Merge branch 'master' of git://factorcode.org/git/factor
Doug Coleman
commit
f12773c8ce
|
|
@ -8,7 +8,7 @@ SINGLETON: gvim
|
|||
HOOK: gvim-path io-backend ( -- path )
|
||||
|
||||
M: gvim vim-command ( file line -- string )
|
||||
[ gvim-path , swap , "+" swap number>string append , ] { } make ;
|
||||
[ gvim-path , "+" swap number>string append , , ] { } make ;
|
||||
|
||||
gvim vim-editor set-global
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,5 @@
|
|||
! Generate a new factor.vim file for syntax highlighting
|
||||
USING: http.server.templating http.server.templating.fhtml
|
||||
io.files ;
|
||||
USING: html.templates html.templates.fhtml io.files io.pathnames ;
|
||||
IN: editors.vim.generate-syntax
|
||||
|
||||
: generate-vim-syntax ( -- )
|
||||
|
|
|
|||
|
|
@ -209,7 +209,8 @@ ARTICLE: "tools" "Developer tools"
|
|||
{ $subsection "timing" }
|
||||
{ $subsection "tools.disassembler" }
|
||||
"Deployment tools:"
|
||||
{ $subsection "tools.deploy" } ;
|
||||
{ $subsection "tools.deploy" }
|
||||
{ $see-also "ui-tools" } ;
|
||||
|
||||
ARTICLE: "article-index" "Article index"
|
||||
{ $index [ articles get keys ] } ;
|
||||
|
|
|
|||
|
|
@ -34,6 +34,7 @@ ARTICLE: "defining-words" "Defining words"
|
|||
{ $see POSTPONE: SYMBOL: }
|
||||
"The key factor in the definition of " { $link POSTPONE: SYMBOL: } " is " { $link CREATE } ", which reads a token from the input and creates a word with that name. This word is then passed to " { $link define-symbol } "."
|
||||
{ $subsection CREATE }
|
||||
{ $subsection CREATE-WORD }
|
||||
"Colon definitions are defined in a more elaborate way:"
|
||||
{ $subsection POSTPONE: : }
|
||||
"The " { $link POSTPONE: : } " word first calls " { $link CREATE } ", and then reads input until reaching " { $link POSTPONE: ; } " using a utility word:"
|
||||
|
|
|
|||
|
|
@ -207,7 +207,8 @@ DEFER: default-L-parser-values
|
|||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: save-turtle ( turtle -- turtle ) dup clone over saved>> push ;
|
||||
: restore-turtle ( turtle -- turtle ) saved>> pop ;
|
||||
|
||||
: restore-turtle ( turtle -- turtle ) saved>> pop dup color>> set-color ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,37 @@
|
|||
|
||||
USING: accessors ui L-system ;
|
||||
|
||||
IN: L-system.models.tree-5
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: tree-5 ( <L-system> -- <L-system> )
|
||||
|
||||
L-parser-dialect >>commands
|
||||
|
||||
[ 5 >>angle ] >>turtle-values
|
||||
|
||||
"c(4)FFS" >>axiom
|
||||
|
||||
{
|
||||
{ "S" "FFR>(60)R>(60)R>(60)R>(60)R>(60)R>(30)S" }
|
||||
{ "R" "[Ba]" }
|
||||
{ "a" "$tF[Cx]Fb" }
|
||||
{ "b" "$tF[Dy]Fa" }
|
||||
{ "B" "&B" }
|
||||
{ "C" "+C" }
|
||||
{ "D" "-D" }
|
||||
|
||||
{ "x" "a" }
|
||||
{ "y" "b" }
|
||||
|
||||
{ "F" "'(1.25)F'(.8)" }
|
||||
}
|
||||
>>rules ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: main ( -- ) [ L-system tree-5 "L-system" open-window ] with-ui ;
|
||||
|
||||
MAIN: main
|
||||
|
||||
|
|
@ -0,0 +1,446 @@
|
|||
|
||||
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 ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: factor-git-tool ( -- ) "resource:" git-tool ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
Loading…
Reference in New Issue