From 09aeeadded9de0fe485115f73b744b4ce03f3b45 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sun, 11 Jan 2009 11:03:42 -0600
Subject: [PATCH] Initial checkin of 'git-tool'

---
 extra/git-tool/git-tool.factor | 440 +++++++++++++++++++++++++++++++++
 1 file changed, 440 insertions(+)
 create mode 100644 extra/git-tool/git-tool.factor

diff --git a/extra/git-tool/git-tool.factor b/extra/git-tool/git-tool.factor
new file mode 100644
index 0000000000..2b692f0963
--- /dev/null
+++ b/extra/git-tool/git-tool.factor
@@ -0,0 +1,440 @@
+
+USING: accessors combinators.cleave combinators.short-circuit
+concurrency.combinators destructors fry io io.directories
+io.encodings io.encodings.utf8 io.launcher io.pathnames
+io.pipes io.ports kernel locals math namespaces sequences
+splitting strings ui ui.gadgets ui.gadgets.buttons
+ui.gadgets.editors ui.gadgets.labels ui.gadgets.packs
+ui.gadgets.tracks ;
+
+IN: git-status
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: head** ( seq obj -- seq/f ) dup number? [ head ] [ dupd find drop head ] if ;
+
+: tail** ( seq obj -- seq/f )
+  dup number?
+    [ tail ]
+    [ dupd find drop [ tail ] [ drop f ] if* ]
+  if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: <process-stdout-stderr-reader> ( DESC -- process stream stream )
+  [
+    [let | STDOUT-PIPE [ (pipe) |dispose ]
+           STDERR-PIPE [ (pipe) |dispose ] |
+
+      [let | PROCESS [ DESC >process ] |
+
+        PROCESS
+          [ STDOUT-PIPE out>> or ] change-stdout
+          [ STDERR-PIPE out>> or ] change-stderr
+        run-detached
+
+        STDOUT-PIPE out>> dispose
+        STDERR-PIPE out>> dispose
+
+        STDOUT-PIPE in>> <input-port> utf8 <decoder>
+        STDERR-PIPE in>> <input-port> utf8 <decoder> ] ]
+  ]
+  with-destructors ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: run-process/result ( desc -- process )
+  <process-stdout-stderr-reader>
+  {
+    [ contents [ string-lines ] [ f ] if* ]
+    [ contents [ string-lines ] [ f ] if* ]
+  }
+  parallel-spread
+  [ >>stdout ] [ >>stderr ] bi*
+  dup wait-for-process >>status ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! process popup windows
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: popup-window ( title contents -- )
+  dup string? [ ] [ "\n" join ] if
+  <editor> tuck set-editor-string swap open-window ;
+
+: popup-process-window ( process -- )
+  [ stdout>> [ "output" swap popup-window ] when* ]
+  [ stderr>> [ "error"  swap popup-window ] when* ]
+  [
+    [ stdout>> ] [ stderr>> ] bi or not
+    [ "Process" "NO OUTPUT" popup-window ]
+    when
+  ]
+  tri ;
+
+: popup-if-error ( process -- )
+  { [ status>> 0 = not ] [ popup-process-window t ] } 1&& drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: git-process ( REPO DESC -- process )
+  REPO [ DESC run-process/result ] with-directory ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: git-status-section ( lines section -- lines/f )
+  '[ _ = ] tail**
+    [
+      [ "#\t" head?      ] tail**
+      [ "#\t" head?  not ] head**
+      [ 2 tail ] map
+    ]
+    [ f ]
+  if* ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: colon ( -- ch ) CHAR: : ;
+: space ( -- ch ) 32      ;
+
+: git-status-line-file ( line -- file )
+  { [ colon = ] 1 [ space = not ] } [ tail** ] each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <git-status>
+  repository
+  to-commit-new
+  to-commit-modified
+  to-commit-deleted
+  modified
+  deleted
+  untracked ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: check-empty ( seq -- seq/f ) dup empty? [ drop f ] when ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: refresh-git-status ( GIT-STATUS -- GIT-STATUS )
+
+  [let | LINES [ GIT-STATUS repository>> "git-status" git-process stdout>> ] |
+
+    GIT-STATUS
+    
+      LINES "# Changes to be committed:" git-status-section
+        [ "new file:" head? ] filter
+        [ git-status-line-file ] map
+        check-empty
+      >>to-commit-new
+    
+      LINES "# Changes to be committed:" git-status-section
+        [ "modified:" head? ] filter
+        [ git-status-line-file ] map
+        check-empty
+      >>to-commit-modified
+
+      LINES "# Changes to be committed:" git-status-section
+        [ "deleted:" head? ] filter
+        [ git-status-line-file ] map
+        check-empty
+      >>to-commit-deleted
+
+      LINES "# Changed but not updated:" git-status-section
+        [ "modified:" head? ] filter
+        [ git-status-line-file ] map
+        check-empty
+      >>modified
+    
+      LINES "# Changed but not updated:" git-status-section
+        [ "deleted:" head? ] filter
+        [ git-status-line-file ] map
+        check-empty
+      >>deleted
+
+      LINES "# Untracked files:" git-status-section >>untracked ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: git-status ( REPO -- <git-status> )
+
+  <git-status> new REPO >>repository refresh-git-status ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: factor-git-status ( -- <git-status> ) "resource:" git-status ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! git-tool
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: to-commit ( <git-status> -- seq )
+  { to-commit-new>> to-commit-modified>> to-commit-deleted>> } 1arr concat ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: refresh-status-pile ( STATUS PILE -- )
+
+  STATUS refresh-git-status drop
+
+  PILE clear-gadget
+
+  PILE
+
+  ! Commit section
+
+  [wlet | add-commit-path-button [| TEXT PATH |
+
+            { 1 0 } <track>
+
+              TEXT <label> 2/8 track-add
+              PATH <label> 6/8 track-add
+
+              "Reset"
+              [
+                drop
+                
+                STATUS repository>>
+                { "git" "reset" "HEAD" PATH }
+                git-process
+                drop
+                
+                STATUS PILE refresh-status-pile
+              ]
+              <bevel-button> f track-add
+
+            add-gadget ] |
+
+    STATUS to-commit
+    [
+      "Changes to be committed" <label> reverse-video-theme add-gadget
+
+      STATUS to-commit-new>>
+      [| PATH | "new file: " PATH add-commit-path-button ]
+      each
+
+      STATUS to-commit-modified>>
+      [| PATH | "modified: " PATH add-commit-path-button ]
+      each
+
+      STATUS to-commit-deleted>>
+      [| PATH | "deleted: " PATH add-commit-path-button ]
+      each
+
+      <pile> 1 >>fill
+
+        [let | EDITOR [ <editor> "COMMIT MESSAGE" over set-editor-string ] |
+
+          EDITOR add-gadget
+  
+          "Commit"
+          [
+           drop
+           [let | MSG [ EDITOR editor-string ] |
+
+              STATUS repository>>
+              { "git" "commit" "-m" MSG } git-process
+              popup-if-error ]
+           STATUS PILE refresh-status-pile
+          ]
+          <bevel-button>
+          add-gadget ]
+       
+      add-gadget
+
+    ]
+    when ]
+
+  ! Modified section
+
+  STATUS modified>>
+  [
+    "Modified but not updated" <label> reverse-video-theme add-gadget
+
+    STATUS modified>>
+    [| PATH |
+
+      <shelf>
+
+        PATH <label> add-gadget
+
+        "Add"
+        [
+          drop
+          STATUS repository>> { "git" "add" PATH } git-process popup-if-error
+          STATUS PILE refresh-status-pile
+        ]
+        <bevel-button> add-gadget
+
+        "Diff"
+        [
+          drop
+          STATUS repository>> { "git-diff" PATH } git-process
+          popup-process-window
+        ]
+        <bevel-button> add-gadget
+
+      add-gadget
+      
+    ]
+    each
+    
+  ]
+  when
+
+  ! Untracked section
+
+  STATUS untracked>>
+  [
+    "Untracked files" <label> reverse-video-theme add-gadget
+
+    STATUS untracked>>
+    [| PATH |
+
+      { 1 0 } <track>
+
+        PATH <label> f track-add
+
+        "Add"
+        [
+          drop
+          STATUS repository>> { "git" "add" PATH } git-process popup-if-error
+          STATUS PILE refresh-status-pile
+        ]
+        <bevel-button> f track-add
+
+      add-gadget
+
+    ]
+    each
+    
+  ]
+  when
+
+  ! Refresh button
+
+  "Refresh" [ drop STATUS PILE refresh-status-pile ] <bevel-button> add-gadget
+
+  drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: git-remote-branches ( REPO NAME -- seq )
+  REPO { "git-remote" "show" NAME } git-process stdout>>
+  "  Tracked remote branches" over index 1 + tail first " " split
+  [ empty? not ] filter ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: refresh-remotes-pile ( REPO PILE -- )
+
+  PILE clear-gadget
+
+  PILE
+  
+  "Remotes" <label> reverse-video-theme add-gadget
+
+  REPO "git-remote" git-process stdout>> [ empty? not ] filter
+
+  [| NAME |
+
+    [let | BRANCH! [ "master" ] |
+  
+      { 1 0 } <track>
+  
+        NAME <label> 1 track-add
+
+        [let | BRANCH-BUTTON [ "master" [ drop ] <bevel-button> ] |
+
+          BRANCH-BUTTON
+          [
+            drop
+                  
+            <pile>
+                  
+              1 >>fill
+    
+              REPO NAME git-remote-branches
+                [| OTHER-BRANCH |
+                  OTHER-BRANCH
+                    [
+                      drop
+                          
+                      OTHER-BRANCH BRANCH!
+                          
+                      OTHER-BRANCH BRANCH-BUTTON gadget-child set-label-string
+                          
+                    ]
+                  <bevel-button>
+                  add-gadget
+                ]
+              each
+                    
+            "Select a branch" open-window
+           ]
+           >>quot
+
+           1 track-add ]
+  
+        "Fetch"
+        [ drop REPO { "git-fetch" NAME } git-process popup-process-window ]
+        <bevel-button>
+        1 track-add
+  
+        "..remote/branch"
+        [
+          drop
+          [let | ARG [ { ".." NAME "/" BRANCH } concat ] |
+            REPO { "git-log" ARG } git-process popup-process-window ]
+        ]
+        <bevel-button>
+        1 track-add
+  
+        "Merge"
+        [
+          drop
+          [let | ARG [ { NAME "/" BRANCH } concat ] |
+            REPO { "git-merge" ARG } git-process popup-process-window ]
+        ]
+        <bevel-button>
+        1 track-add
+  
+        "remote/branch.."
+        [
+          drop
+          [let | ARG [ { NAME "/" BRANCH ".." } concat ] |
+            REPO { "git-log" ARG } git-process popup-process-window ]
+        ]
+        <bevel-button>
+        1 track-add
+  
+        "Push"
+        [
+          drop
+          REPO { "git-push" NAME "master" } git-process popup-process-window 
+        ]
+        <bevel-button>
+        1 track-add
+
+        add-gadget ]
+
+    ]
+  each
+
+  drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: git-tool ( REPO -- )
+
+  <pile> 1 >>fill
+
+    "Repository: " REPO [ current-directory get ] with-directory append
+    <label>
+    add-gadget
+
+    REPO git-status <pile> 1 >>fill tuck refresh-status-pile  add-gadget
+    REPO            <pile> 1 >>fill tuck refresh-remotes-pile add-gadget
+
+  "Git" open-window ;
+  
\ No newline at end of file
-- 
2.34.1