Merge branch 'master' of git://factorcode.org/git/factor

db4
Slava Pestov 2009-01-11 14:58:36 -06:00
commit 82a7e28082
11 changed files with 897 additions and 5 deletions

View File

@ -1,5 +1,5 @@
USING: help.markup help.syntax io io.ports kernel math
io.pathnames io.directories math.parser io.files ;
io.pathnames io.directories math.parser io.files strings ;
IN: io.files.unique
HELP: temporary-path
@ -30,7 +30,7 @@ HELP: make-unique-file ( prefix suffix -- path )
HELP: make-unique-file*
{ $values
{ "prefix" null } { "suffix" null }
{ "prefix" string } { "suffix" string }
{ "path" "a pathname string" }
}
{ $description "Creates a file that is guaranteed not to exist in the directory in the " { $link current-directory } " variable. The file name is composed of a prefix, a number of random digits and letters, and the suffix. Returns the full pathname." } ;
@ -55,11 +55,11 @@ HELP: with-unique-directory ( quot -- )
ARTICLE: "io.files.unique" "Temporary files"
"The " { $vocab-link "io.files.unique" } " vocabulary implements cross-platform temporary file creation in a high-level and secure way." $nl
"Files:"
"Creating temporary files:"
{ $subsection make-unique-file }
{ $subsection make-unique-file* }
{ $subsection with-unique-file }
"Directories:"
"Creating temporary directories:"
{ $subsection make-unique-directory }
{ $subsection with-unique-directory } ;

View File

@ -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 ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

View File

@ -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

1
extra/curses/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

View File

@ -0,0 +1,18 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors curses kernel threads tools.test ;
IN: curses.tests
: hello-curses ( -- )
[
curses-window new
"mainwin" >>name
add-curses-window
"mainwin" "hi" curses-printf
2000000 sleep
] with-curses ;
[
] [ hello-curses ] unit-test

155
extra/curses/curses.factor Normal file
View File

@ -0,0 +1,155 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types alien.strings assocs byte-arrays
combinators continuations destructors fry io.encodings.8-bit
io io.encodings.string io.encodings.utf8 kernel math
namespaces prettyprint sequences
strings threads curses.ffi ;
IN: curses
SYMBOL: curses-windows
SYMBOL: current-window
: ERR -1 ; inline
: FALSE 0 ; inline
: TRUE 1 ; inline
: >BOOLEAN ( n -- TRUE/FALSE ) >boolean TRUE FALSE ? ; inline
ERROR: duplicate-window window ;
ERROR: unnamed-window window ;
ERROR: window-not-found window ;
ERROR: curses-failed ;
: get-window ( string -- window )
dup curses-windows get at*
[ nip ] [ drop window-not-found ] if ;
: window-ptr ( string -- window ) get-window ptr>> ;
: curses-error ( n -- ) ERR = [ curses-failed ] when ;
: with-curses ( quot -- )
H{ } clone curses-windows [
initscr curses-error
[
curses-windows get values [ dispose ] each
nocbreak curses-error
echo curses-error
endwin curses-error
] [ ] cleanup
] with-variable ; inline
: with-window ( name quot -- )
[ window-ptr current-window ] dip with-variable ; inline
TUPLE: curses-window
name
parent-name
ptr
{ lines integer initial: 0 }
{ columns integer initial: 0 }
{ y integer initial: 0 }
{ x integer initial: 0 }
{ cbreak initial: t }
{ echo initial: t }
{ raw initial: f }
{ scrollok initial: t }
{ leaveok initial: f }
idcok idlok immedok
{ keypad initial: f } ;
M: curses-window dispose ( window -- )
ptr>> delwin curses-error ;
<PRIVATE
: add-window ( window -- )
dup name>> [ unnamed-window ] unless*
curses-windows get 2dup key?
[ duplicate-window ] [ set-at ] if ;
: delete-window ( window -- )
curses-windows get 2dup key?
[ delete-at ] [ drop window-not-found ] if ;
: window-params ( window -- lines columns y x )
{ [ lines>> ] [ columns>> ] [ y>> ] [ x>> ] } cleave ;
: setup-window ( window -- )
{
[
dup
dup parent-name>> [
window-ptr swap window-params derwin
] [
window-params newwin
] if* [ curses-error ] keep >>ptr drop
]
[ cbreak>> [ cbreak ] [ nocbreak ] if curses-error ]
[ echo>> [ echo ] [ noecho ] if curses-error ]
[ raw>> [ raw ] [ noraw ] if curses-error ]
[ [ ptr>> ] [ scrollok>> >BOOLEAN ] bi scrollok curses-error ]
[ [ ptr>> ] [ leaveok>> >BOOLEAN ] bi leaveok curses-error ]
[ [ ptr>> ] [ keypad>> >BOOLEAN ] bi keypad curses-error ]
[ add-window ]
} cleave ;
PRIVATE>
: add-curses-window ( window -- )
[ setup-window ] [ ] [ dispose ] cleanup ;
: (curses-window-refresh) ( window-ptr -- ) wrefresh curses-error ;
: wnrefresh ( window -- ) window-ptr (curses-window-refresh) ;
: curses-refresh ( -- ) current-window get (curses-window-refresh) ;
: (curses-wprint) ( window-ptr string -- )
waddstr curses-error ;
: curses-nwrite ( window string -- )
[ window-ptr ] dip (curses-wprint) ;
: curses-wprint ( window string -- )
[ window-ptr dup ] dip (curses-wprint) "\n" (curses-wprint) ;
: curses-printf ( window string -- )
[ window-ptr dup dup ] dip (curses-wprint)
"\n" (curses-wprint)
(curses-window-refresh) ;
: curses-writef ( window string -- )
[ window-ptr dup ] dip (curses-wprint) (curses-window-refresh) ;
: (curses-read) ( window-ptr n encoding -- string )
[ [ <byte-array> tuck ] keep wgetnstr curses-error ] dip alien>string ;
: curses-read ( window n -- string )
utf8 [ window-ptr ] 2dip (curses-read) ;
: curses-erase ( window -- ) window-ptr werase curses-error ;
: move-cursor ( window-name y x -- )
[
window-ptr
{
[ ]
[ (curses-window-refresh) ]
[ c-window-_curx ]
[ c-window-_cury ]
} cleave
] 2dip mvcur curses-error (curses-window-refresh) ;
: delete-line ( window-name y -- )
[ window-ptr dup ] dip
0 wmove curses-error wdeleteln curses-error ;
: insert-blank-line ( window-name y -- )
[ window-ptr dup ] dip
0 wmove curses-error winsertln curses-error ;
: insert-line ( window-name y string -- )
[ dupd insert-blank-line ] dip
curses-writef ;

231
extra/curses/ffi/ffi.factor Normal file
View File

@ -0,0 +1,231 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.syntax combinators kernel system ;
IN: curses.ffi
<< "curses" {
{ [ os winnt? ] [ "libcurses.dll" ] }
{ [ os macosx? ] [ "libcurses.dylib" ] }
{ [ os unix? ] [ "libcurses.so" ] }
} cond "cdecl" add-library >>
TYPEDEF: void* WINDOW*
TYPEDEF: void* SCREEN*
TYPEDEF: void* va_list
TYPEDEF: uint chtype
TYPEDEF: chtype attr_t
TYPEDEF: short NCURSES_SIZE_T
TYPEDEF: ushort wchar_t
: CCHARW_MAX 5 ; inline
C-STRUCT: cchar_t
{ "attr_t" "attr" }
{ { "wchar_t" CCHARW_MAX } "chars" } ;
C-STRUCT: pdat
{ "NCURSES_SIZE_T" "_pad_y" }
{ "NCURSES_SIZE_T" "_pad_x" }
{ "NCURSES_SIZE_T" "_pad_top" }
{ "NCURSES_SIZE_T" "_pad_left" }
{ "NCURSES_SIZE_T" "_pad_bottom" }
{ "NCURSES_SIZE_T" "_pad_right" } ;
C-STRUCT: c-window
{ "NCURSES_SIZE_T" "_cury" }
{ "NCURSES_SIZE_T" "_curx" }
{ "NCURSES_SIZE_T" "_maxy" }
{ "NCURSES_SIZE_T" "_maxx" }
{ "NCURSES_SIZE_T" "_begy" }
{ "NCURSES_SIZE_T" "_begx" }
{ "short" " _flags" }
{ "attr_t" "_attrs" }
{ "chtype" "_bkgd" }
{ "bool" "_notimeout" }
{ "bool" "_clear" }
{ "bool" "_leaveok" }
{ "bool" "_scroll" }
{ "bool" "_idlok" }
{ "bool" "_idcok" }
{ "bool" "_immed" }
{ "bool" "_sync" }
{ "bool" "_use_keypad" }
{ "int" "_delay" }
{ "char*" "_line" }
{ "NCURSES_SIZE_T" "_regtop" }
{ "NCURSES_SIZE_T" "_regbottom" }
{ "int" "_parx" }
{ "int" "_pary" }
{ "WINDOW*" "_parent" }
{ "pdat" "_pad" }
{ "NCURSES_SIZE_T" "_yoffset" }
{ "cchar_t" "_bkgrnd" } ;
LIBRARY: curses
: stdscr ( -- alien )
"stdscr" "curses" library dll>> dlsym ;
FUNCTION: WINDOW* initscr ( ) ;
FUNCTION: int endwin ( ) ;
FUNCTION: bool isendwin ( ) ;
FUNCTION: SCREEN* newterm ( char* type, FILE* outfd, FILE* infd ) ;
FUNCTION: SCREEN* set_term ( SCREEN* new ) ;
FUNCTION: void delscreen ( SCREEN* sp ) ;
FUNCTION: int def_prog_mode ( ) ;
FUNCTION: int def_shell_mode ( ) ;
FUNCTION: int reset_prog_mode ( ) ;
FUNCTION: int reset_shell_mode ( ) ;
FUNCTION: int resetty ( ) ;
FUNCTION: int savetty ( ) ;
FUNCTION: int ripoffline ( int line, void* callback ) ;
FUNCTION: int curs_set ( int visibility ) ;
FUNCTION: int napms ( int ms ) ;
FUNCTION: WINDOW* newwin ( int nlines, int ncols, int begin_y, int begin_x ) ;
FUNCTION: int delwin ( WINDOW* win ) ;
FUNCTION: int mvwin ( WINDOW* win, int y, int x ) ;
FUNCTION: WINDOW* subwin ( WINDOW* orig, int nlines, int ncols, int begin_y, int begin_x ) ;
FUNCTION: WINDOW* derwin ( WINDOW* orig, int nlines, int ncols, int begin_y, int begin_x ) ;
FUNCTION: int mvderwin ( WINDOW* win, int par_y, int par_x ) ;
FUNCTION: WINDOW* dupwin ( WINDOW* win ) ;
FUNCTION: void wsyncup ( WINDOW* win ) ;
FUNCTION: int syncok ( WINDOW* win, bool bf ) ;
FUNCTION: void wcursyncup ( WINDOW* win ) ;
FUNCTION: void wsyncdown ( WINDOW* win ) ;
FUNCTION: int cbreak ( ) ;
FUNCTION: int nocbreak ( ) ;
FUNCTION: int echo ( ) ;
FUNCTION: int noecho ( ) ;
FUNCTION: int halfdelay ( int tenths ) ;
FUNCTION: int intrflush ( WINDOW* win, bool bf ) ;
FUNCTION: int keypad ( WINDOW* win, bool bf ) ;
FUNCTION: int meta ( WINDOW* win, bool bf ) ;
FUNCTION: int nodelay ( WINDOW* win, bool bf ) ;
FUNCTION: int raw ( ) ;
FUNCTION: int noraw ( ) ;
FUNCTION: void noqiflush ( ) ;
FUNCTION: void qiflush ( ) ;
FUNCTION: int notimeout ( WINDOW* win, bool bf ) ;
FUNCTION: void timeout ( int delay ) ;
FUNCTION: void wtimeout ( WINDOW* win, int delay ) ;
FUNCTION: int typeahead ( int fd ) ;
FUNCTION: int clearok ( WINDOW* win, bool bf ) ;
FUNCTION: int idlok ( WINDOW* win, bool bf ) ;
FUNCTION: void idcok ( WINDOW* win, bool bf ) ;
FUNCTION: void immedok ( WINDOW* win, bool bf ) ;
FUNCTION: int leaveok ( WINDOW* win, bool bf ) ;
FUNCTION: int setscrreg ( int top, int bot ) ;
FUNCTION: int wsetscrreg ( WINDOW* win, int top, int bot ) ;
FUNCTION: int scrollok ( WINDOW* win, bool bf ) ;
FUNCTION: int nl ( ) ;
FUNCTION: int nonl ( ) ;
FUNCTION: int erase ( ) ;
FUNCTION: int werase ( WINDOW* win ) ;
FUNCTION: int clear ( ) ;
FUNCTION: int wclear ( WINDOW* win ) ;
FUNCTION: int clrtobot ( ) ;
FUNCTION: int wclrtobot ( WINDOW* win ) ;
FUNCTION: int clrtoeol ( ) ;
FUNCTION: int wclrtoeol ( WINDOW* win ) ;
FUNCTION: int refresh ( ) ;
FUNCTION: int wrefresh ( WINDOW* win ) ;
FUNCTION: int wnoutrefresh ( WINDOW* win ) ;
FUNCTION: int doupdate ( ) ;
FUNCTION: int redrawwin ( WINDOW* win ) ;
FUNCTION: int wredrawln ( WINDOW* win, int beg_line, int num_lines ) ;
FUNCTION: int getch ( ) ;
FUNCTION: int wgetch ( WINDOW* win ) ;
FUNCTION: int mvgetch ( int y, int x ) ;
FUNCTION: int mvwgetch ( WINDOW* win, int y, int x ) ;
FUNCTION: int ungetch ( int ch ) ;
FUNCTION: int has_key ( int ch ) ;
FUNCTION: int getstr ( char* str ) ;
FUNCTION: int getnstr ( char* str, int n ) ;
FUNCTION: int wgetstr ( WINDOW* win, char* str ) ;
FUNCTION: int wgetnstr ( WINDOW* win, char* str, int n ) ;
FUNCTION: int mvgetstr ( int y, int x, char* str ) ;
FUNCTION: int mvwgetstr ( WINDOW* win, int y, int x, char* str ) ;
FUNCTION: int mvgetnstr ( int y, int x, char* str, int n ) ;
FUNCTION: int mvwgetnstr ( WINDOW* win, int y, int x, char* str, int n ) ;
FUNCTION: int printw ( char* fmt, int lol ) ;
FUNCTION: int wprintw ( WINDOW* win, char* fmt, int lol ) ;
FUNCTION: int mvprintw ( int y, int x, char* fmt, int lol ) ;
FUNCTION: int mvwprintw ( WINDOW* win, int y, int x, char* fmt, int lol ) ;
FUNCTION: int vwprintw ( WINDOW* win, char* fmt, va_list varglist ) ;
FUNCTION: int vw_printw ( WINDOW* win, char* fmt, va_list varglist ) ;
FUNCTION: int move ( int y, int x ) ;
FUNCTION: int wmove ( WINDOW* win, int y, int x ) ;
FUNCTION: int scroll ( WINDOW* win ) ;
FUNCTION: int scrl ( int n ) ;
FUNCTION: int wscrl ( WINDOW* win, int n ) ;
! int setupterm(char *term, int fildes, int *errret);
! int setterm(char *term);
! TERMINAL *set_curterm(TERMINAL *nterm);
! int del_curterm(TERMINAL *oterm);
! int restartterm(const char *term, int fildes, int *errret);
! char *tparm(char *str, ...);
! int tputs(const char *str, int affcnt, int (*putc)(int));
! int putp(const char *str);
! int vidputs(chtype attrs, int (*putc)(int));
! int vidattr(chtype attrs);
! int vid_puts(attr_t attrs, short pair, void *opts, int (*putc)(char));
! int vid_attr(attr_t attrs, short pair, void *opts);
FUNCTION: int mvcur ( int oldrow, int oldcol, int newrow, int newcol ) ;
! int tigetflag(char *capname);
! int tigetnum(char *capname);
! char *tigetstr(char *capname);
FUNCTION: int touchwin ( WINDOW* win ) ;
FUNCTION: int touchline ( WINDOW* win, int start, int count ) ;
FUNCTION: int untouchwin ( WINDOW* win ) ;
FUNCTION: int wtouchln ( WINDOW* win, int y, int n, int changed ) ;
FUNCTION: bool is_linetouched ( WINDOW* win, int line ) ;
FUNCTION: bool is_wintouched ( WINDOW* win ) ;
FUNCTION: int insch ( chtype ch ) ;
FUNCTION: int winsch ( WINDOW* win, chtype ch ) ;
FUNCTION: int mvinsch ( int y, int x, chtype ch ) ;
FUNCTION: int mvwinsch ( WINDOW* win, int y, int x, chtype ch ) ;
FUNCTION: int delch ( ) ;
FUNCTION: int wdelch ( WINDOW* win ) ;
FUNCTION: int mvdelch ( int y, int x ) ;
FUNCTION: int mvwdelch ( WINDOW* win, int y, int x ) ;
FUNCTION: int deleteln ( ) ;
FUNCTION: int wdeleteln ( WINDOW* win ) ;
FUNCTION: int insdelln ( int n ) ;
FUNCTION: int winsdelln ( WINDOW* win, int n ) ;
FUNCTION: int insertln ( ) ;
FUNCTION: int winsertln ( WINDOW* win ) ;
FUNCTION: int addstr ( char* str ) ;
FUNCTION: int addnstr ( char* str, int n ) ;
FUNCTION: int waddstr ( WINDOW* win, char* str ) ;
FUNCTION: int waddnstr ( WINDOW* win, char* str, int n ) ;
FUNCTION: int mvaddstr ( int y, int x, char* str ) ;
FUNCTION: int mvaddnstr ( int y, int x, char* str, int n ) ;
FUNCTION: int mvwaddstr ( WINDOW* win, int y, int x, char* str ) ;
FUNCTION: int mvwaddnstr ( WINDOW* win, int y, int x, char* str, int n ) ;

View File

@ -0,0 +1 @@
unportable

1
extra/curses/summary.txt Normal file
View File

@ -0,0 +1 @@
ncurses binding

1
extra/curses/tags.txt Normal file
View File

@ -0,0 +1 @@
unportable

View File

@ -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 ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!