extra/git-tool/remote/remote.factor

   1
   2 USING: accessors calendar git-tool git-tool io.directories
   3 io.monitors io.pathnames kernel locals math namespaces
   4 sequences splitting system threads ui ui.gadgets
   5 ui.gadgets.buttons ui.gadgets.labels ui.gadgets.packs ;
   6
   7 USING: git-tool ;
   8
   9 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  10
  11 IN: git-tool.remote
  12
  13 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  14
  15 TUPLE: <git-remote-gadget> < pack
  16   repository
  17   branch
  18   remote
  19   remote-branch
  20   fetch-period
  21   push
  22   closed
  23   last-refresh ;
  24
  25 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  26
  27 : current-branch ( REPO -- branch )
  28   { "git" "branch" } git-process stdout>> [ "* " head? ] find nip 2 tail ;
  29
  30 : list-branches ( REPO -- branches )
  31   { "git" "branch" } git-process stdout>>
  32   [ empty? not ] filter
  33   [ 2 tail ] map ;
  34
  35 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  36
  37 : list-remotes ( REPO -- remotes )
  38   { "git" "remote" } git-process stdout>> [ empty? not ] filter ;
  39
  40 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  41
  42 :: list-remote-branches ( REPO REMOTE -- branches )
  43   [let | OUT [ REPO { "git" "remote" "show" REMOTE } git-process stdout>> ] |
  44
  45     "  Tracked remote branches" OUT member?
  46       [
  47         OUT
  48         "  Tracked remote branches" OUT index 1 + tail first " " split
  49         [ empty? not ] filter
  50       ]
  51       [
  52         OUT
  53         OUT [ "  New remote branches" head? ] find drop
  54         1 + tail first " " split
  55         [ empty? not ] filter
  56       ]
  57     if ] ;
  58
  59 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  60
  61 :: refresh-git-remote-gadget ( GADGET -- )
  62
  63   [let | REPO [ GADGET repository>> ] |
  64
  65     GADGET clear-gadget
  66
  67     GADGET
  68
  69     ! Repository label
  70
  71     "Repository: " REPO [ current-directory get ] with-directory append
  72     <label>
  73     add-gadget
  74
  75     ! Branch button
  76
  77     <shelf>
  78
  79       "Branch: " <label> add-gadget
  80
  81       REPO current-branch
  82       [
  83         drop
  84
  85         <pile>
  86           REPO list-branches
  87
  88           [| BRANCH |
  89
  90             BRANCH
  91             [
  92               drop
  93               REPO { "git" "checkout" BRANCH } git-process popup-if-error
  94               GADGET refresh-git-remote-gadget
  95             ]
  96             <bevel-button> add-gadget
  97
  98           ]
  99           each
 100
 101         "Select a branch" open-window
 102
 103       ]
 104       <bevel-button> add-gadget
 105
 106     add-gadget
 107
 108     ! Remote button
 109
 110     <shelf>
 111
 112       "Remote: " <label> add-gadget
 113
 114       GADGET remote>>
 115       [
 116         drop
 117
 118         <pile>
 119
 120           REPO list-remotes
 121
 122           [| REMOTE |
 123
 124             REMOTE
 125             [
 126               drop
 127               GADGET REMOTE >>remote drop
 128               GADGET "master" >>remote-branch drop
 129               GADGET refresh-git-remote-gadget
 130             ]
 131             <bevel-button> add-gadget
 132
 133           ]
 134           each
 135
 136         "Select a remote" open-window
 137
 138       ]
 139       <bevel-button> add-gadget
 140
 141     add-gadget
 142
 143     ! Remote branch button
 144
 145     <shelf>
 146
 147       "Remote branch: " <label> add-gadget
 148
 149       GADGET remote-branch>>
 150       [
 151         drop
 152
 153         <pile>
 154
 155           REPO GADGET remote>> list-remote-branches
 156
 157           [| REMOTE-BRANCH |
 158
 159             REMOTE-BRANCH
 160             [
 161               drop
 162               GADGET REMOTE-BRANCH >>remote-branch drop
 163               GADGET refresh-git-remote-gadget
 164             ]
 165             <bevel-button> add-gadget
 166           ]
 167
 168           each
 169
 170         "Select a remote branch" open-window
 171
 172       ]
 173       <bevel-button> add-gadget
 174
 175     add-gadget
 176
 177     ! Fetch button
 178
 179     "Fetch"
 180     [
 181       drop
 182       [let | REMOTE [ GADGET remote>> ] |
 183         REPO { "git" "fetch" REMOTE } git-process popup-if-error ]
 184
 185       GADGET refresh-git-remote-gadget
 186     ]
 187     <bevel-button> add-gadget
 188
 189     ! Available changes
 190
 191     [let | REMOTE        [ GADGET remote>>        ]
 192            REMOTE-BRANCH [ GADGET remote-branch>> ] |
 193
 194       [let | ARG [ { ".." REMOTE "/" REMOTE-BRANCH } concat ] |
 195
 196         [let | PROCESS [ REPO { "git" "log" ARG } git-process ] |
 197
 198           PROCESS stdout>>
 199             [
 200               <shelf>
 201
 202                 "Changes available:" <label> add-gadget
 203
 204                 "View"
 205                 [
 206                   drop
 207                   PROCESS popup-process-window
 208                 ]
 209                 <bevel-button> add-gadget
 210
 211                 "Merge"
 212                 [
 213                   drop
 214
 215                   [let | ARG [ { REMOTE "/" REMOTE-BRANCH } concat ] |
 216
 217                     REPO { "git" "merge" ARG } git-process popup-process-window
 218
 219                   ]
 220
 221                   GADGET refresh-git-remote-gadget
 222
 223                 ]
 224                 <bevel-button> add-gadget
 225
 226               add-gadget
 227
 228             ]
 229           when
 230
 231         ] ] ]
 232
 233
 234     ! Pushable changes
 235
 236     [let | REMOTE        [ GADGET remote>>        ]
 237            REMOTE-BRANCH [ GADGET remote-branch>> ] |
 238
 239       [let | ARG [ { REMOTE "/" REMOTE-BRANCH ".." } concat ] |
 240
 241         [let | PROCESS [ REPO { "git" "log" ARG } git-process ] |
 242
 243           PROCESS stdout>>
 244             [
 245               <shelf>
 246
 247                 "Pushable changes: " <label> add-gadget
 248
 249                 "View"
 250                 [
 251                   drop
 252                   PROCESS popup-process-window
 253                 ]
 254                 <bevel-button> add-gadget
 255
 256                 "Push"
 257                 [
 258                   drop
 259
 260                   REPO { "git" "push" REMOTE REMOTE-BRANCH }
 261                   git-process
 262                   popup-process-window
 263
 264                   GADGET refresh-git-remote-gadget
 265
 266                 ]
 267                 <bevel-button> add-gadget
 268
 269               add-gadget
 270
 271             ]
 272           when
 273
 274         ] ] ]
 275
 276     drop
 277
 278   ] ;
 279
 280 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 281
 282 :: start-fetch-thread ( GADGET -- )
 283
 284   GADGET f >>closed drop
 285
 286   [
 287
 288     [
 289
 290       GADGET closed>>
 291         [ f ]
 292         [
 293           [let | REPO          [ GADGET repository>> ]
 294                  REMOTE-BRANCH [ GADGET remote-branch>> ] |
 295
 296             REPO { "git" "fetch" REMOTE-BRANCH } git-process drop ]
 297
 298           GADGET fetch-period>> sleep
 299
 300           t
 301         ]
 302       if
 303
 304
 305     ]
 306     loop
 307
 308   ]
 309
 310   in-thread ;
 311
 312 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 313
 314 :: start-monitor-thread ( GADGET -- )
 315
 316   GADGET f >>closed drop
 317
 318   [
 319     [
 320       [let | MONITOR [ GADGET repository>> t <monitor> ] |
 321
 322         [
 323           GADGET closed>>
 324           [ f ]
 325           [
 326
 327             [let | PATH [ MONITOR next-change drop ] |
 328
 329               ".git" PATH subseq?
 330                 [ ]
 331                 [
 332                   micros
 333                   GADGET last-refresh>> 0 or -
 334                   1000000 >
 335                     [
 336                       GADGET micros >>last-refresh drop
 337                       GADGET refresh-git-remote-gadget
 338                     ]
 339                   when
 340                 ]
 341               if ]
 342
 343             t
 344
 345           ]
 346           if
 347         ]
 348         loop
 349       ]
 350     ]
 351     with-monitors
 352   ]
 353   in-thread ;
 354
 355 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 356
 357 M: <git-remote-gadget> pref-dim* ( gadget -- dim ) drop { 500 500 } ;
 358
 359 M:: <git-remote-gadget> graft*   ( GADGET -- )
 360   GADGET start-fetch-thread
 361   GADGET start-monitor-thread ;
 362
 363 M:: <git-remote-gadget> ungraft* ( GADGET -- ) GADGET t >>closed drop ;
 364
 365 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 366
 367 :: git-remote-tool ( REPO -- )
 368
 369   <git-remote-gadget> new-gadget
 370
 371     { 0 1 } >>orientation
 372     1       >>fill
 373
 374     REPO >>repository
 375
 376     "origin" >>remote
 377
 378     "master" >>remote-branch
 379
 380     5 minutes >>fetch-period
 381
 382   dup refresh-git-remote-gadget
 383
 384   "git-remote-tool" open-window ;
 385
 386 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 387
 388 : factor-git-remote-tool ( -- ) "resource:" git-remote-tool ;
 389
 390 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 391
 392 MAIN: factor-git-remote-tool