diff --git a/basis/editors/gvim/gvim.factor b/basis/editors/gvim/gvim.factor index ad6fb65cfb..8fb4d6b23d 100644 --- a/basis/editors/gvim/gvim.factor +++ b/basis/editors/gvim/gvim.factor @@ -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 diff --git a/basis/editors/vim/generate-syntax/generate-syntax.factor b/basis/editors/vim/generate-syntax/generate-syntax.factor index 325a451a0b..74b04c346f 100644 --- a/basis/editors/vim/generate-syntax/generate-syntax.factor +++ b/basis/editors/vim/generate-syntax/generate-syntax.factor @@ -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 ( -- ) diff --git a/basis/help/cookbook/cookbook.factor b/basis/help/cookbook/cookbook.factor index 4ea90e086b..ebc711d527 100644 --- a/basis/help/cookbook/cookbook.factor +++ b/basis/help/cookbook/cookbook.factor @@ -267,8 +267,8 @@ $nl { $heading "Example: ls" } "Here is an example implementing a simplified version of the Unix " { $snippet "ls" } " command in Factor:" { $code - <" USING: command-line namespaces io io.files tools.files -sequences kernel ; + <" USING: command-line namespaces io io.files +io.pathnames tools.files sequences kernel ; command-line get [ current-directory get directory. diff --git a/basis/help/handbook/handbook.factor b/basis/help/handbook/handbook.factor index 69c2046834..f63bb35f65 100644 --- a/basis/help/handbook/handbook.factor +++ b/basis/help/handbook/handbook.factor @@ -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 ] } ; diff --git a/basis/io/files/unique/unique-docs.factor b/basis/io/files/unique/unique-docs.factor index 681cd94a38..08836cf497 100644 --- a/basis/io/files/unique/unique-docs.factor +++ b/basis/io/files/unique/unique-docs.factor @@ -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 } ; diff --git a/basis/io/files/unix/unix-tests.factor b/basis/io/files/unix/unix-tests.factor index 48a128d862..003cb40621 100644 --- a/basis/io/files/unix/unix-tests.factor +++ b/basis/io/files/unix/unix-tests.factor @@ -117,12 +117,12 @@ prepare-test-file [ ] [ test-file f f 2array set-file-times ] unit-test -[ ] [ test-file real-username set-file-user ] unit-test +[ ] [ test-file real-user-name set-file-user ] unit-test [ ] [ test-file real-user-id set-file-user ] unit-test [ ] [ test-file real-group-name set-file-group ] unit-test [ ] [ test-file real-group-id set-file-group ] unit-test -[ t ] [ test-file file-username real-username = ] unit-test +[ t ] [ test-file file-user-name real-user-name = ] unit-test [ t ] [ test-file file-group-name real-group-name = ] unit-test [ ] diff --git a/basis/splitting/monotonic/monotonic-tests.factor b/basis/splitting/monotonic/monotonic-tests.factor index 7bf9a38e8a..2b44f42394 100644 --- a/basis/splitting/monotonic/monotonic-tests.factor +++ b/basis/splitting/monotonic/monotonic-tests.factor @@ -15,6 +15,8 @@ USING: tools.test math arrays kernel sequences ; [ { { 1 } } ] [ { 1 } [ = ] slice monotonic-slice [ >array ] map ] unit-test +[ { 1 } [ = ] slice monotonic-slice ] must-infer + [ t ] [ { 1 1 1 2 2 3 3 4 } [ = ] slice monotonic-slice [ slice? ] all? ] unit-test diff --git a/basis/splitting/monotonic/monotonic.factor b/basis/splitting/monotonic/monotonic.factor index e39bba25ab..2e2ac74e30 100644 --- a/basis/splitting/monotonic/monotonic.factor +++ b/basis/splitting/monotonic/monotonic.factor @@ -24,13 +24,15 @@ PRIVATE> 1 over change-circular-start ] tri - [ @ not [ , ] [ drop ] if ] 3each - ] { } make - dup empty? [ over length 1- prefix ] when -1 prefix 2 clump - [ first2 [ 1+ ] bi@ rot roll boa ] with with map ; inline + [ + dupd '[ + [ length ] [ ] [ 1 over change-circular-start ] tri + [ @ not [ , ] [ drop ] if ] 3each + ] { } make + dup empty? [ over length 1- prefix ] when -1 prefix 2 clump + swap + ] dip + '[ first2 [ 1+ ] bi@ _ _ boa ] map ; inline PRIVATE> @@ -39,7 +41,7 @@ PRIVATE> { 0 [ 2drop ] } { 1 [ nip [ 0 1 rot ] dip boa 1array ] } [ drop (monotonic-slice) ] - } case ; + } case ; inline TUPLE: downward-slice < slice ; TUPLE: stable-slice < slice ; diff --git a/basis/tools/files/files.factor b/basis/tools/files/files.factor index e6ca02d5f9..9066f3a219 100755 --- a/basis/tools/files/files.factor +++ b/basis/tools/files/files.factor @@ -65,7 +65,7 @@ percent-used percent-free ; [ [ unparse ] map ] bi prefix simple-table. ; : file-systems. ( -- ) - { device-name free-space used-space total-space percent-used mount-point } + { device-name available-space free-space used-space total-space percent-used mount-point } print-file-systems ; { diff --git a/basis/tools/scaffold/scaffold-docs.factor b/basis/tools/scaffold/scaffold-docs.factor index d2989d3cac..9074c80986 100644 --- a/basis/tools/scaffold/scaffold-docs.factor +++ b/basis/tools/scaffold/scaffold-docs.factor @@ -26,7 +26,7 @@ HELP: scaffold-undocumented HELP: scaffold-vocab { $values { "vocab-root" "a vocabulary root string" } { "string" string } } -{ $description "Creates a direcory in the given root for a new vocabulary and adds a main .factor file, a tests file, and an authors.txt file." } ; +{ $description "Creates a directory in the given root for a new vocabulary and adds a main .factor file, a tests file, and an authors.txt file." } ; HELP: using { $description "Stores the vocabularies that are pulled into the documentation file from looking up the stack effect types." } ; diff --git a/basis/ui/gadgets/labels/labels.factor b/basis/ui/gadgets/labels/labels.factor index 5706f47639..eff3c6f7bb 100644 --- a/basis/ui/gadgets/labels/labels.factor +++ b/basis/ui/gadgets/labels/labels.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2005, 2008 Slava Pestov. +! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays hashtables io kernel math namespaces make opengl sequences strings splitting ui.gadgets @@ -12,11 +12,7 @@ TUPLE: label < gadget text font color ; text>> dup string? [ "\n" join ] unless ; inline : set-label-string ( string label -- ) - CHAR: \n pick memq? [ - [ string-lines ] dip (>>text) - ] [ - (>>text) - ] if ; inline + [ CHAR: \n over memq? [ string-lines ] when ] dip (>>text) ; inline : label-theme ( gadget -- gadget ) sans-serif-font >>font diff --git a/basis/unix/groups/groups-docs.factor b/basis/unix/groups/groups-docs.factor index 18c2e2384a..07911bc96b 100644 --- a/basis/unix/groups/groups-docs.factor +++ b/basis/unix/groups/groups-docs.factor @@ -24,8 +24,8 @@ HELP: group-cache HELP: group-id { $values { "string" string } - { "id" integer } } -{ $description "Returns the group id given a group name." } ; + { "id/f" "an integer or f" } } +{ $description "Returns the group id given a group name. Returns " { $link f } " if the group does not exist." } ; HELP: group-name { $values @@ -36,7 +36,7 @@ HELP: group-name HELP: group-struct { $values { "obj" object } - { "group" "a group struct" } } + { "group/f" "a group struct or f" } } { $description "Returns an alien group struct to be turned into a group tuple by calling subsequent words." } ; HELP: real-group-id diff --git a/basis/unix/groups/groups-tests.factor b/basis/unix/groups/groups-tests.factor index 75f5d64b5f..2e989b32c0 100644 --- a/basis/unix/groups/groups-tests.factor +++ b/basis/unix/groups/groups-tests.factor @@ -27,3 +27,5 @@ IN: unix.groups.tests [ ] [ real-group-id group-name drop ] unit-test [ "888888888888888" ] [ 888888888888888 group-name ] unit-test +[ f ] +[ "please-oh-please-don't-have-a-group-named-this123lalala" group-struct ] unit-test diff --git a/basis/unix/groups/groups.factor b/basis/unix/groups/groups.factor index 164afa46fb..f4d91df245 100644 --- a/basis/unix/groups/groups.factor +++ b/basis/unix/groups/groups.factor @@ -13,7 +13,7 @@ TUPLE: group id name passwd members ; SYMBOL: group-cache -GENERIC: group-struct ( obj -- group ) +GENERIC: group-struct ( obj -- group/f ) tuck 4096 [ ] keep f ; -M: integer group-struct ( id -- group ) - (group-struct) getgrgid_r io-error ; +: check-group-struct ( group-struct ptr -- group-struct/f ) + *void* [ drop f ] unless ; -M: string group-struct ( string -- group ) - (group-struct) getgrnam_r 0 = [ (io-error) ] unless ; +M: integer group-struct ( id -- group/f ) + (group-struct) [ getgrgid_r io-error ] keep check-group-struct ; + +M: string group-struct ( string -- group/f ) + (group-struct) [ getgrnam_r io-error ] keep check-group-struct ; : group-struct>group ( group-struct -- group ) [ \ group new ] dip @@ -45,12 +48,12 @@ PRIVATE> dup group-cache get [ dupd at* [ name>> nip ] [ drop number>string ] if ] [ - group-struct group-gr_name + group-struct [ group-gr_name ] [ f ] if* ] if* [ nip ] [ number>string ] if* ; -: group-id ( string -- id ) - group-struct group-gr_gid ; +: group-id ( string -- id/f ) + group-struct [ group-gr_gid ] [ f ] if* ; bignum ; { 3 0 } [ [ 3drop ] 3each ] must-infer-as -[ V{ 0 3 } ] [ "A" { "A" "B" "C" "A" "D" } indices ] unit-test \ No newline at end of file +[ V{ 0 3 } ] [ "A" { "A" "B" "C" "A" "D" } indices ] unit-test + +[ "asdf" iota ] must-fail +[ T{ iota { n 10 } } ] [ 10 iota ] unit-test +[ 0 ] [ 10 iota first ] unit-test diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 91c9d52404..5a92dcaf2d 100644 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -101,6 +101,20 @@ M: integer nth-unsafe drop ; INSTANCE: integer immutable-sequence +PRIVATE> + +! In the future, this will replace integer sequences +TUPLE: iota { n integer read-only } ; + +: iota ( n -- iota ) \ iota boa ; inline + +> ; +M: iota nth-unsafe drop ; + +INSTANCE: iota immutable-sequence + : first-unsafe ( seq -- first ) 0 swap nth-unsafe ; inline diff --git a/core/sorting/sorting-docs.factor b/core/sorting/sorting-docs.factor index 6ea1485425..290ca1470c 100644 --- a/core/sorting/sorting-docs.factor +++ b/core/sorting/sorting-docs.factor @@ -20,7 +20,8 @@ ABOUT: "sequences-sorting" HELP: sort { $values { "seq" "a sequence" } { "quot" { $quotation "( obj1 obj2 -- <=> )" } } { "sortedseq" "a new sorted sequence" } } -{ $description "Sorts the elements into a new array." } ; +{ $description "Sorts the elements into a new array using a stable sort." } +{ $notes "The algorithm used is the merge sort." } ; HELP: sort-keys { $values { "seq" "an alist" } { "sortedseq" "a new sorted sequence" } } diff --git a/extra/L-system/L-system.factor b/extra/L-system/L-system.factor index 5bc7ce1db6..0dbf94b1c6 100644 --- a/extra/L-system/L-system.factor +++ b/extra/L-system/L-system.factor @@ -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 ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/L-system/models/tree-5/tree-5.factor b/extra/L-system/models/tree-5/tree-5.factor new file mode 100644 index 0000000000..2647698351 --- /dev/null +++ b/extra/L-system/models/tree-5/tree-5.factor @@ -0,0 +1,37 @@ + +USING: accessors ui L-system ; + +IN: L-system.models.tree-5 + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: tree-5 ( -- ) + + 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 + \ No newline at end of file diff --git a/extra/benchmark/nbody/nbody.factor b/extra/benchmark/nbody/nbody.factor index 84c41ee69f..37c4fc43c5 100644 --- a/extra/benchmark/nbody/nbody.factor +++ b/extra/benchmark/nbody/nbody.factor @@ -1,7 +1,7 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors specialized-arrays.double fry kernel locals make math -math.constants math.functions math.vectors prettyprint +USING: accessors specialized-arrays.double fry kernel locals math +math.constants math.functions math.vectors prettyprint combinators.smart sequences hints arrays ; IN: benchmark.nbody @@ -53,7 +53,7 @@ TUPLE: nbody-system { bodies array read-only } ; offset-momentum drop ; inline : ( -- system ) - [ , , , , , ] { } make nbody-system boa + [ ] output>array nbody-system boa dup bodies>> init-bodies ; inline :: each-pair ( bodies pair-quot: ( other-body body -- ) each-quot: ( body -- ) -- ) diff --git a/extra/curses/authors.txt b/extra/curses/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/curses/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/curses/curses-tests.factor b/extra/curses/curses-tests.factor new file mode 100644 index 0000000000..21463b207b --- /dev/null +++ b/extra/curses/curses-tests.factor @@ -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 diff --git a/extra/curses/curses.factor b/extra/curses/curses.factor new file mode 100644 index 0000000000..f11b26333b --- /dev/null +++ b/extra/curses/curses.factor @@ -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 ; + +> [ 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 ) + [ [ 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 ; diff --git a/extra/curses/ffi/ffi.factor b/extra/curses/ffi/ffi.factor new file mode 100644 index 0000000000..8d4a7ddb4b --- /dev/null +++ b/extra/curses/ffi/ffi.factor @@ -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 ) ; diff --git a/extra/curses/ffi/tags.txt b/extra/curses/ffi/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/extra/curses/ffi/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/extra/curses/summary.txt b/extra/curses/summary.txt new file mode 100644 index 0000000000..0eb839c524 --- /dev/null +++ b/extra/curses/summary.txt @@ -0,0 +1 @@ +ncurses binding diff --git a/extra/curses/tags.txt b/extra/curses/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/extra/curses/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor index 50f02f1a1a..587537adcf 100644 --- a/extra/fuel/fuel.factor +++ b/extra/fuel/fuel.factor @@ -4,9 +4,10 @@ USING: accessors arrays assocs classes.tuple combinators compiler.units continuations debugger definitions help help.crossref help.markup help.topics io io.pathnames io.streams.string kernel lexer -make math math.order memoize namespaces parser quotations prettyprint +make math math.order memoize namespaces parser prettyprint quotations sequences sets sorting source-files strings summary tools.crossref -tools.vocabs tools.vocabs.browser vectors vocabs vocabs.parser words ; +tools.scaffold tools.vocabs tools.vocabs.browser vectors vocabs +vocabs.loader vocabs.parser words ; IN: fuel @@ -69,13 +70,15 @@ M: integer fuel-pprint pprint ; inline M: string fuel-pprint pprint ; inline -M: sequence fuel-pprint - "(" write [ " " write ] [ fuel-pprint ] interleave ")" write ; inline +: fuel-pprint-sequence ( seq open close -- ) + [ write ] dip swap [ " " write ] [ fuel-pprint ] interleave write ; inline + +M: sequence fuel-pprint "(" ")" fuel-pprint-sequence ; inline + +M: quotation fuel-pprint "[" "]" fuel-pprint-sequence ; inline M: tuple fuel-pprint tuple>array fuel-pprint ; inline -M: quotation fuel-pprint pprint ; inline - M: continuation fuel-pprint drop ":continuation" write ; inline M: restart fuel-pprint name>> fuel-pprint ; inline @@ -328,7 +331,7 @@ SYMBOL: vocab-list [ describe-words ] with-string-writer \ describe-words swap 2array ; inline : (fuel-vocab-help) ( name -- element ) - \ article swap dup >vocab-link + dup require \ article swap dup >vocab-link [ { [ vocab-authors [ \ $authors prefix , ] when* ] @@ -358,13 +361,24 @@ MEMO: (fuel-get-vocabs/author) ( author -- element ) : fuel-get-vocabs/author ( author -- ) (fuel-get-vocabs/author) fuel-eval-set-result ; -MEMO: (fuel-get-vocabs/tag ( tag -- element ) +MEMO: (fuel-get-vocabs/tag) ( tag -- element ) [ "Vocabularies tagged " prepend \ $heading swap 2array ] [ tagged fuel-vocab-list ] bi 2array ; : fuel-get-vocabs/tag ( tag -- ) - (fuel-get-vocabs/tag fuel-eval-set-result ; + (fuel-get-vocabs/tag) fuel-eval-set-result ; +! Scaffold support + +: fuel-scaffold-vocab ( root name devname -- ) + developer-name set + [ scaffold-vocab ] 2keep [ (normalize-path) ] dip dup + append-path append-path ".factor" append fuel-eval-set-result ; + +: fuel-scaffold-help ( name devname -- ) + developer-name set + dup require dup scaffold-help vocab-docs-path + (normalize-path) fuel-eval-set-result ; ! -run=fuel support diff --git a/extra/git-tool/git-tool.factor b/extra/git-tool/git-tool.factor new file mode 100644 index 0000000000..1b079ed0ac --- /dev/null +++ b/extra/git-tool/git-tool.factor @@ -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 ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +:: ( 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>> utf8 + STDERR-PIPE in>> utf8 ] ] + ] + with-destructors ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: run-process/result ( desc -- process ) + + { + [ 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 + 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: + 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 -- ) + + new REPO >>repository refresh-git-status ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +:: factor-git-status ( -- ) "resource:" git-status ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! git-tool +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: to-commit ( -- 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 } + + TEXT