Merge git://github.com/dharmatech/factor into new_ui
Slava Pestov
commit
463599a931
|
|
@ -1,470 +0,0 @@
|
||||||
|
|
||||||
USING: accessors combinators.cleave combinators.short-circuit
|
|
||||||
concurrency.combinators destructors fry io io.directories
|
|
||||||
io.encodings io.encodings.utf8 io.launcher io.monitors
|
|
||||||
io.pathnames io.pipes io.ports kernel locals math namespaces
|
|
||||||
sequences splitting strings threads ui ui.gadgets
|
|
||||||
ui.gadgets.buttons ui.gadgets.editors ui.gadgets.labels
|
|
||||||
ui.gadgets.packs ui.gadgets.tracks ;
|
|
||||||
|
|
||||||
IN: git-tool
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
: 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 ( STATUS -- STATUS )
|
|
||||||
|
|
||||||
[let | LINES [ STATUS repository>> { "git" "status" } git-process stdout>> ] |
|
|
||||||
|
|
||||||
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
|
|
||||||
|
|
||||||
[let | STATUS [ REPO git-status ]
|
|
||||||
PILE [ <pile> 1 >>fill ] |
|
|
||||||
|
|
||||||
[
|
|
||||||
[
|
|
||||||
[let | MONITOR [ REPO t <monitor> ] |
|
|
||||||
[
|
|
||||||
[let | PATH [ MONITOR next-change drop ] |
|
|
||||||
".git" PATH subseq? ! Ignore git internal operations
|
|
||||||
[ ]
|
|
||||||
[ STATUS PILE refresh-status-pile ]
|
|
||||||
if
|
|
||||||
t ]
|
|
||||||
]
|
|
||||||
loop
|
|
||||||
]
|
|
||||||
]
|
|
||||||
with-monitors
|
|
||||||
]
|
|
||||||
in-thread
|
|
||||||
|
|
||||||
STATUS PILE refresh-status-pile
|
|
||||||
|
|
||||||
PILE add-gadget ]
|
|
||||||
|
|
||||||
REPO <pile> 1 >>fill tuck refresh-remotes-pile add-gadget
|
|
||||||
|
|
||||||
"Git" open-window ;
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
: factor-git-tool ( -- ) "resource:" git-tool ;
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
|
|
@ -1,392 +0,0 @@
|
||||||
|
|
||||||
USING: accessors calendar git-tool git-tool io.directories
|
|
||||||
io.monitors io.pathnames kernel locals math namespaces
|
|
||||||
sequences splitting system threads ui ui.gadgets
|
|
||||||
ui.gadgets.buttons ui.gadgets.labels ui.gadgets.packs ;
|
|
||||||
|
|
||||||
USING: git-tool ;
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
IN: git-tool.remote
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
TUPLE: <git-remote-gadget> < pack
|
|
||||||
repository
|
|
||||||
branch
|
|
||||||
remote
|
|
||||||
remote-branch
|
|
||||||
fetch-period
|
|
||||||
push
|
|
||||||
closed
|
|
||||||
last-refresh ;
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
: current-branch ( REPO -- branch )
|
|
||||||
{ "git" "branch" } git-process stdout>> [ "* " head? ] find nip 2 tail ;
|
|
||||||
|
|
||||||
: list-branches ( REPO -- branches )
|
|
||||||
{ "git" "branch" } git-process stdout>>
|
|
||||||
[ empty? not ] filter
|
|
||||||
[ 2 tail ] map ;
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
: list-remotes ( REPO -- remotes )
|
|
||||||
{ "git" "remote" } git-process stdout>> [ empty? not ] filter ;
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
:: list-remote-branches ( REPO REMOTE -- branches )
|
|
||||||
[let | OUT [ REPO { "git" "remote" "show" REMOTE } git-process stdout>> ] |
|
|
||||||
|
|
||||||
" Tracked remote branches" OUT member?
|
|
||||||
[
|
|
||||||
OUT
|
|
||||||
" Tracked remote branches" OUT index 1 + tail first " " split
|
|
||||||
[ empty? not ] filter
|
|
||||||
]
|
|
||||||
[
|
|
||||||
OUT
|
|
||||||
OUT [ " New remote branches" head? ] find drop
|
|
||||||
1 + tail first " " split
|
|
||||||
[ empty? not ] filter
|
|
||||||
]
|
|
||||||
if ] ;
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
:: refresh-git-remote-gadget ( GADGET -- )
|
|
||||||
|
|
||||||
[let | REPO [ GADGET repository>> ] |
|
|
||||||
|
|
||||||
GADGET clear-gadget
|
|
||||||
|
|
||||||
GADGET
|
|
||||||
|
|
||||||
! Repository label
|
|
||||||
|
|
||||||
"Repository: " REPO [ current-directory get ] with-directory append
|
|
||||||
<label>
|
|
||||||
add-gadget
|
|
||||||
|
|
||||||
! Branch button
|
|
||||||
|
|
||||||
<shelf>
|
|
||||||
|
|
||||||
"Branch: " <label> add-gadget
|
|
||||||
|
|
||||||
REPO current-branch
|
|
||||||
[
|
|
||||||
drop
|
|
||||||
|
|
||||||
<pile>
|
|
||||||
REPO list-branches
|
|
||||||
|
|
||||||
[| BRANCH |
|
|
||||||
|
|
||||||
BRANCH
|
|
||||||
[
|
|
||||||
drop
|
|
||||||
REPO { "git" "checkout" BRANCH } git-process popup-if-error
|
|
||||||
GADGET refresh-git-remote-gadget
|
|
||||||
]
|
|
||||||
<bevel-button> add-gadget
|
|
||||||
|
|
||||||
]
|
|
||||||
each
|
|
||||||
|
|
||||||
"Select a branch" open-window
|
|
||||||
|
|
||||||
]
|
|
||||||
<bevel-button> add-gadget
|
|
||||||
|
|
||||||
add-gadget
|
|
||||||
|
|
||||||
! Remote button
|
|
||||||
|
|
||||||
<shelf>
|
|
||||||
|
|
||||||
"Remote: " <label> add-gadget
|
|
||||||
|
|
||||||
GADGET remote>>
|
|
||||||
[
|
|
||||||
drop
|
|
||||||
|
|
||||||
<pile>
|
|
||||||
|
|
||||||
REPO list-remotes
|
|
||||||
|
|
||||||
[| REMOTE |
|
|
||||||
|
|
||||||
REMOTE
|
|
||||||
[
|
|
||||||
drop
|
|
||||||
GADGET REMOTE >>remote drop
|
|
||||||
GADGET "master" >>remote-branch drop
|
|
||||||
GADGET refresh-git-remote-gadget
|
|
||||||
]
|
|
||||||
<bevel-button> add-gadget
|
|
||||||
|
|
||||||
]
|
|
||||||
each
|
|
||||||
|
|
||||||
"Select a remote" open-window
|
|
||||||
|
|
||||||
]
|
|
||||||
<bevel-button> add-gadget
|
|
||||||
|
|
||||||
add-gadget
|
|
||||||
|
|
||||||
! Remote branch button
|
|
||||||
|
|
||||||
<shelf>
|
|
||||||
|
|
||||||
"Remote branch: " <label> add-gadget
|
|
||||||
|
|
||||||
GADGET remote-branch>>
|
|
||||||
[
|
|
||||||
drop
|
|
||||||
|
|
||||||
<pile>
|
|
||||||
|
|
||||||
REPO GADGET remote>> list-remote-branches
|
|
||||||
|
|
||||||
[| REMOTE-BRANCH |
|
|
||||||
|
|
||||||
REMOTE-BRANCH
|
|
||||||
[
|
|
||||||
drop
|
|
||||||
GADGET REMOTE-BRANCH >>remote-branch drop
|
|
||||||
GADGET refresh-git-remote-gadget
|
|
||||||
]
|
|
||||||
<bevel-button> add-gadget
|
|
||||||
]
|
|
||||||
|
|
||||||
each
|
|
||||||
|
|
||||||
"Select a remote branch" open-window
|
|
||||||
|
|
||||||
]
|
|
||||||
<bevel-button> add-gadget
|
|
||||||
|
|
||||||
add-gadget
|
|
||||||
|
|
||||||
! Fetch button
|
|
||||||
|
|
||||||
"Fetch"
|
|
||||||
[
|
|
||||||
drop
|
|
||||||
[let | REMOTE [ GADGET remote>> ] |
|
|
||||||
REPO { "git" "fetch" REMOTE } git-process popup-if-error ]
|
|
||||||
|
|
||||||
GADGET refresh-git-remote-gadget
|
|
||||||
]
|
|
||||||
<bevel-button> add-gadget
|
|
||||||
|
|
||||||
! Available changes
|
|
||||||
|
|
||||||
[let | REMOTE [ GADGET remote>> ]
|
|
||||||
REMOTE-BRANCH [ GADGET remote-branch>> ] |
|
|
||||||
|
|
||||||
[let | ARG [ { ".." REMOTE "/" REMOTE-BRANCH } concat ] |
|
|
||||||
|
|
||||||
[let | PROCESS [ REPO { "git" "log" ARG } git-process ] |
|
|
||||||
|
|
||||||
PROCESS stdout>>
|
|
||||||
[
|
|
||||||
<shelf>
|
|
||||||
|
|
||||||
"Changes available:" <label> add-gadget
|
|
||||||
|
|
||||||
"View"
|
|
||||||
[
|
|
||||||
drop
|
|
||||||
PROCESS popup-process-window
|
|
||||||
]
|
|
||||||
<bevel-button> add-gadget
|
|
||||||
|
|
||||||
"Merge"
|
|
||||||
[
|
|
||||||
drop
|
|
||||||
|
|
||||||
[let | ARG [ { REMOTE "/" REMOTE-BRANCH } concat ] |
|
|
||||||
|
|
||||||
REPO { "git" "merge" ARG } git-process popup-process-window
|
|
||||||
|
|
||||||
]
|
|
||||||
|
|
||||||
GADGET refresh-git-remote-gadget
|
|
||||||
|
|
||||||
]
|
|
||||||
<bevel-button> add-gadget
|
|
||||||
|
|
||||||
add-gadget
|
|
||||||
|
|
||||||
]
|
|
||||||
when
|
|
||||||
|
|
||||||
] ] ]
|
|
||||||
|
|
||||||
|
|
||||||
! Pushable changes
|
|
||||||
|
|
||||||
[let | REMOTE [ GADGET remote>> ]
|
|
||||||
REMOTE-BRANCH [ GADGET remote-branch>> ] |
|
|
||||||
|
|
||||||
[let | ARG [ { REMOTE "/" REMOTE-BRANCH ".." } concat ] |
|
|
||||||
|
|
||||||
[let | PROCESS [ REPO { "git" "log" ARG } git-process ] |
|
|
||||||
|
|
||||||
PROCESS stdout>>
|
|
||||||
[
|
|
||||||
<shelf>
|
|
||||||
|
|
||||||
"Pushable changes: " <label> add-gadget
|
|
||||||
|
|
||||||
"View"
|
|
||||||
[
|
|
||||||
drop
|
|
||||||
PROCESS popup-process-window
|
|
||||||
]
|
|
||||||
<bevel-button> add-gadget
|
|
||||||
|
|
||||||
"Push"
|
|
||||||
[
|
|
||||||
drop
|
|
||||||
|
|
||||||
REPO { "git" "push" REMOTE REMOTE-BRANCH }
|
|
||||||
git-process
|
|
||||||
popup-process-window
|
|
||||||
|
|
||||||
GADGET refresh-git-remote-gadget
|
|
||||||
|
|
||||||
]
|
|
||||||
<bevel-button> add-gadget
|
|
||||||
|
|
||||||
add-gadget
|
|
||||||
|
|
||||||
]
|
|
||||||
when
|
|
||||||
|
|
||||||
] ] ]
|
|
||||||
|
|
||||||
drop
|
|
||||||
|
|
||||||
] ;
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
:: start-fetch-thread ( GADGET -- )
|
|
||||||
|
|
||||||
GADGET f >>closed drop
|
|
||||||
|
|
||||||
[
|
|
||||||
|
|
||||||
[
|
|
||||||
|
|
||||||
GADGET closed>>
|
|
||||||
[ f ]
|
|
||||||
[
|
|
||||||
[let | REPO [ GADGET repository>> ]
|
|
||||||
REMOTE-BRANCH [ GADGET remote-branch>> ] |
|
|
||||||
|
|
||||||
REPO { "git" "fetch" REMOTE-BRANCH } git-process drop ]
|
|
||||||
|
|
||||||
GADGET fetch-period>> sleep
|
|
||||||
|
|
||||||
t
|
|
||||||
]
|
|
||||||
if
|
|
||||||
|
|
||||||
|
|
||||||
]
|
|
||||||
loop
|
|
||||||
|
|
||||||
]
|
|
||||||
|
|
||||||
in-thread ;
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
:: start-monitor-thread ( GADGET -- )
|
|
||||||
|
|
||||||
GADGET f >>closed drop
|
|
||||||
|
|
||||||
[
|
|
||||||
[
|
|
||||||
[let | MONITOR [ GADGET repository>> t <monitor> ] |
|
|
||||||
|
|
||||||
[
|
|
||||||
GADGET closed>>
|
|
||||||
[ f ]
|
|
||||||
[
|
|
||||||
|
|
||||||
[let | PATH [ MONITOR next-change drop ] |
|
|
||||||
|
|
||||||
".git" PATH subseq?
|
|
||||||
[ ]
|
|
||||||
[
|
|
||||||
micros
|
|
||||||
GADGET last-refresh>> 0 or -
|
|
||||||
1000000 >
|
|
||||||
[
|
|
||||||
GADGET micros >>last-refresh drop
|
|
||||||
GADGET refresh-git-remote-gadget
|
|
||||||
]
|
|
||||||
when
|
|
||||||
]
|
|
||||||
if ]
|
|
||||||
|
|
||||||
t
|
|
||||||
|
|
||||||
]
|
|
||||||
if
|
|
||||||
]
|
|
||||||
loop
|
|
||||||
]
|
|
||||||
]
|
|
||||||
with-monitors
|
|
||||||
]
|
|
||||||
in-thread ;
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
M: <git-remote-gadget> pref-dim* ( gadget -- dim ) drop { 500 500 } ;
|
|
||||||
|
|
||||||
M:: <git-remote-gadget> graft* ( GADGET -- )
|
|
||||||
GADGET start-fetch-thread
|
|
||||||
GADGET start-monitor-thread ;
|
|
||||||
|
|
||||||
M:: <git-remote-gadget> ungraft* ( GADGET -- ) GADGET t >>closed drop ;
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
:: git-remote-tool ( REPO -- )
|
|
||||||
|
|
||||||
<git-remote-gadget> new-gadget
|
|
||||||
|
|
||||||
{ 0 1 } >>orientation
|
|
||||||
1 >>fill
|
|
||||||
|
|
||||||
REPO >>repository
|
|
||||||
|
|
||||||
"origin" >>remote
|
|
||||||
|
|
||||||
"master" >>remote-branch
|
|
||||||
|
|
||||||
5 minutes >>fetch-period
|
|
||||||
|
|
||||||
dup refresh-git-remote-gadget
|
|
||||||
|
|
||||||
"git-remote-tool" open-window ;
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
: factor-git-remote-tool ( -- ) "resource:" git-remote-tool ;
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
MAIN: factor-git-remote-tool
|
|
||||||
Loading…
Reference in New Issue