extra/git-tool/git-tool.factor

   1
   2 USING: accessors combinators.cleave combinators.short-circuit
   3 concurrency.combinators destructors fry io io.directories
   4 io.encodings io.encodings.utf8 io.launcher io.monitors
   5 io.pathnames io.pipes io.ports kernel locals math namespaces
   6 sequences splitting strings threads ui ui.gadgets
   7 ui.gadgets.buttons ui.gadgets.editors ui.gadgets.labels
   8 ui.gadgets.packs ui.gadgets.tracks ;
   9
  10 IN: git-tool
  11
  12 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  13
  14 : head** ( seq obj -- seq/f ) dup number? [ head ] [ dupd find drop head ] if ;
  15
  16 : tail** ( seq obj -- seq/f )
  17   dup number?
  18     [ tail ]
  19     [ dupd find drop [ tail ] [ drop f ] if* ]
  20   if ;
  21
  22 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  23
  24 :: <process-stdout-stderr-reader> ( DESC -- process stream stream )
  25   [
  26     [let | STDOUT-PIPE [ (pipe) |dispose ]
  27            STDERR-PIPE [ (pipe) |dispose ] |
  28
  29       [let | PROCESS [ DESC >process ] |
  30
  31         PROCESS
  32           [ STDOUT-PIPE out>> or ] change-stdout
  33           [ STDERR-PIPE out>> or ] change-stderr
  34         run-detached
  35
  36         STDOUT-PIPE out>> dispose
  37         STDERR-PIPE out>> dispose
  38
  39         STDOUT-PIPE in>> <input-port> utf8 <decoder>
  40         STDERR-PIPE in>> <input-port> utf8 <decoder> ] ]
  41   ]
  42   with-destructors ;
  43
  44 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  45
  46 : run-process/result ( desc -- process )
  47   <process-stdout-stderr-reader>
  48   {
  49     [ contents [ string-lines ] [ f ] if* ]
  50     [ contents [ string-lines ] [ f ] if* ]
  51   }
  52   parallel-spread
  53   [ >>stdout ] [ >>stderr ] bi*
  54   dup wait-for-process >>status ;
  55
  56 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  57 ! process popup windows
  58 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  59
  60 : popup-window ( title contents -- )
  61   dup string? [ ] [ "\n" join ] if
  62   <editor> tuck set-editor-string swap open-window ;
  63
  64 : popup-process-window ( process -- )
  65   [ stdout>> [ "output" swap popup-window ] when* ]
  66   [ stderr>> [ "error"  swap popup-window ] when* ]
  67   [
  68     [ stdout>> ] [ stderr>> ] bi or not
  69     [ "Process" "NO OUTPUT" popup-window ]
  70     when
  71   ]
  72   tri ;
  73
  74 : popup-if-error ( process -- )
  75   { [ status>> 0 = not ] [ popup-process-window t ] } 1&& drop ;
  76
  77 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  78
  79 :: git-process ( REPO DESC -- process )
  80   REPO [ DESC run-process/result ] with-directory ;
  81
  82 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  83
  84 : git-status-section ( lines section -- lines/f )
  85   '[ _ = ] tail**
  86     [
  87       [ "#\t" head?      ] tail**
  88       [ "#\t" head?  not ] head**
  89       [ 2 tail ] map
  90     ]
  91     [ f ]
  92   if* ;
  93
  94 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  95
  96 : colon ( -- ch ) CHAR: : ;
  97 : space ( -- ch ) 32      ;
  98
  99 : git-status-line-file ( line -- file )
 100   { [ colon = ] 1 [ space = not ] } [ tail** ] each ;
 101
 102 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 103
 104 TUPLE: <git-status>
 105   repository
 106   to-commit-new
 107   to-commit-modified
 108   to-commit-deleted
 109   modified
 110   deleted
 111   untracked ;
 112
 113 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 114
 115 : check-empty ( seq -- seq/f ) dup empty? [ drop f ] when ;
 116
 117 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 118
 119 :: refresh-git-status ( STATUS -- STATUS )
 120
 121   [let | LINES [ STATUS repository>> { "git" "status" } git-process stdout>> ] |
 122
 123     STATUS
 124
 125       LINES "# Changes to be committed:" git-status-section
 126         [ "new file:" head? ] filter
 127         [ git-status-line-file ] map
 128         check-empty
 129       >>to-commit-new
 130
 131       LINES "# Changes to be committed:" git-status-section
 132         [ "modified:" head? ] filter
 133         [ git-status-line-file ] map
 134         check-empty
 135       >>to-commit-modified
 136
 137       LINES "# Changes to be committed:" git-status-section
 138         [ "deleted:" head? ] filter
 139         [ git-status-line-file ] map
 140         check-empty
 141       >>to-commit-deleted
 142
 143       LINES "# Changed but not updated:" git-status-section
 144         [ "modified:" head? ] filter
 145         [ git-status-line-file ] map
 146         check-empty
 147       >>modified
 148
 149       LINES "# Changed but not updated:" git-status-section
 150         [ "deleted:" head? ] filter
 151         [ git-status-line-file ] map
 152         check-empty
 153       >>deleted
 154
 155       LINES "# Untracked files:" git-status-section >>untracked ] ;
 156
 157 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 158
 159 :: git-status ( REPO -- <git-status> )
 160
 161   <git-status> new REPO >>repository refresh-git-status ;
 162
 163 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 164
 165 :: factor-git-status ( -- <git-status> ) "resource:" git-status ;
 166
 167 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 168 ! git-tool
 169 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 170
 171 : to-commit ( <git-status> -- seq )
 172   { to-commit-new>> to-commit-modified>> to-commit-deleted>> } 1arr concat ;
 173
 174 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 175
 176 :: refresh-status-pile ( STATUS PILE -- )
 177
 178   STATUS refresh-git-status drop
 179
 180   PILE clear-gadget
 181
 182   PILE
 183
 184   ! Commit section
 185
 186   [wlet | add-commit-path-button [| TEXT PATH |
 187
 188             { 1 0 } <track>
 189
 190               TEXT <label> 2/8 track-add
 191               PATH <label> 6/8 track-add
 192
 193               "Reset"
 194               [
 195                 drop
 196
 197                 STATUS repository>>
 198                 { "git" "reset" "HEAD" PATH }
 199                 git-process
 200                 drop
 201
 202                 STATUS PILE refresh-status-pile
 203               ]
 204               <bevel-button> f track-add
 205
 206             add-gadget ] |
 207
 208     STATUS to-commit
 209     [
 210       "Changes to be committed" <label> reverse-video-theme add-gadget
 211
 212       STATUS to-commit-new>>
 213       [| PATH | "new file: " PATH add-commit-path-button ]
 214       each
 215
 216       STATUS to-commit-modified>>
 217       [| PATH | "modified: " PATH add-commit-path-button ]
 218       each
 219
 220       STATUS to-commit-deleted>>
 221       [| PATH | "deleted: " PATH add-commit-path-button ]
 222       each
 223
 224       <pile> 1 >>fill
 225
 226         [let | EDITOR [ <editor> "COMMIT MESSAGE" over set-editor-string ] |
 227
 228           EDITOR add-gadget
 229
 230           "Commit"
 231           [
 232            drop
 233            [let | MSG [ EDITOR editor-string ] |
 234
 235               STATUS repository>>
 236               { "git" "commit" "-m" MSG } git-process
 237               popup-if-error ]
 238            STATUS PILE refresh-status-pile
 239           ]
 240           <bevel-button>
 241           add-gadget ]
 242
 243       add-gadget
 244
 245     ]
 246     when ]
 247
 248   ! Modified section
 249
 250   STATUS modified>>
 251   [
 252     "Modified but not updated" <label> reverse-video-theme add-gadget
 253
 254     STATUS modified>>
 255     [| PATH |
 256
 257       <shelf>
 258
 259         PATH <label> add-gadget
 260
 261         "Add"
 262         [
 263           drop
 264           STATUS repository>> { "git" "add" PATH } git-process popup-if-error
 265           STATUS PILE refresh-status-pile
 266         ]
 267         <bevel-button> add-gadget
 268
 269         "Diff"
 270         [
 271           drop
 272           STATUS repository>> { "git" "diff" PATH } git-process
 273           popup-process-window
 274         ]
 275         <bevel-button> add-gadget
 276
 277       add-gadget
 278
 279     ]
 280     each
 281
 282   ]
 283   when
 284
 285   ! Untracked section
 286
 287   STATUS untracked>>
 288   [
 289     "Untracked files" <label> reverse-video-theme add-gadget
 290
 291     STATUS untracked>>
 292     [| PATH |
 293
 294       { 1 0 } <track>
 295
 296         PATH <label> f track-add
 297
 298         "Add"
 299         [
 300           drop
 301           STATUS repository>> { "git" "add" PATH } git-process popup-if-error
 302           STATUS PILE refresh-status-pile
 303         ]
 304         <bevel-button> f track-add
 305
 306       add-gadget
 307
 308     ]
 309     each
 310
 311   ]
 312   when
 313
 314   ! Refresh button
 315
 316   "Refresh" [ drop STATUS PILE refresh-status-pile ] <bevel-button> add-gadget
 317
 318   drop ;
 319
 320 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 321
 322 :: git-remote-branches ( REPO NAME -- seq )
 323   REPO { "git" "remote" "show" NAME } git-process stdout>>
 324   "  Tracked remote branches" over index 1 + tail first " " split
 325   [ empty? not ] filter ;
 326
 327 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 328
 329 :: refresh-remotes-pile ( REPO PILE -- )
 330
 331   PILE clear-gadget
 332
 333   PILE
 334
 335   "Remotes" <label> reverse-video-theme add-gadget
 336
 337   REPO { "git" "remote" } git-process stdout>> [ empty? not ] filter
 338
 339   [| NAME |
 340
 341     [let | BRANCH! [ "master" ] |
 342
 343       { 1 0 } <track>
 344
 345         NAME <label> 1 track-add
 346
 347         [let | BRANCH-BUTTON [ "master" [ drop ] <bevel-button> ] |
 348
 349           BRANCH-BUTTON
 350           [
 351             drop
 352
 353             <pile>
 354
 355               1 >>fill
 356
 357               REPO NAME git-remote-branches
 358                 [| OTHER-BRANCH |
 359                   OTHER-BRANCH
 360                     [
 361                       drop
 362
 363                       OTHER-BRANCH BRANCH!
 364
 365                       OTHER-BRANCH BRANCH-BUTTON gadget-child set-label-string
 366
 367                     ]
 368                   <bevel-button>
 369                   add-gadget
 370                 ]
 371               each
 372
 373             "Select a branch" open-window
 374            ]
 375            >>quot
 376
 377            1 track-add ]
 378
 379         "Fetch"
 380         [ drop REPO { "git" "fetch" NAME } git-process popup-process-window ]
 381         <bevel-button>
 382         1 track-add
 383
 384         "..remote/branch"
 385         [
 386           drop
 387           [let | ARG [ { ".." NAME "/" BRANCH } concat ] |
 388             REPO { "git" "log" ARG } git-process popup-process-window ]
 389         ]
 390         <bevel-button>
 391         1 track-add
 392
 393         "Merge"
 394         [
 395           drop
 396           [let | ARG [ { NAME "/" BRANCH } concat ] |
 397             REPO { "git" "merge" ARG } git-process popup-process-window ]
 398         ]
 399         <bevel-button>
 400         1 track-add
 401
 402         "remote/branch.."
 403         [
 404           drop
 405           [let | ARG [ { NAME "/" BRANCH ".." } concat ] |
 406             REPO { "git" "log" ARG } git-process popup-process-window ]
 407         ]
 408         <bevel-button>
 409         1 track-add
 410
 411         "Push"
 412         [
 413           drop
 414           REPO { "git" "push" NAME "master" } git-process popup-process-window
 415         ]
 416         <bevel-button>
 417         1 track-add
 418
 419         add-gadget ]
 420
 421     ]
 422   each
 423
 424   drop ;
 425
 426 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 427
 428 :: git-tool ( REPO -- )
 429
 430   <pile> 1 >>fill
 431
 432     "Repository: " REPO [ current-directory get ] with-directory append
 433     <label>
 434     add-gadget
 435
 436     [let | STATUS [ REPO git-status ]
 437            PILE   [ <pile> 1 >>fill ] |
 438
 439       [
 440         [
 441           [let | MONITOR [ REPO t <monitor> ] |
 442             [
 443               [let | PATH [ MONITOR next-change drop ] |
 444                 ".git" PATH subseq? ! Ignore git internal operations
 445                   [ ]
 446                   [ STATUS PILE refresh-status-pile ]
 447                 if
 448                 t ]
 449             ]
 450             loop
 451           ]
 452         ]
 453         with-monitors
 454       ]
 455       in-thread
 456
 457       STATUS PILE refresh-status-pile
 458
 459       PILE add-gadget ]
 460
 461     REPO <pile> 1 >>fill tuck refresh-remotes-pile add-gadget
 462
 463   "Git" open-window ;
 464
 465 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 466
 467 : factor-git-tool ( -- ) "resource:" git-tool ;
 468
 469 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 470