Merge branch 'master' into new_ui
Slava Pestov
commit
2b2f95e711
|
|
@ -3,12 +3,12 @@
|
|||
USING: combinators.short-circuit accessors combinators io
|
||||
io.encodings.8-bit io.encodings io.encodings.binary
|
||||
io.encodings.utf8 io.files io.files.info io.directories
|
||||
io.pathnames io.sockets kernel math.parser namespaces make
|
||||
sequences ftp io.launcher.unix.parser unicode.case splitting
|
||||
io.sockets kernel math.parser namespaces make sequences
|
||||
ftp io.launcher.unix.parser unicode.case splitting
|
||||
assocs classes io.servers.connection destructors calendar
|
||||
io.timeouts io.streams.duplex threads continuations math
|
||||
concurrency.promises byte-arrays io.backend tools.hexdump
|
||||
tools.files io.streams.string math.bitwise ;
|
||||
io.streams.string math.bitwise tools.files io.pathnames ;
|
||||
IN: ftp.server
|
||||
|
||||
TUPLE: ftp-client url mode state command-promise user password ;
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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 } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -4,8 +4,7 @@ USING: combinators.short-circuit unicode.categories kernel math
|
|||
combinators splitting sequences math.parser io.files io assocs
|
||||
arrays namespaces make math.ranges unicode.normalize.private values
|
||||
io.encodings.ascii unicode.syntax unicode.data compiler.units fry
|
||||
alien.syntax sets accessors interval-maps memoize locals words
|
||||
strings hints ;
|
||||
alien.syntax sets accessors interval-maps memoize locals words ;
|
||||
IN: unicode.breaks
|
||||
|
||||
<PRIVATE
|
||||
|
|
@ -212,25 +211,21 @@ to: word-table
|
|||
[ dupd walk-up wNumeric property-not= ] }
|
||||
{ check-number-before
|
||||
[ dupd walk-down wNumeric property-not= ] }
|
||||
} case ; inline
|
||||
} case ;
|
||||
|
||||
:: word-break-next ( old-class new-char i str -- next-class ? )
|
||||
new-char dup format/extended?
|
||||
[ drop old-class dup { 1 2 3 } member? ] [
|
||||
word-break-prop old-class over word-table-nth
|
||||
i str word-break?
|
||||
] if ; inline
|
||||
] if ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: first-word ( str -- i )
|
||||
[ unclip-slice word-break-prop over <enum> ] keep
|
||||
'[ swap _ word-break-next ] assoc-find 2drop
|
||||
nip swap length or 1+ ; inline
|
||||
|
||||
HINTS: first-word string ;
|
||||
nip swap length or 1+ ;
|
||||
|
||||
: >words ( str -- words )
|
||||
[ first-word ] >pieces ;
|
||||
|
||||
HINTS: >words string ;
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ io.encodings.ascii kernel values splitting accessors math.parser
|
|||
ascii io assocs strings math namespaces make sorting combinators
|
||||
math.order arrays unicode.normalize unicode.data locals
|
||||
unicode.syntax macros sequences.deep words unicode.breaks
|
||||
quotations ;
|
||||
quotations combinators.short-circuit ;
|
||||
IN: unicode.collation
|
||||
|
||||
<PRIVATE
|
||||
|
|
@ -71,12 +71,12 @@ ducet insert-helpers
|
|||
building get empty? [ 0 ] [ building get peek peek ] if ;
|
||||
|
||||
: blocked? ( char -- ? )
|
||||
combining-class [
|
||||
last combining-class =
|
||||
] [ last combining-class ] if* ;
|
||||
combining-class dup { 0 f } member?
|
||||
[ drop last non-starter? ]
|
||||
[ last combining-class = ] if ;
|
||||
|
||||
: possible-bases ( -- slice-of-building )
|
||||
building get dup [ first combining-class not ] find-last
|
||||
building get dup [ first non-starter? not ] find-last
|
||||
drop [ 0 ] unless* tail-slice ;
|
||||
|
||||
:: ?combine ( char slice i -- ? )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
@ -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
|
||||
|
||||
: <nbody-system> ( -- system )
|
||||
[ <sun> , <jupiter> , <saturn> , <uranus> , <neptune> , ] { } make nbody-system boa
|
||||
[ <sun> <jupiter> <saturn> <uranus> <neptune> ] output>array nbody-system boa
|
||||
dup bodies>> init-bodies ; inline
|
||||
|
||||
:: each-pair ( bodies pair-quot: ( other-body body -- ) each-quot: ( body -- ) -- )
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -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
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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 ) ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
unportable
|
||||
|
|
@ -0,0 +1 @@
|
|||
ncurses binding
|
||||
|
|
@ -0,0 +1 @@
|
|||
unportable
|
||||
|
|
@ -0,0 +1 @@
|
|||
Jose Antonio Ortega Ruiz
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
! Copyright (C) 2009 Jose Antonio Ortega Ruiz.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test fuel.eval ;
|
||||
IN: fuel.eval.tests
|
||||
|
|
@ -0,0 +1,75 @@
|
|||
! Copyright (C) 2009 Jose Antonio Ortega Ruiz.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays compiler.units continuations debugger
|
||||
fuel.pprint io io.streams.string kernel namespaces parser sequences
|
||||
vectors vocabs.parser ;
|
||||
|
||||
IN: fuel.eval
|
||||
|
||||
TUPLE: fuel-status in use restarts ;
|
||||
|
||||
SYMBOL: fuel-status-stack
|
||||
V{ } clone fuel-status-stack set-global
|
||||
|
||||
SYMBOL: fuel-eval-result
|
||||
f fuel-eval-result set-global
|
||||
|
||||
SYMBOL: fuel-eval-output
|
||||
f fuel-eval-result set-global
|
||||
|
||||
SYMBOL: fuel-eval-res-flag
|
||||
t fuel-eval-res-flag set-global
|
||||
|
||||
: fuel-eval-restartable? ( -- ? )
|
||||
fuel-eval-res-flag get-global ; inline
|
||||
|
||||
: fuel-push-status ( -- )
|
||||
in get use get clone restarts get-global clone
|
||||
fuel-status boa
|
||||
fuel-status-stack get push ;
|
||||
|
||||
: fuel-pop-restarts ( restarts -- )
|
||||
fuel-eval-restartable? [ drop ] [ clone restarts set-global ] if ; inline
|
||||
|
||||
: fuel-pop-status ( -- )
|
||||
fuel-status-stack get empty? [
|
||||
fuel-status-stack get pop
|
||||
[ in>> in set ]
|
||||
[ use>> clone use set ]
|
||||
[ restarts>> fuel-pop-restarts ] tri
|
||||
] unless ;
|
||||
|
||||
: fuel-forget-error ( -- ) f error set-global ; inline
|
||||
: fuel-forget-result ( -- ) f fuel-eval-result set-global ; inline
|
||||
: fuel-forget-output ( -- ) f fuel-eval-output set-global ; inline
|
||||
: fuel-forget-status ( -- )
|
||||
fuel-forget-error fuel-forget-result fuel-forget-output ; inline
|
||||
|
||||
: fuel-send-retort ( -- )
|
||||
error get fuel-eval-result get-global fuel-eval-output get-global
|
||||
3array fuel-pprint flush nl "<~FUEL~>" write nl flush ;
|
||||
|
||||
: (fuel-begin-eval) ( -- )
|
||||
fuel-push-status fuel-forget-status ; inline
|
||||
|
||||
: (fuel-end-eval) ( output -- )
|
||||
fuel-eval-output set-global fuel-send-retort fuel-pop-status ; inline
|
||||
|
||||
: (fuel-eval) ( lines -- )
|
||||
[ [ parse-lines ] with-compilation-unit call ] curry
|
||||
[ print-error ] recover ; inline
|
||||
|
||||
: (fuel-eval-each) ( lines -- )
|
||||
[ 1vector (fuel-eval) ] each ; inline
|
||||
|
||||
: (fuel-eval-usings) ( usings -- )
|
||||
[ "USING: " prepend " ;" append ] map
|
||||
(fuel-eval-each) fuel-forget-error fuel-forget-output ;
|
||||
|
||||
: (fuel-eval-in) ( in -- )
|
||||
[ dup "IN: " prepend 1vector (fuel-eval) in set ] when* ; inline
|
||||
|
||||
: (fuel-eval-in-context) ( lines in usings -- )
|
||||
(fuel-begin-eval)
|
||||
[ (fuel-eval-usings) (fuel-eval-in) (fuel-eval) ] with-string-writer
|
||||
(fuel-end-eval) ;
|
||||
|
|
@ -1,34 +1,14 @@
|
|||
! Copyright (C) 2008, 2009 Jose Antonio Ortega Ruiz.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
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 prettyprint quotations
|
||||
sequences sets sorting source-files strings summary tools.crossref
|
||||
tools.scaffold tools.vocabs tools.vocabs.browser vectors vocabs
|
||||
vocabs.loader vocabs.parser words ;
|
||||
USING: accessors arrays assocs compiler.units definitions fuel.eval
|
||||
fuel.help help.markup help.topics io.pathnames kernel math math.order
|
||||
memoize namespaces parser sequences sets sorting tools.crossref
|
||||
tools.scaffold tools.vocabs vocabs vocabs.loader vocabs.parser words ;
|
||||
|
||||
IN: fuel
|
||||
|
||||
! Evaluation status:
|
||||
|
||||
TUPLE: fuel-status in use restarts ;
|
||||
|
||||
SYMBOL: fuel-status-stack
|
||||
V{ } clone fuel-status-stack set-global
|
||||
|
||||
SYMBOL: fuel-eval-result
|
||||
f fuel-eval-result set-global
|
||||
|
||||
SYMBOL: fuel-eval-output
|
||||
f fuel-eval-result set-global
|
||||
|
||||
SYMBOL: fuel-eval-res-flag
|
||||
t fuel-eval-res-flag set-global
|
||||
|
||||
: fuel-eval-restartable? ( -- ? )
|
||||
fuel-eval-res-flag get-global ; inline
|
||||
! Evaluation
|
||||
|
||||
: fuel-eval-restartable ( -- )
|
||||
t fuel-eval-res-flag set-global ; inline
|
||||
|
|
@ -36,156 +16,64 @@ t fuel-eval-res-flag set-global
|
|||
: fuel-eval-non-restartable ( -- )
|
||||
f fuel-eval-res-flag set-global ; inline
|
||||
|
||||
: fuel-push-status ( -- )
|
||||
in get use get clone restarts get-global clone
|
||||
fuel-status boa
|
||||
fuel-status-stack get push ;
|
||||
|
||||
: fuel-pop-restarts ( restarts -- )
|
||||
fuel-eval-restartable? [ drop ] [ clone restarts set-global ] if ; inline
|
||||
|
||||
: fuel-pop-status ( -- )
|
||||
fuel-status-stack get empty? [
|
||||
fuel-status-stack get pop
|
||||
[ in>> in set ]
|
||||
[ use>> clone use set ]
|
||||
[ restarts>> fuel-pop-restarts ] tri
|
||||
] unless ;
|
||||
|
||||
! Lispy pretty printing
|
||||
|
||||
GENERIC: fuel-pprint ( obj -- )
|
||||
|
||||
M: object fuel-pprint pprint ; inline
|
||||
|
||||
: fuel-maybe-scape ( ch -- seq )
|
||||
dup "\\\"?#()[]'`" member? [ CHAR: \ swap 2array ] [ 1array ] if ;
|
||||
|
||||
M: word fuel-pprint
|
||||
name>> V{ } clone [ fuel-maybe-scape append ] reduce >string write ;
|
||||
|
||||
M: f fuel-pprint drop "nil" write ; inline
|
||||
|
||||
M: integer fuel-pprint pprint ; inline
|
||||
|
||||
M: string fuel-pprint pprint ; 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: continuation fuel-pprint drop ":continuation" write ; inline
|
||||
|
||||
M: restart fuel-pprint name>> fuel-pprint ; inline
|
||||
|
||||
SYMBOL: :restarts
|
||||
|
||||
: fuel-restarts ( obj -- seq )
|
||||
compute-restarts :restarts prefix ; inline
|
||||
|
||||
M: condition fuel-pprint
|
||||
[ error>> ] [ fuel-restarts ] bi 2array condition prefix fuel-pprint ;
|
||||
|
||||
M: lexer-error fuel-pprint
|
||||
{
|
||||
[ line>> ]
|
||||
[ column>> ]
|
||||
[ line-text>> ]
|
||||
[ fuel-restarts ]
|
||||
} cleave 4array lexer-error prefix fuel-pprint ;
|
||||
|
||||
M: source-file-error fuel-pprint
|
||||
[ file>> ] [ error>> ] bi 2array source-file-error prefix
|
||||
fuel-pprint ;
|
||||
|
||||
M: source-file fuel-pprint path>> fuel-pprint ;
|
||||
|
||||
! Evaluation vocabulary
|
||||
: fuel-eval-in-context ( lines in usings -- )
|
||||
(fuel-eval-in-context) ;
|
||||
|
||||
: fuel-eval-set-result ( obj -- )
|
||||
clone fuel-eval-result set-global ; inline
|
||||
|
||||
: fuel-retort ( -- )
|
||||
error get fuel-eval-result get-global fuel-eval-output get-global
|
||||
3array fuel-pprint flush nl "<~FUEL~>" write nl flush ;
|
||||
|
||||
: fuel-forget-error ( -- ) f error set-global ; inline
|
||||
: fuel-forget-result ( -- ) f fuel-eval-result set-global ; inline
|
||||
: fuel-forget-output ( -- ) f fuel-eval-output set-global ; inline
|
||||
: fuel-forget-status ( -- )
|
||||
fuel-forget-error fuel-forget-result fuel-forget-output ; inline
|
||||
|
||||
: (fuel-begin-eval) ( -- )
|
||||
fuel-push-status fuel-forget-status ; inline
|
||||
|
||||
: (fuel-end-eval) ( output -- )
|
||||
fuel-eval-output set-global fuel-retort fuel-pop-status ; inline
|
||||
|
||||
: (fuel-eval) ( lines -- )
|
||||
[ [ parse-lines ] with-compilation-unit call ] curry
|
||||
[ print-error ] recover ; inline
|
||||
|
||||
: (fuel-eval-each) ( lines -- )
|
||||
[ 1vector (fuel-eval) ] each ; inline
|
||||
|
||||
: (fuel-eval-usings) ( usings -- )
|
||||
[ "USING: " prepend " ;" append ] map
|
||||
(fuel-eval-each) fuel-forget-error fuel-forget-output ;
|
||||
|
||||
: (fuel-eval-in) ( in -- )
|
||||
[ dup "IN: " prepend 1vector (fuel-eval) in set ] when* ; inline
|
||||
|
||||
: fuel-eval-in-context ( lines in usings -- )
|
||||
(fuel-begin-eval)
|
||||
[ (fuel-eval-usings) (fuel-eval-in) (fuel-eval) ] with-string-writer
|
||||
(fuel-end-eval) ;
|
||||
: fuel-retort ( -- ) fuel-send-retort ; inline
|
||||
|
||||
! Loading files
|
||||
|
||||
<PRIVATE
|
||||
|
||||
SYMBOL: :uses
|
||||
|
||||
: fuel-set-use-hook ( -- )
|
||||
[ amended-use get clone :uses prefix fuel-eval-set-result ]
|
||||
print-use-hook set ;
|
||||
|
||||
: (fuel-get-uses) ( lines -- )
|
||||
[ parse-fresh drop ] curry with-compilation-unit ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: fuel-run-file ( path -- )
|
||||
[ fuel-set-use-hook run-file ] curry with-scope ; inline
|
||||
|
||||
: fuel-with-autouse ( ... quot: ( ... -- ... ) -- ... )
|
||||
[ auto-use? on fuel-set-use-hook call ] curry with-scope ; inline
|
||||
|
||||
: (fuel-get-uses) ( lines -- )
|
||||
[ parse-fresh drop ] curry with-compilation-unit ; inline
|
||||
|
||||
: fuel-get-uses ( lines -- )
|
||||
[ (fuel-get-uses) ] curry fuel-with-autouse ;
|
||||
|
||||
! Edit locations
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: fuel-normalize-loc ( seq -- path line )
|
||||
[ dup length 0 > [ first (normalize-path) ] [ drop f ] if ]
|
||||
[ dup length 1 > [ second ] [ drop 1 ] if ] bi ;
|
||||
|
||||
: fuel-get-edit-location ( word -- )
|
||||
where fuel-normalize-loc 2array fuel-eval-set-result ; inline
|
||||
: fuel-get-loc ( object -- )
|
||||
fuel-normalize-loc 2array fuel-eval-set-result ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: fuel-get-edit-location ( word -- ) where fuel-get-loc ; inline
|
||||
|
||||
: fuel-get-vocab-location ( vocab -- )
|
||||
>vocab-link fuel-get-edit-location ; inline
|
||||
|
||||
: fuel-get-doc-location ( word -- )
|
||||
props>> "help-loc" swap at
|
||||
fuel-normalize-loc 2array fuel-eval-set-result ;
|
||||
: fuel-get-doc-location ( word -- ) props>> "help-loc" swap at fuel-get-loc ;
|
||||
|
||||
: fuel-get-article-location ( name -- )
|
||||
article loc>> fuel-normalize-loc 2array fuel-eval-set-result ;
|
||||
: fuel-get-article-location ( name -- ) article loc>> fuel-get-loc ;
|
||||
|
||||
! Cross-references
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: fuel-word>xref ( word -- xref )
|
||||
[ name>> ] [ vocabulary>> ] [ where fuel-normalize-loc ] tri 4array ;
|
||||
|
||||
|
|
@ -195,6 +83,11 @@ SYMBOL: :uses
|
|||
: fuel-format-xrefs ( seq -- seq' )
|
||||
[ word? ] filter [ fuel-word>xref ] map ; inline
|
||||
|
||||
: (fuel-index) ( seq -- seq )
|
||||
[ [ >link name>> ] [ article-title ] bi 2array \ $subsection prefix ] map ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: fuel-callers-xref ( word -- )
|
||||
usage fuel-format-xrefs fuel-sort-xrefs fuel-eval-set-result ; inline
|
||||
|
||||
|
|
@ -207,23 +100,19 @@ SYMBOL: :uses
|
|||
: fuel-vocab-xref ( vocab -- )
|
||||
words fuel-format-xrefs fuel-eval-set-result ; inline
|
||||
|
||||
: fuel-index ( quot: ( -- seq ) -- )
|
||||
call (fuel-index) fuel-eval-set-result ; inline
|
||||
|
||||
! Completion support
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: fuel-filter-prefix ( seq prefix -- seq )
|
||||
[ drop-prefix nip length 0 = ] curry filter prune ; inline
|
||||
|
||||
: (fuel-get-vocabs) ( -- seq )
|
||||
all-vocabs-seq [ vocab-name ] map ; inline
|
||||
|
||||
: fuel-get-vocabs ( -- )
|
||||
(fuel-get-vocabs) fuel-eval-set-result ; inline
|
||||
|
||||
: fuel-get-vocabs/prefix ( prefix -- )
|
||||
(fuel-get-vocabs) swap fuel-filter-prefix fuel-eval-set-result ; inline
|
||||
|
||||
: fuel-vocab-summary ( name -- )
|
||||
>vocab-link summary fuel-eval-set-result ; inline
|
||||
|
||||
MEMO: (fuel-vocab-words) ( name -- seq )
|
||||
>vocab-link words [ name>> ] map ;
|
||||
|
||||
|
|
@ -237,151 +126,48 @@ MEMO: (fuel-vocab-words) ( name -- seq )
|
|||
[ fuel-vocabs-words ] [ fuel-current-words ] if* natural-sort
|
||||
swap fuel-filter-prefix ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: fuel-get-vocabs ( -- )
|
||||
(fuel-get-vocabs) fuel-eval-set-result ;
|
||||
|
||||
: fuel-get-vocabs/prefix ( prefix -- )
|
||||
(fuel-get-vocabs) swap fuel-filter-prefix fuel-eval-set-result ;
|
||||
|
||||
: fuel-get-words ( prefix names -- )
|
||||
(fuel-get-words) fuel-eval-set-result ; inline
|
||||
(fuel-get-words) fuel-eval-set-result ;
|
||||
|
||||
! Help support
|
||||
|
||||
MEMO: fuel-articles-seq ( -- seq )
|
||||
articles get values ;
|
||||
: fuel-get-article ( name -- ) article fuel-eval-set-result ;
|
||||
|
||||
: fuel-find-articles ( title -- seq )
|
||||
[ [ article-title ] dip = ] curry fuel-articles-seq swap filter ;
|
||||
MEMO: fuel-get-article-title ( name -- )
|
||||
articles get at [ article-title ] [ f ] if* fuel-eval-set-result ;
|
||||
|
||||
MEMO: fuel-find-article ( title -- article/f )
|
||||
fuel-find-articles dup empty? [ drop f ] [ first ] if ;
|
||||
: fuel-word-help ( name -- ) (fuel-word-help) fuel-eval-set-result ;
|
||||
|
||||
MEMO: fuel-article-title ( name -- title/f )
|
||||
articles get at [ article-title ] [ f ] if* ;
|
||||
: fuel-word-see ( name -- ) (fuel-word-see) fuel-eval-set-result ;
|
||||
|
||||
: fuel-get-article ( name -- )
|
||||
article fuel-eval-set-result ;
|
||||
: fuel-vocab-help ( name -- ) (fuel-vocab-help) fuel-eval-set-result ;
|
||||
|
||||
: fuel-value-str ( word -- str )
|
||||
[ pprint-short ] with-string-writer ; inline
|
||||
|
||||
: fuel-definition-str ( word -- str )
|
||||
[ see ] with-string-writer ; inline
|
||||
|
||||
: fuel-methods-str ( word -- str )
|
||||
methods dup empty? not [
|
||||
[ [ see nl ] each ] with-string-writer
|
||||
] [ drop f ] if ; inline
|
||||
|
||||
: fuel-related-words ( word -- seq )
|
||||
dup "related" word-prop remove ; inline
|
||||
|
||||
: fuel-parent-topics ( word -- seq )
|
||||
help-path [ dup article-title swap 2array ] map ; inline
|
||||
|
||||
: (fuel-word-help) ( word -- element )
|
||||
\ article swap dup article-title swap
|
||||
[
|
||||
{
|
||||
[ fuel-parent-topics [ \ $doc-path prefix , ] unless-empty ]
|
||||
[ \ $vocabulary swap vocabulary>> 2array , ]
|
||||
[ word-help % ]
|
||||
[ fuel-related-words [ \ $related swap 2array , ] unless-empty ]
|
||||
[ get-global [ \ $value swap fuel-value-str 2array , ] when* ]
|
||||
[ \ $definition swap fuel-definition-str 2array , ]
|
||||
[ fuel-methods-str [ \ $methods swap 2array , ] when* ]
|
||||
} cleave
|
||||
] { } make 3array ;
|
||||
|
||||
MEMO: fuel-find-word ( name -- word/f )
|
||||
[ [ name>> ] dip = ] curry all-words swap filter
|
||||
dup empty? not [ first ] [ drop f ] if ;
|
||||
|
||||
: fuel-word-help ( name -- )
|
||||
fuel-find-word [ [ auto-use? on (fuel-word-help) ] with-scope ] [ f ] if*
|
||||
fuel-eval-set-result ; inline
|
||||
|
||||
: (fuel-word-see) ( word -- elem )
|
||||
[ name>> \ article swap ]
|
||||
[ [ see ] with-string-writer \ $code swap 2array ] bi 3array ; inline
|
||||
|
||||
: fuel-word-see ( name -- )
|
||||
fuel-find-word [ [ auto-use? on (fuel-word-see) ] with-scope ] [ f ] if*
|
||||
fuel-eval-set-result ; inline
|
||||
|
||||
: fuel-vocab-help-row ( vocab -- element )
|
||||
[ vocab-status-string ] [ vocab-name ] [ summary ] tri 3array ;
|
||||
|
||||
: fuel-vocab-help-root-heading ( root -- element )
|
||||
[ "Children from " prepend ] [ "Other children" ] if* \ $heading swap 2array ;
|
||||
|
||||
SYMBOL: vocab-list
|
||||
|
||||
: fuel-vocab-help-table ( vocabs -- element )
|
||||
[ fuel-vocab-help-row ] map vocab-list prefix ;
|
||||
|
||||
: fuel-vocab-list ( assoc -- seq )
|
||||
[
|
||||
[ drop f ] [
|
||||
[ fuel-vocab-help-root-heading ]
|
||||
[ fuel-vocab-help-table ] bi*
|
||||
[ 2array ] [ drop f ] if*
|
||||
] if-empty
|
||||
] { } assoc>map [ ] filter ;
|
||||
|
||||
: fuel-vocab-children-help ( name -- element )
|
||||
all-child-vocabs fuel-vocab-list ; inline
|
||||
|
||||
: fuel-vocab-describe-words ( name -- element )
|
||||
[ describe-words ] with-string-writer \ describe-words swap 2array ; inline
|
||||
|
||||
: (fuel-vocab-help) ( name -- element )
|
||||
dup require \ article swap dup >vocab-link
|
||||
[
|
||||
{
|
||||
[ vocab-authors [ \ $authors prefix , ] when* ]
|
||||
[ vocab-tags [ \ $tags prefix , ] when* ]
|
||||
[ summary [ { $heading "Summary" } swap 2array , ] when* ]
|
||||
[ drop \ $nl , ]
|
||||
[ vocab-help [ article content>> % ] when* ]
|
||||
[ name>> fuel-vocab-describe-words , ]
|
||||
[ name>> fuel-vocab-children-help % ]
|
||||
} cleave
|
||||
] { } make 3array ;
|
||||
|
||||
: fuel-vocab-help ( name -- )
|
||||
dup empty? [ fuel-vocab-children-help ] [ (fuel-vocab-help) ] if
|
||||
fuel-eval-set-result ; inline
|
||||
|
||||
: (fuel-index) ( seq -- seq )
|
||||
[ [ >link name>> ] [ article-title ] bi 2array \ $subsection prefix ] map ;
|
||||
|
||||
: fuel-index ( quot: ( -- seq ) -- )
|
||||
call (fuel-index) fuel-eval-set-result ; inline
|
||||
|
||||
MEMO: (fuel-get-vocabs/author) ( author -- element )
|
||||
[ "Vocabularies by " prepend \ $heading swap 2array ]
|
||||
[ authored fuel-vocab-list ] bi 2array ;
|
||||
|
||||
: fuel-get-vocabs/author ( author -- )
|
||||
(fuel-get-vocabs/author) fuel-eval-set-result ;
|
||||
|
||||
MEMO: (fuel-get-vocabs/tag) ( tag -- element )
|
||||
[ "Vocabularies tagged " prepend \ $heading swap 2array ]
|
||||
[ tagged fuel-vocab-list ] bi 2array ;
|
||||
: fuel-vocab-summary ( name -- )
|
||||
(fuel-vocab-summary) fuel-eval-set-result ;
|
||||
|
||||
: fuel-get-vocabs/tag ( tag -- )
|
||||
(fuel-get-vocabs/tag) fuel-eval-set-result ;
|
||||
|
||||
: fuel-get-vocabs/author ( author -- )
|
||||
(fuel-get-vocabs/author) 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 ;
|
||||
developer-name set dup [ scaffold-vocab ] dip
|
||||
dup require vocab-source-path (normalize-path) 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
|
||||
|
||||
: fuel-startup ( -- ) "listener" run-file ; inline
|
||||
|
||||
MAIN: fuel-startup
|
||||
: fuel-scaffold-get-root ( name -- ) find-vocab-root fuel-eval-set-result ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Jose Antonio Ortega Ruiz
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
! Copyright (C) 2009 Jose Antonio Ortega Ruiz.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test fuel.help ;
|
||||
IN: fuel.help.tests
|
||||
|
|
@ -0,0 +1,108 @@
|
|||
! Copyright (C) 2009 Jose Antonio Ortega Ruiz.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
USING: accessors arrays assocs combinators help help.crossref
|
||||
help.markup help.topics io io.streams.string kernel make memoize
|
||||
namespaces parser prettyprint sequences summary tools.vocabs
|
||||
tools.vocabs.browser vocabs vocabs.loader words ;
|
||||
|
||||
IN: fuel.help
|
||||
|
||||
<PRIVATE
|
||||
|
||||
MEMO: fuel-find-word ( name -- word/f )
|
||||
[ [ name>> ] dip = ] curry all-words swap filter
|
||||
dup empty? not [ first ] [ drop f ] if ;
|
||||
|
||||
: fuel-value-str ( word -- str )
|
||||
[ pprint-short ] with-string-writer ; inline
|
||||
|
||||
: fuel-definition-str ( word -- str )
|
||||
[ see ] with-string-writer ; inline
|
||||
|
||||
: fuel-methods-str ( word -- str )
|
||||
methods dup empty? not [
|
||||
[ [ see nl ] each ] with-string-writer
|
||||
] [ drop f ] if ; inline
|
||||
|
||||
: fuel-related-words ( word -- seq )
|
||||
dup "related" word-prop remove ; inline
|
||||
|
||||
: fuel-parent-topics ( word -- seq )
|
||||
help-path [ dup article-title swap 2array ] map ; inline
|
||||
|
||||
: (fuel-word-element) ( word -- element )
|
||||
\ article swap dup article-title swap
|
||||
[
|
||||
{
|
||||
[ fuel-parent-topics [ \ $doc-path prefix , ] unless-empty ]
|
||||
[ \ $vocabulary swap vocabulary>> 2array , ]
|
||||
[ word-help % ]
|
||||
[ fuel-related-words [ \ $related swap 2array , ] unless-empty ]
|
||||
[ get-global [ \ $value swap fuel-value-str 2array , ] when* ]
|
||||
[ \ $definition swap fuel-definition-str 2array , ]
|
||||
[ fuel-methods-str [ \ $methods swap 2array , ] when* ]
|
||||
} cleave
|
||||
] { } make 3array ;
|
||||
|
||||
: fuel-vocab-help-row ( vocab -- element )
|
||||
[ vocab-status-string ] [ vocab-name ] [ summary ] tri 3array ;
|
||||
|
||||
: fuel-vocab-help-root-heading ( root -- element )
|
||||
[ "Children from " prepend ] [ "Other children" ] if* \ $heading swap 2array ;
|
||||
|
||||
SYMBOL: vocab-list
|
||||
|
||||
: fuel-vocab-help-table ( vocabs -- element )
|
||||
[ fuel-vocab-help-row ] map vocab-list prefix ;
|
||||
|
||||
: fuel-vocab-list ( assoc -- seq )
|
||||
[
|
||||
[ drop f ] [
|
||||
[ fuel-vocab-help-root-heading ]
|
||||
[ fuel-vocab-help-table ] bi*
|
||||
[ 2array ] [ drop f ] if*
|
||||
] if-empty
|
||||
] { } assoc>map [ ] filter ;
|
||||
|
||||
: fuel-vocab-children-help ( name -- element )
|
||||
all-child-vocabs fuel-vocab-list ; inline
|
||||
|
||||
: fuel-vocab-describe-words ( name -- element )
|
||||
[ describe-words ] with-string-writer \ describe-words swap 2array ; inline
|
||||
|
||||
: (fuel-vocab-element) ( name -- element )
|
||||
dup require \ article swap dup >vocab-link
|
||||
[
|
||||
{
|
||||
[ vocab-authors [ \ $authors prefix , ] when* ]
|
||||
[ vocab-tags [ \ $tags prefix , ] when* ]
|
||||
[ summary [ { $heading "Summary" } swap 2array , ] when* ]
|
||||
[ drop \ $nl , ]
|
||||
[ vocab-help [ article content>> % ] when* ]
|
||||
[ name>> fuel-vocab-describe-words , ]
|
||||
[ name>> fuel-vocab-children-help % ]
|
||||
} cleave
|
||||
] { } make 3array ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: (fuel-word-help) ( object -- object )
|
||||
fuel-find-word [ [ auto-use? on (fuel-word-element) ] with-scope ] [ f ] if* ;
|
||||
|
||||
: (fuel-word-see) ( word -- elem )
|
||||
[ name>> \ article swap ]
|
||||
[ [ see ] with-string-writer \ $code swap 2array ] bi 3array ; inline
|
||||
|
||||
: (fuel-vocab-summary) ( name -- str ) >vocab-link summary ; inline
|
||||
|
||||
: (fuel-vocab-help) ( name -- str )
|
||||
dup empty? [ fuel-vocab-children-help ] [ (fuel-vocab-element) ] if ;
|
||||
|
||||
MEMO: (fuel-get-vocabs/author) ( author -- element )
|
||||
[ "Vocabularies by " prepend \ $heading swap 2array ]
|
||||
[ authored fuel-vocab-list ] bi 2array ;
|
||||
|
||||
MEMO: (fuel-get-vocabs/tag) ( tag -- element )
|
||||
[ "Vocabularies tagged " prepend \ $heading swap 2array ]
|
||||
[ tagged fuel-vocab-list ] bi 2array ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Jose Antonio Ortega Ruiz
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
! Copyright (C) 2009 Jose Antonio Ortega Ruiz.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test fuel.pprint ;
|
||||
IN: fuel.pprint.tests
|
||||
|
|
@ -0,0 +1,63 @@
|
|||
! Copyright (C) 2009 Jose Antonio Ortega Ruiz.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
USING: accessors arrays classes.tuple combinators continuations io
|
||||
kernel lexer math prettyprint quotations sequences source-files
|
||||
strings words ;
|
||||
|
||||
IN: fuel.pprint
|
||||
|
||||
GENERIC: fuel-pprint ( obj -- )
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: fuel-maybe-scape ( ch -- seq )
|
||||
dup "\\\"?#()[]'`" member? [ CHAR: \ swap 2array ] [ 1array ] if ;
|
||||
|
||||
SYMBOL: :restarts
|
||||
|
||||
: fuel-restarts ( obj -- seq )
|
||||
compute-restarts :restarts prefix ; inline
|
||||
|
||||
: fuel-pprint-sequence ( seq open close -- )
|
||||
[ write ] dip swap [ " " write ] [ fuel-pprint ] interleave write ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
M: object fuel-pprint pprint ; inline
|
||||
|
||||
M: word fuel-pprint
|
||||
name>> V{ } clone [ fuel-maybe-scape append ] reduce >string write ;
|
||||
|
||||
M: f fuel-pprint drop "nil" write ; inline
|
||||
|
||||
M: integer fuel-pprint pprint ; inline
|
||||
|
||||
M: string fuel-pprint pprint ; 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: continuation fuel-pprint drop ":continuation" write ; inline
|
||||
|
||||
M: restart fuel-pprint name>> fuel-pprint ; inline
|
||||
|
||||
M: condition fuel-pprint
|
||||
[ error>> ] [ fuel-restarts ] bi 2array condition prefix fuel-pprint ;
|
||||
|
||||
M: lexer-error fuel-pprint
|
||||
{
|
||||
[ line>> ]
|
||||
[ column>> ]
|
||||
[ line-text>> ]
|
||||
[ fuel-restarts ]
|
||||
} cleave 4array lexer-error prefix fuel-pprint ;
|
||||
|
||||
M: source-file-error fuel-pprint
|
||||
[ file>> ] [ error>> ] bi 2array source-file-error prefix
|
||||
fuel-pprint ;
|
||||
|
||||
M: source-file fuel-pprint path>> fuel-pprint ;
|
||||
|
|
@ -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 ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
@ -32,6 +32,7 @@ beast.
|
|||
(require 'factor-mode)
|
||||
|
||||
* Basic usage
|
||||
*** Running the listener
|
||||
|
||||
If you're using the default factor binary and images locations inside
|
||||
the Factor's source tree, that should be enough to start using FUEL.
|
||||
|
|
@ -97,6 +98,7 @@ beast.
|
|||
|
||||
- C-cC-xs : extract innermost sexp (up to point) as a separate word
|
||||
- C-cC-xr : extract region as a separate word
|
||||
- C-cC-xv : extract region as a separate vocabulary
|
||||
|
||||
*** In the listener:
|
||||
|
||||
|
|
|
|||
|
|
@ -160,7 +160,7 @@
|
|||
(fuel-con--send-string/wait buffer
|
||||
fuel-con--init-stanza
|
||||
'fuel-con--establish-connection-cont
|
||||
20000)
|
||||
60000)
|
||||
conn))
|
||||
|
||||
(defun fuel-con--establish-connection-cont (ignore)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; fuel-debug-uses.el -- retrieving USING: stanzas
|
||||
|
||||
;; Copyright (C) 2008 Jose Antonio Ortega Ruiz
|
||||
;; Copyright (C) 2008, 2009 Jose Antonio Ortega Ruiz
|
||||
;; See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
|
||||
|
|
@ -32,6 +32,9 @@
|
|||
|
||||
;;; Utility functions:
|
||||
|
||||
(defsubst fuel-debug--chomp (s)
|
||||
(replace-regexp-in-string "[\n\r\f]" "" s))
|
||||
|
||||
(defun fuel-debug--file-lines (file)
|
||||
(when (file-readable-p file)
|
||||
(with-current-buffer (find-file-noselect file)
|
||||
|
|
@ -40,7 +43,8 @@
|
|||
(let ((lines) (in-usings))
|
||||
(while (not (eobp))
|
||||
(when (looking-at "^USING: ") (setq in-usings t))
|
||||
(let ((line (substring-no-properties (thing-at-point 'line) 0 -1)))
|
||||
(let ((line (fuel-debug--chomp
|
||||
(substring-no-properties (thing-at-point 'line)))))
|
||||
(when in-usings (setq line (concat "! " line)))
|
||||
(push line lines))
|
||||
(when (and in-usings (looking-at ".*\\_<;\\_>")) (setq in-usings nil))
|
||||
|
|
|
|||
|
|
@ -73,7 +73,7 @@ buffer."
|
|||
(error "Could not run factor: %s is not executable" factor))
|
||||
(unless (file-readable-p image)
|
||||
(error "Could not run factor: image file %s not readable" image))
|
||||
(message "Starting FUEL listener ...")
|
||||
(message "Starting FUEL listener (this may take a while) ...")
|
||||
(pop-to-buffer (fuel-listener--buffer))
|
||||
(make-comint-in-buffer "fuel listener" (current-buffer) factor nil
|
||||
"-run=listener" (format "-i=%s" image))
|
||||
|
|
|
|||
|
|
@ -71,7 +71,7 @@
|
|||
|
||||
(defun fuel-markup--article-title (name)
|
||||
(fuel-eval--retort-result
|
||||
(fuel-eval--send/wait `(:fuel* ((,name fuel-article-title :get)) "fuel"))))
|
||||
(fuel-eval--send/wait `(:fuel* ((,name fuel-get-article-title)) "fuel"))))
|
||||
|
||||
(defun fuel-markup--link-at-point ()
|
||||
(let ((button (condition-case nil (forward-button 0) (error nil))))
|
||||
|
|
|
|||
|
|
@ -196,6 +196,7 @@ interacting with a factor listener is at your disposal.
|
|||
|
||||
(fuel-mode--key ?x ?s 'fuel-refactor-extract-sexp)
|
||||
(fuel-mode--key ?x ?r 'fuel-refactor-extract-region)
|
||||
(fuel-mode--key ?x ?v 'fuel-refactor-extract-vocab)
|
||||
|
||||
(fuel-mode--key ?d ?> 'fuel-show-callees)
|
||||
(fuel-mode--key ?d ?< 'fuel-show-callers)
|
||||
|
|
|
|||
|
|
@ -13,6 +13,7 @@
|
|||
|
||||
;;; Code:
|
||||
|
||||
(require 'fuel-scaffold)
|
||||
(require 'fuel-stack)
|
||||
(require 'fuel-syntax)
|
||||
(require 'fuel-base)
|
||||
|
|
@ -70,7 +71,46 @@ word."
|
|||
(if (looking-at-p ";") (point)
|
||||
(fuel-syntax--end-of-symbol-pos))))
|
||||
|
||||
|
||||
;;; Extract vocab:
|
||||
|
||||
(defun fuel-refactor--insert-using (vocab)
|
||||
(save-excursion
|
||||
(goto-char (point-min))
|
||||
(let ((usings (sort (cons vocab (fuel-syntax--usings)) 'string<)))
|
||||
(fuel-debug--replace-usings (buffer-file-name) usings))))
|
||||
|
||||
(defun fuel-refactor--vocab-root (vocab)
|
||||
(let ((cmd `(:fuel* (,vocab fuel-scaffold-get-root) "fuel")))
|
||||
(fuel-eval--retort-result (fuel-eval--send/wait cmd))))
|
||||
|
||||
(defun fuel-refactor--extract-vocab (begin end)
|
||||
(when (< begin end)
|
||||
(let* ((str (buffer-substring begin end))
|
||||
(buffer (current-buffer))
|
||||
(vocab (fuel-syntax--current-vocab))
|
||||
(vocab-hint (and vocab (format "%s." vocab)))
|
||||
(root-hint (fuel-refactor--vocab-root vocab))
|
||||
(vocab (fuel-scaffold-vocab t vocab-hint root-hint)))
|
||||
(with-current-buffer buffer
|
||||
(delete-region begin end)
|
||||
(fuel-refactor--insert-using vocab))
|
||||
(newline)
|
||||
(insert str)
|
||||
(newline)
|
||||
(save-buffer)
|
||||
(fuel-update-usings))))
|
||||
|
||||
(defun fuel-refactor-extract-vocab (begin end)
|
||||
"Creates a new vocab with the words in current region.
|
||||
The region is extended to the closest definition boundaries."
|
||||
(interactive "r")
|
||||
(fuel-refactor--extract-vocab (save-excursion (goto-char begin)
|
||||
(mark-defun)
|
||||
(point))
|
||||
(save-excursion (goto-char end)
|
||||
(mark-defun)
|
||||
(mark))))
|
||||
|
||||
(provide 'fuel-refactor)
|
||||
;;; fuel-refactor.el ends here
|
||||
|
|
|
|||
|
|
@ -41,25 +41,26 @@
|
|||
|
||||
;;; User interface:
|
||||
|
||||
(defun fuel-scaffold-vocab ()
|
||||
(defun fuel-scaffold-vocab (&optional other-window name-hint root-hint)
|
||||
"Creates a directory in the given root for a new vocabulary and
|
||||
adds source, tests and authors.txt files.
|
||||
|
||||
You can configure `fuel-scaffold-developer-name' (set by default to
|
||||
`user-full-name') for the name to be inserted in the generated files."
|
||||
(interactive)
|
||||
(let* ((name (read-string "Vocab name: "))
|
||||
(let* ((name (read-string "Vocab name: " name-hint))
|
||||
(root (completing-read "Vocab root: "
|
||||
(fuel-scaffold--vocab-roots)
|
||||
nil t "resource:"))
|
||||
nil t (or root-hint "resource:")))
|
||||
(cmd `(:fuel* ((,root ,name ,fuel-scaffold-developer-name)
|
||||
(fuel-scaffold-vocab)) "fuel"))
|
||||
(ret (fuel-eval--send/wait cmd))
|
||||
(file (fuel-eval--retort-result ret)))
|
||||
(unless file
|
||||
(error "Error creating vocab (%s)" (car (fuel-eval--retort-error ret))))
|
||||
(find-file file)
|
||||
(goto-char (point-max))))
|
||||
(if other-window (find-file-other-window file) (find-file file))
|
||||
(goto-char (point-max))
|
||||
name))
|
||||
|
||||
(defun fuel-scaffold-help (&optional arg)
|
||||
"Creates, if it does not already exist, a help file with
|
||||
|
|
|
|||
Loading…
Reference in New Issue