-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: vocabs vocabs.loader kernel ;
+USING: vocabs vocabs.loader kernel io.thread threads
+compiler.utilities namespaces ;
IN: bootstrap.threads
-USE: io.thread
-USE: threads
-
"debugger" vocab [
"debugger.threads" require
] when
+
+[ yield ] yield-hook set-global
\ No newline at end of file
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces make math math.order math.parser sequences accessors
kernel kernel.private layouts assocs words summary arrays
combinators classes.algebra alien alien.c-types alien.structs
-alien.strings alien.arrays sets threads libc continuations.private
+alien.strings alien.arrays sets libc continuations.private
fry cpu.architecture
compiler.errors
compiler.alien
compiler.cfg.instructions
compiler.cfg.registers
compiler.cfg.builder
-compiler.codegen.fixup ;
+compiler.codegen.fixup
+compiler.utilities ;
IN: compiler.codegen
GENERIC: generate-insn ( insn -- )
dup current-callback eq? [
drop
] [
- yield wait-to-return
+ yield-hook get call wait-to-return
] if ;
: do-callback ( quot token -- )
-! Copyright (C) 2004, 2008 Slava Pestov.
+! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces arrays sequences io
words fry continuations vocabs assocs dlists definitions math
-threads graphs generic combinators deques search-deques io
+graphs generic combinators deques search-deques io
stack-checker stack-checker.state stack-checker.inlining
compiler.errors compiler.units compiler.tree.builder
compiler.tree.optimizer compiler.cfg.builder
compiler.cfg.optimizer compiler.cfg.linearization
compiler.cfg.two-operand compiler.cfg.linear-scan
-compiler.cfg.stack-frame compiler.codegen ;
+compiler.cfg.stack-frame compiler.codegen compiler.utilities ;
IN: compiler
SYMBOL: compile-queue
] with-return ;
: compile-loop ( deque -- )
- [ (compile) yield ] slurp-deque ;
+ [ (compile) yield-hook get call ] slurp-deque ;
: decompile ( word -- )
f 2array 1array t modify-code-heap ;
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences sequences.private arrays vectors fry
-math.order ;
+math.order namespaces assocs ;
IN: compiler.utilities
: flattener ( seq quot -- seq vector quot' )
: map-flat ( seq quot -- seq' ) [ each ] flattening ; inline
: 2map-flat ( seq quot -- seq' ) [ 2each ] flattening ; inline
+
+SYMBOL: yield-hook
+
+yield-hook global [ [ ] or ] change-at
: db-tester2 ( test-db -- )
[
- [ test-1 recreate-table ] with-db
- ] [
[
- 2 [
- 10 random 100 random 100 random 100 random test-1 boa
+ test-1 ensure-table
+ test-2 ensure-table
+ ] with-db
+ ] [
+ <db-pool> [
+ 10 [
+ 10 [
+ f 100 random 100 random 100 random test-1 boa
insert-tuple yield
+ ] times
] parallel-each
- ] with-db
+ ] with-pooled-db
] bi ;
! Copyright (C) 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: delegate sequences.private sequences assocs
-io definitions kernel continuations ;
+io io.styles definitions kernel continuations ;
IN: delegate.protocols
PROTOCOL: sequence-protocol
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
! 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 ( -- )
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 ;
{ $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.
{ $subsection "io.streams.byte-array" }
{ $heading "Utilities" }
{ $subsection "stream-binary" }
-{ $subsection "styles" }
+{ $subsection "io.styles" }
{ $subsection "checksums" }
{ $heading "Implementation" }
{ $subsection "io.streams.c" }
{ $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 ] } ;
! Copyright (C) 2004 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: io kernel namespaces prettyprint quotations
+USING: io io.styles kernel namespaces prettyprint quotations
sequences strings words xml.entities compiler.units effects
urls math math.parser combinators present fry ;
USING: html.templates html.templates.chloe
tools.test io.streams.string kernel sequences ascii boxes
namespaces xml html.components html.forms
-splitting unicode.categories furnace accessors ;
+splitting unicode.categories furnace accessors
+html.templates.chloe.compiler ;
IN: html.templates.chloe.tests
: run-template
"test12" test-template call-template
] run-template
] unit-test
+
+[
+ [
+ "test13" test-template call-template
+ ] run-template
+] [ error>> T{ unknown-chloe-tag f "this-tag-does-not-exist" } = ] must-fail-with
[ drop tag-stack get pop* ]
} cleave ;
+ERROR: unknown-chloe-tag tag ;
+
: compile-chloe-tag ( tag -- )
- ! "Unknown chloe tag: " prepend throw
dup main>> dup tags get at
- [ curry assert-depth ] [ 2drop ] ?if ;
+ [ curry assert-depth ]
+ [ unknown-chloe-tag ]
+ ?if ;
: compile-element ( element -- )
{
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:this-tag-does-not-exist />
+
+</t:chloe>
: check-header-string ( str -- str )
#! http://en.wikipedia.org/wiki/HTTP_Header_Injection
- dup "\r\n\"" intersect empty?
- [ "Header injection attack" throw ] unless ;
+ dup "\r\n\"" intersects?
+ [ "Header injection attack" throw ] when ;
: write-header ( assoc -- )
>alist sort-keys [
] { } make ;
: check-cookie-string ( string -- string' )
- dup "=;'\"\r\n" intersect empty?
- [ "Bad cookie name or value" throw ] unless ;
+ dup "=;'\"\r\n" intersects?
+ [ "Bad cookie name or value" throw ] when ;
: unparse-cookie-value ( key value -- )
{
{ $values { "path" "a pathname string" } { "quot" quotation } }
{ $description "Calls the quotation with the directory file names on the stack and with the directory set as the " { $link current-directory } ". Restores the current directory after the quotation is called." } ;
+HELP: with-directory-entries
+{ $values { "path" "a pathname string" } { "quot" quotation } }
+{ $description "Calls the quotation with the directory entries on the stack and with the directory set as the " { $link current-directory } ". Restores the current directory after the quotation is called." } ;
+
HELP: delete-file
{ $values { "path" "a pathname string" } }
{ $description "Deletes a file." }
"Directory listing:"
{ $subsection directory-entries }
{ $subsection directory-files }
+{ $subsection with-directory-entries }
{ $subsection with-directory-files } ;
ARTICLE: "io.directories.create" "Creating directories"
: directory-files ( path -- seq )
directory-entries [ name>> ] map ;
+: with-directory-entries ( path quot -- )
+ '[ "" directory-entries @ ] with-directory ; inline
+
: with-directory-files ( path quot -- )
'[ "" directory-files @ ] with-directory ; inline
PRIVATE>
-: ch>file-type ( ch -- type )
- {
- { CHAR: b [ +block-device+ ] }
- { CHAR: c [ +character-device+ ] }
- { CHAR: d [ +directory+ ] }
- { CHAR: l [ +symbolic-link+ ] }
- { CHAR: s [ +socket+ ] }
- { CHAR: p [ +fifo+ ] }
- { CHAR: - [ +regular-file+ ] }
- [ drop +unknown+ ]
- } case ;
-
-: file-type>ch ( type -- string )
- {
- { +block-device+ [ CHAR: b ] }
- { +character-device+ [ CHAR: c ] }
- { +directory+ [ CHAR: d ] }
- { +symbolic-link+ [ CHAR: l ] }
- { +socket+ [ CHAR: s ] }
- { +fifo+ [ CHAR: p ] }
- { +regular-file+ [ CHAR: - ] }
- [ drop CHAR: - ]
- } case ;
-
: UID OCT: 0004000 ; inline
: GID OCT: 0002000 ; inline
: STICKY OCT: 0001000 ; inline
: file-group-name ( path -- string )
file-group-id group-name ;
+
+: ch>file-type ( ch -- type )
+ {
+ { CHAR: b [ +block-device+ ] }
+ { CHAR: c [ +character-device+ ] }
+ { CHAR: d [ +directory+ ] }
+ { CHAR: l [ +symbolic-link+ ] }
+ { CHAR: s [ +socket+ ] }
+ { CHAR: p [ +fifo+ ] }
+ { CHAR: - [ +regular-file+ ] }
+ [ drop +unknown+ ]
+ } case ;
+
+: file-type>ch ( type -- ch )
+ {
+ { +block-device+ [ CHAR: b ] }
+ { +character-device+ [ CHAR: c ] }
+ { +directory+ [ CHAR: d ] }
+ { +symbolic-link+ [ CHAR: l ] }
+ { +socket+ [ CHAR: s ] }
+ { +fifo+ [ CHAR: p ] }
+ { +regular-file+ [ CHAR: - ] }
+ [ drop CHAR: - ]
+ } case ;
+
+<PRIVATE
+
+: file-type>executable ( directory-entry -- string )
+ name>> any-execute? "*" "" ? ;
+
+PRIVATE>
+
+: file-type>trailing ( directory-entry -- string )
+ dup type>>
+ {
+ { +directory+ [ drop "/" ] }
+ { +symbolic-link+ [ drop "@" ] }
+ { +fifo+ [ drop "|" ] }
+ { +socket+ [ drop "=" ] }
+ { +whiteout+ [ drop "%" ] }
+ { +unknown+ [ file-type>executable ] }
+ { +regular-file+ [ file-type>executable ] }
+ [ drop file-type>executable ]
+ } case ;
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
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." } ;
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 } ;
USING: help.markup help.syntax io.streams.plain io strings
-hashtables ;
+hashtables kernel quotations ;
IN: io.styles
+HELP: stream-format
+{ $values { "str" string } { "style" "a hashtable" } { "stream" "an output stream" } }
+{ $contract "Writes formatted text to the stream. If the stream does buffering, output may not be performed immediately; use " { $link stream-flush } " to force output."
+$nl
+"The " { $snippet "style" } " hashtable holds character style information. See " { $link "character-styles" } "." }
+{ $notes "Most code only works on one stream at a time and should instead use " { $link format } "; see " { $link "stdio" } "." }
+$io-error ;
+
+HELP: make-block-stream
+{ $values { "style" "a hashtable" } { "stream" "an output stream" } { "stream'" "an output stream" } }
+{ $contract "Creates an output stream which wraps " { $snippet "stream" } " and adds " { $snippet "style" } " on calls to " { $link stream-write } " and " { $link stream-format } "."
+$nl
+"Unlike " { $link make-span-stream } ", this creates a new paragraph block in the output."
+$nl
+"The " { $snippet "style" } " hashtable holds paragraph style information. See " { $link "paragraph-styles" } "." }
+{ $notes "Most code only works on one stream at a time and should instead use " { $link with-nesting } "; see " { $link "stdio" } "." }
+$io-error ;
+
+HELP: stream-write-table
+{ $values { "table-cells" "a sequence of sequences of table cells" } { "style" "a hashtable" } { "stream" "an output stream" } }
+{ $contract "Prints a table of cells produced by " { $link with-cell } "."
+$nl
+"The " { $snippet "style" } " hashtable holds table style information. See " { $link "table-styles" } "." }
+{ $notes "Most code only works on one stream at a time and should instead use " { $link tabular-output } "; see " { $link "stdio" } "." }
+$io-error ;
+
+HELP: make-cell-stream
+{ $values { "style" hashtable } { "stream" "an output stream" } { "stream'" object } }
+{ $contract "Creates an output stream which writes to a table cell object." }
+{ $notes "Most code only works on one stream at a time and should instead use " { $link with-cell } "; see " { $link "stdio" } "." }
+$io-error ;
+
+HELP: make-span-stream
+{ $values { "style" "a hashtable" } { "stream" "an output stream" } { "stream'" "an output stream" } }
+{ $contract "Creates an output stream which wraps " { $snippet "stream" } " and adds " { $snippet "style" } " on calls to " { $link stream-write } " and " { $link stream-format } "."
+$nl
+"Unlike " { $link make-block-stream } ", the stream output is inline, and not nested in a paragraph block." }
+{ $notes "Most code only works on one stream at a time and should instead use " { $link with-style } "; see " { $link "stdio" } "." }
+$io-error ;
+
+HELP: format
+{ $values { "str" string } { "style" "a hashtable" } }
+{ $description "Writes formatted text to " { $link output-stream } ". If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." }
+{ $notes "Details are in the documentation for " { $link stream-format } "." }
+$io-error ;
+
+HELP: with-nesting
+{ $values { "style" "a hashtable" } { "quot" quotation } }
+{ $description "Calls the quotation in a new dynamic scope with " { $link output-stream } " rebound to a nested paragraph stream, with formatting information applied." }
+{ $notes "Details are in the documentation for " { $link make-block-stream } "." }
+$io-error ;
+
+HELP: tabular-output
+{ $values { "style" "a hashtable" } { "quot" quotation } }
+{ $description "Calls a quotation which emits a series of equal-length table rows using " { $link with-row } ". The results are laid out in a tabular fashion on " { $link output-stream } "."
+$nl
+"The " { $snippet "style" } " hashtable holds table style information. See " { $link "table-styles" } "." }
+{ $examples
+ { $code
+ "{ { 1 2 } { 3 4 } }"
+ "H{ { table-gap { 10 10 } } } ["
+ " [ [ [ [ . ] with-cell ] each ] with-row ] each"
+ "] tabular-output"
+ }
+}
+$io-error ;
+
+HELP: with-row
+{ $values { "quot" quotation } }
+{ $description "Calls a quotation which emits a series of table cells using " { $link with-cell } ". This word can only be called inside the quotation given to " { $link tabular-output } "." }
+$io-error ;
+
+HELP: with-cell
+{ $values { "quot" quotation } }
+{ $description "Calls a quotation in a new scope with " { $link output-stream } " rebound. Output performed by the quotation is displayed in a table cell. This word can only be called inside the quotation given to " { $link with-row } "." }
+$io-error ;
+
+HELP: write-cell
+{ $values { "str" string } }
+{ $description "Outputs a table cell containing a single string. This word can only be called inside the quotation given to " { $link with-row } "." }
+$io-error ;
+
+HELP: with-style
+{ $values { "style" "a hashtable" } { "quot" quotation } }
+{ $description "Calls the quotation in a new dynamic scope where calls to " { $link write } ", " { $link format } " and other stream output words automatically inherit style settings from " { $snippet "style" } "." }
+{ $notes "Details are in the documentation for " { $link make-span-stream } "." }
+$io-error ;
+
+ARTICLE: "formatted-stream-protocol" "Formatted stream protocol"
+"The " { $vocab-link "io.styles" } " vocabulary defines a protocol for output streams that support rich text."
+{ $subsection stream-format }
+{ $subsection make-span-stream }
+{ $subsection make-block-stream }
+{ $subsection make-cell-stream }
+{ $subsection stream-write-table } ;
+
+ARTICLE: "formatted-stdout" "Formatted output on the default stream"
+"The below words perform formatted output on " { $link output-stream } "."
+$nl
+"Formatted output:"
+{ $subsection format }
+{ $subsection with-style }
+{ $subsection with-nesting }
+"Tabular output:"
+{ $subsection tabular-output }
+{ $subsection with-row }
+{ $subsection with-cell }
+{ $subsection write-cell } ;
+
ARTICLE: "character-styles" "Character styles"
"Character styles for " { $link stream-format } " and " { $link with-style } ":"
{ $subsection foreground }
"The " { $link presented } " style can be used to emit clickable objects. A utility word for outputting this style:"
{ $subsection write-object } ;
-ARTICLE: "styles" "Formatted output"
+ARTICLE: "styles" "Styled text"
"The " { $link stream-format } ", " { $link with-style } ", " { $link with-nesting } " and " { $link tabular-output } " words take a hashtable of style attributes. Output stream implementations are free to ignore style information."
$nl
"Style hashtables are keyed by symbols from the " { $vocab-link "io.styles" } " vocabulary."
{ $subsection "table-styles" }
{ $subsection "presentations" } ;
-ABOUT: "styles"
+ARTICLE: "io.styles" "Formatted output"
+"The " { $vocab-link "io.styles" } " vocabulary defines a protocol for formatted output. This is used by the prettyprinter, help system, and various developer tools. Implementations include " { $vocab-link "ui.gadgets.panes" } ", " { $vocab-link "html.streams" } ", and " { $vocab-link "io.streams.plain" } "."
+{ $subsection "formatted-stream-protocol" }
+{ $subsection "formatted-stdout" }
+{ $subsection "styles" } ;
+
+ABOUT: "io.styles"
HELP: plain
{ $description "A value for the " { $link font-style } " character style denoting plain text." } ;
HELP: standard-table-style
{ $values { "style" hashtable } }
{ $description "Outputs a table style where cells are separated by 5-pixel gaps and framed by a light gray border. This style can be passed to " { $link tabular-output } "." } ;
+
+ARTICLE: "io.streams.plain" "Plain writer streams"
+"Plain writer streams wrap an underlying stream and provide a default implementation of "
+{ $link stream-nl } ", "
+{ $link stream-format } ", "
+{ $link make-span-stream } ", "
+{ $link make-block-stream } " and "
+{ $link make-cell-stream } "."
+{ $subsection plain-writer } ;
\ No newline at end of file
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: hashtables io colors summary make accessors splitting
-kernel ;
+USING: hashtables io io.streams.plain io.streams.string
+colors summary make accessors splitting math.order
+kernel namespaces assocs destructors strings sequences ;
IN: io.styles
+GENERIC: stream-format ( str style stream -- )
+GENERIC: make-span-stream ( style stream -- stream' )
+GENERIC: make-block-stream ( style stream -- stream' )
+GENERIC: make-cell-stream ( style stream -- stream' )
+GENERIC: stream-write-table ( table-cells style stream -- )
+
+: format ( str style -- ) output-stream get stream-format ;
+
+: tabular-output ( style quot -- )
+ swap [ { } make ] dip output-stream get stream-write-table ; inline
+
+: with-row ( quot -- )
+ { } make , ; inline
+
+: with-cell ( quot -- )
+ H{ } output-stream get make-cell-stream
+ [ swap with-output-stream ] keep , ; inline
+
+: write-cell ( str -- )
+ [ write ] with-cell ; inline
+
+: with-style ( style quot -- )
+ swap dup assoc-empty? [
+ drop call
+ ] [
+ output-stream get make-span-stream swap with-output-stream
+ ] if ; inline
+
+: with-nesting ( style quot -- )
+ [ output-stream get make-block-stream ] dip
+ with-output-stream ; inline
+
+TUPLE: filter-writer stream ;
+
+M: filter-writer stream-format
+ stream>> stream-format ;
+
+M: filter-writer stream-write
+ stream>> stream-write ;
+
+M: filter-writer stream-write1
+ stream>> stream-write1 ;
+
+M: filter-writer make-span-stream
+ stream>> make-span-stream ;
+
+M: filter-writer make-block-stream
+ stream>> make-block-stream ;
+
+M: filter-writer make-cell-stream
+ stream>> make-cell-stream ;
+
+M: filter-writer stream-flush
+ stream>> stream-flush ;
+
+M: filter-writer stream-nl
+ stream>> stream-nl ;
+
+M: filter-writer stream-write-table
+ stream>> stream-write-table ;
+
+M: filter-writer dispose
+ stream>> dispose ;
+
+TUPLE: ignore-close-stream < filter-writer ;
+
+M: ignore-close-stream dispose drop ;
+
+C: <ignore-close-stream> ignore-close-stream
+
+TUPLE: style-stream < filter-writer style ;
+
+: do-nested-style ( style style-stream -- style stream )
+ [ style>> swap assoc-union ] [ stream>> ] bi ; inline
+
+C: <style-stream> style-stream
+
+M: style-stream stream-format
+ do-nested-style stream-format ;
+
+M: style-stream stream-write
+ [ style>> ] [ stream>> ] bi stream-format ;
+
+M: style-stream stream-write1
+ [ 1string ] dip stream-write ;
+
+M: style-stream make-span-stream
+ do-nested-style make-span-stream ;
+
+M: style-stream make-block-stream
+ [ do-nested-style make-block-stream ] [ style>> ] bi
+ <style-stream> ;
+
+M: style-stream make-cell-stream
+ [ do-nested-style make-cell-stream ] [ style>> ] bi
+ <style-stream> ;
+
+M: style-stream stream-write-table
+ [ [ [ stream>> ] map ] map ] [ ] [ stream>> ] tri*
+ stream-write-table ;
+
+M: plain-writer stream-format
+ nip stream-write ;
+
+M: plain-writer make-span-stream
+ swap <style-stream> <ignore-close-stream> ;
+
+M: plain-writer make-block-stream
+ nip <ignore-close-stream> ;
+
+: format-column ( seq ? -- seq )
+ [
+ [ 0 [ length max ] reduce ] keep
+ swap [ CHAR: \s pad-right ] curry map
+ ] unless ;
+
+: map-last ( seq quot -- seq )
+ [ dup length <reversed> ] dip [ 0 = ] prepose 2map ; inline
+
+: format-table ( table -- seq )
+ flip [ format-column ] map-last
+ flip [ " " join ] map ;
+
+M: plain-writer stream-write-table
+ [ drop format-table [ print ] each ] with-output-stream* ;
+
+M: plain-writer make-cell-stream 2drop <string-writer> ;
+
+! Font styles
SYMBOL: plain
SYMBOL: bold
SYMBOL: italic
USING: arrays generic hashtables io kernel math assocs
namespaces make sequences strings io.styles vectors words
prettyprint.config splitting classes continuations
-io.streams.nested accessors sets ;
+accessors sets ;
IN: prettyprint.sections
! State
dup
[ nfa-table>> final-states>> keys ]
[ dfa-table>> transitions>> states ] bi
- [ intersect empty? not ] with filter
+ [ intersects? ] with filter
swap dfa-table>> final-states>>
[ conjoin ] curry each ;
: validate-address ( string -- string' )
#! Make sure we send funky stuff to the server by accident.
- dup "\r\n>" intersect empty?
- [ bad-email-address ] unless ;
+ dup "\r\n>" intersects?
+ [ bad-email-address ] when ;
: mail-from ( fromaddr -- )
validate-address
ERROR: invalid-header-string string ;
: validate-header ( string -- string' )
- dup "\r\n" intersect empty?
- [ invalid-header-string ] unless ;
+ dup "\r\n" intersects?
+ [ invalid-header-string ] when ;
: write-header ( key value -- )
[ validate-header write ]
HELP: compare-slots
{ $values
- { "sort-specs" "a sequence of accessor/comparator pairs" }
+ { "sort-specs" "a sequence of accessors ending with a comparator" }
{ "<=>" { $link +lt+ } " " { $link +eq+ } " or " { $link +gt+ } }
}
{ $description "Compares two objects using a chain of intrinsic linear orders such that if two objects are " { $link +eq+ } ", then the next comparator is tried. The comparators are slot-name/comparator pairs." } ;
HELP: sort-by-slots
{ $values
- { "seq" sequence } { "sort-specs" "a sequence of accessor/comparator pairs" }
+ { "seq" sequence } { "sort-specs" "a sequence of accessors ending with a comparator" }
{ "seq'" sequence }
}
-{ $description "Sorts a sequence of tuples by the sort-specs in " { $snippet "sort-spec" } ". A sort-spec is a slot accessor and a comparator." }
+{ $description "Sorts a sequence of tuples by the sort-specs in " { $snippet "sort-spec" } ". A sort-spec is a sequence of slot accessors ending in a comparator." }
{ $examples
"Sort by slot c, then b descending:"
{ $example
}
} ;
+HELP: split-by-slots
+{ $values
+ { "accessor-seqs" "a sequence of sequences of tuple accessors" }
+ { "quot" quotation }
+}
+{ $description "Splits a sequence of tuples into a sequence of slices of tuples that have the same values in all slots in the accessor sequence. This word is only useful for splitting a sorted sequence, but is more efficient than partitioning in such a case." } ;
+
ARTICLE: "sorting.slots" "Sorting by slots"
"The " { $vocab-link "sorting.slots" } " vocabulary can sort tuples by slot in ascending or descending order, using subsequent slots as tie-breakers." $nl
"Comparing two objects by a sequence of slots:"
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors math.order sorting.slots tools.test
-sorting.human ;
+sorting.human arrays sequences kernel assocs multiline ;
IN: sorting.literals.tests
-TUPLE: sort-test a b c ;
+TUPLE: sort-test a b c tuple2 ;
+
+TUPLE: tuple2 d ;
[
{
] unit-test
[
- { }
+ {
+ {
+ T{ sort-test { a 1 } { b 1 } { c 10 } }
+ T{ sort-test { a 1 } { b 1 } { c 11 } }
+ }
+ { T{ sort-test { a 1 } { b 3 } { c 9 } } }
+ {
+ T{ sort-test { a 2 } { b 5 } { c 3 } }
+ T{ sort-test { a 2 } { b 5 } { c 2 } }
+ }
+ }
] [
- { }
- { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by-slots
+ {
+ T{ sort-test f 1 3 9 }
+ T{ sort-test f 1 1 10 }
+ T{ sort-test f 1 1 11 }
+ T{ sort-test f 2 5 3 }
+ T{ sort-test f 2 5 2 }
+ }
+ { { a>> human-<=> } { b>> <=> } } [ sort-by-slots ] keep
+ [ but-last-slice ] map split-by-slots [ >array ] map
+] unit-test
+
+: split-test ( seq -- seq' )
+ { { a>> } { b>> } } split-by-slots ;
+
+[ split-test ] must-infer
+
+[ { } ]
+[ { } { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by-slots ] unit-test
+
+[
+ {
+ T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 1 } } } }
+ T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 2 } } } }
+ T{ sort-test { a 5 } { tuple2 T{ tuple2 { d 3 } } } }
+ T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 3 } } } }
+ T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 3 } } } }
+ T{ sort-test { a 5 } { tuple2 T{ tuple2 { d 4 } } } }
+ }
+] [
+ {
+ T{ sort-test f 6 f f T{ tuple2 f 1 } }
+ T{ sort-test f 5 f f T{ tuple2 f 4 } }
+ T{ sort-test f 6 f f T{ tuple2 f 3 } }
+ T{ sort-test f 6 f f T{ tuple2 f 3 } }
+ T{ sort-test f 5 f f T{ tuple2 f 3 } }
+ T{ sort-test f 6 f f T{ tuple2 f 2 } }
+ } { { tuple2>> d>> <=> } { a>> <=> } } sort-by-slots
+] unit-test
+
+[
+ {
+ {
+ T{ sort-test
+ { a 6 }
+ { tuple2 T{ tuple2 { d 1 } } }
+ }
+ }
+ {
+ T{ sort-test
+ { a 6 }
+ { tuple2 T{ tuple2 { d 2 } } }
+ }
+ }
+ {
+ T{ sort-test
+ { a 5 }
+ { tuple2 T{ tuple2 { d 3 } } }
+ }
+ }
+ {
+ T{ sort-test
+ { a 6 }
+ { tuple2 T{ tuple2 { d 3 } } }
+ }
+ T{ sort-test
+ { a 6 }
+ { tuple2 T{ tuple2 { d 3 } } }
+ }
+ }
+ {
+ T{ sort-test
+ { a 5 }
+ { tuple2 T{ tuple2 { d 4 } } }
+ }
+ }
+ }
+] [
+ {
+ T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 1 } } } }
+ T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 2 } } } }
+ T{ sort-test { a 5 } { tuple2 T{ tuple2 { d 3 } } } }
+ T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 3 } } } }
+ T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 3 } } } }
+ T{ sort-test { a 5 } { tuple2 T{ tuple2 { d 4 } } } }
+ } { { tuple2>> d>> } { a>> } } split-by-slots [ >array ] map
] unit-test
! Copyright (C) 2009 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.short-circuit fry kernel macros math.order
-sequences words sorting ;
+sequences words sorting sequences.deep assocs splitting.monotonic
+math ;
IN: sorting.slots
<PRIVATE
-: slot-comparator ( accessor comparator -- quot )
- '[ [ _ execute ] bi@ _ execute dup +eq+ eq? [ drop f ] when ] ;
+: slot-comparator ( seq -- quot )
+ [
+ but-last-slice
+ [ '[ [ _ execute ] bi@ ] ] map concat
+ ] [
+ peek
+ '[ @ _ execute dup +eq+ eq? [ drop f ] when ]
+ ] bi ;
PRIVATE>
MACRO: compare-slots ( sort-specs -- <=> )
- #! sort-spec: { accessor comparator }
- [ first2 slot-comparator ] map '[ _ 2|| +eq+ or ] ;
+ #! sort-spec: { accessors comparator }
+ [ slot-comparator ] map '[ _ 2|| +eq+ or ] ;
: sort-by-slots ( seq sort-specs -- seq' )
'[ _ compare-slots ] sort ;
+
+MACRO: split-by-slots ( accessor-seqs -- quot )
+ [ [ '[ [ _ execute ] bi@ ] ] map concat [ = ] compose ] map
+ '[ [ _ 2&& ] slice monotonic-slice ] ;
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." } ;
-! Copyright (C) 2006, 2008 Slava Pestov.
+! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math namespaces make sequences words io
-io.streams.string math.vectors ui.gadgets columns accessors
+io.styles math.vectors ui.gadgets columns accessors
math.geometry.rect locals fry ;
IN: ui.gadgets.grids
-! 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
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
ui.gadgets.menus ui.clipboards ui.gestures ui.traverse ui.render
hashtables io kernel namespaces sequences io.styles strings
quotations math opengl combinators math.vectors sorting
-splitting io.streams.nested assocs ui.gadgets.presentations
+splitting assocs ui.gadgets.presentations
ui.gadgets.slots ui.gadgets.grids ui.gadgets.grid-lines
classes.tuple models continuations destructors accessors
math.geometry.rect fry ;
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
[ 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 ;
ascii io assocs strings math namespaces make sorting combinators\r
math.order arrays unicode.normalize unicode.data locals\r
unicode.syntax macros sequences.deep words unicode.breaks\r
-quotations ;\r
+quotations combinators.short-circuit ;\r
IN: unicode.collation\r
\r
<PRIVATE\r
building get empty? [ 0 ] [ building get peek peek ] if ;\r
\r
: blocked? ( char -- ? )\r
- combining-class [\r
- last combining-class =\r
- ] [ last combining-class ] if* ;\r
+ combining-class dup { 0 f } member?\r
+ [ drop last non-starter? ]\r
+ [ last combining-class = ] if ;\r
\r
: possible-bases ( -- slice-of-building )\r
- building get dup [ first combining-class not ] find-last\r
+ building get dup [ first non-starter? not ] find-last\r
drop [ 0 ] unless* tail-slice ;\r
\r
:: ?combine ( char slice i -- ? )\r
: v-one-line ( str -- str )
v-required
- dup "\r\n" intersect empty?
- [ "must be a single line" throw ] unless ;
+ dup "\r\n" intersects?
+ [ "must be a single line" throw ] when ;
: v-one-word ( str -- str )
v-required
{ $notes "Most code only works on one stream at a time and should instead use " { $link nl } "; see " { $link "stdio" } "." }
$io-error ;
-HELP: stream-format
-{ $values { "str" string } { "style" "a hashtable" } { "stream" "an output stream" } }
-{ $contract "Writes formatted text to the stream. If the stream does buffering, output may not be performed immediately; use " { $link stream-flush } " to force output."
-$nl
-"The " { $snippet "style" } " hashtable holds character style information. See " { $link "character-styles" } "." }
-{ $notes "Most code only works on one stream at a time and should instead use " { $link format } "; see " { $link "stdio" } "." }
-$io-error ;
-
-HELP: make-block-stream
-{ $values { "style" "a hashtable" } { "stream" "an output stream" } { "stream'" "an output stream" } }
-{ $contract "Creates an output stream which wraps " { $snippet "stream" } " and adds " { $snippet "style" } " on calls to " { $link stream-write } " and " { $link stream-format } "."
-$nl
-"Unlike " { $link make-span-stream } ", this creates a new paragraph block in the output."
-$nl
-"The " { $snippet "style" } " hashtable holds paragraph style information. See " { $link "paragraph-styles" } "." }
-{ $notes "Most code only works on one stream at a time and should instead use " { $link with-nesting } "; see " { $link "stdio" } "." }
-$io-error ;
-
-HELP: stream-write-table
-{ $values { "table-cells" "a sequence of sequences of table cells" } { "style" "a hashtable" } { "stream" "an output stream" } }
-{ $contract "Prints a table of cells produced by " { $link with-cell } "."
-$nl
-"The " { $snippet "style" } " hashtable holds table style information. See " { $link "table-styles" } "." }
-{ $notes "Most code only works on one stream at a time and should instead use " { $link tabular-output } "; see " { $link "stdio" } "." }
-$io-error ;
-
-HELP: make-cell-stream
-{ $values { "style" hashtable } { "stream" "an output stream" } { "stream'" object } }
-{ $contract "Creates an output stream which writes to a table cell object." }
-{ $notes "Most code only works on one stream at a time and should instead use " { $link with-cell } "; see " { $link "stdio" } "." }
-$io-error ;
-
-HELP: make-span-stream
-{ $values { "style" "a hashtable" } { "stream" "an output stream" } { "stream'" "an output stream" } }
-{ $contract "Creates an output stream which wraps " { $snippet "stream" } " and adds " { $snippet "style" } " on calls to " { $link stream-write } " and " { $link stream-format } "."
-$nl
-"Unlike " { $link make-block-stream } ", the stream output is inline, and not nested in a paragraph block." }
-{ $notes "Most code only works on one stream at a time and should instead use " { $link with-style } "; see " { $link "stdio" } "." }
-$io-error ;
HELP: stream-print
{ $values { "str" string } { "stream" "an output stream" } }
{ $description "Writes a line terminator to " { $link output-stream } ". If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." }
$io-error ;
-HELP: format
-{ $values { "str" string } { "style" "a hashtable" } }
-{ $description "Writes formatted text to " { $link output-stream } ". If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." }
-{ $notes "Details are in the documentation for " { $link stream-format } "." }
-$io-error ;
-
-HELP: with-nesting
-{ $values { "style" "a hashtable" } { "quot" quotation } }
-{ $description "Calls the quotation in a new dynamic scope with " { $link output-stream } " rebound to a nested paragraph stream, with formatting information applied." }
-{ $notes "Details are in the documentation for " { $link make-block-stream } "." }
-$io-error ;
-
-HELP: tabular-output
-{ $values { "style" "a hashtable" } { "quot" quotation } }
-{ $description "Calls a quotation which emits a series of equal-length table rows using " { $link with-row } ". The results are laid out in a tabular fashion on " { $link output-stream } "."
-$nl
-"The " { $snippet "style" } " hashtable holds table style information. See " { $link "table-styles" } "." }
-{ $examples
- { $code
- "{ { 1 2 } { 3 4 } }"
- "H{ { table-gap { 10 10 } } } ["
- " [ [ [ [ . ] with-cell ] each ] with-row ] each"
- "] tabular-output"
- }
-}
-$io-error ;
-
-HELP: with-row
-{ $values { "quot" quotation } }
-{ $description "Calls a quotation which emits a series of table cells using " { $link with-cell } ". This word can only be called inside the quotation given to " { $link tabular-output } "." }
-$io-error ;
-
-HELP: with-cell
-{ $values { "quot" quotation } }
-{ $description "Calls a quotation in a new scope with " { $link output-stream } " rebound. Output performed by the quotation is displayed in a table cell. This word can only be called inside the quotation given to " { $link with-row } "." }
-$io-error ;
-
-HELP: write-cell
-{ $values { "str" string } }
-{ $description "Outputs a table cell containing a single string. This word can only be called inside the quotation given to " { $link with-row } "." }
-$io-error ;
-
-HELP: with-style
-{ $values { "style" "a hashtable" } { "quot" quotation } }
-{ $description "Calls the quotation in a new dynamic scope where calls to " { $link write } ", " { $link format } " and other stream output words automatically inherit style settings from " { $snippet "style" } "." }
-{ $notes "Details are in the documentation for " { $link make-span-stream } "." }
-$io-error ;
-
HELP: print
{ $values { "string" string } }
{ $description "Writes a newline-terminated string to " { $link output-stream } "." }
{ $subsection stream-flush }
{ $subsection stream-write1 }
{ $subsection stream-write }
-{ $subsection stream-format }
{ $subsection stream-nl }
-{ $subsection make-span-stream }
-{ $subsection make-block-stream }
-{ $subsection make-cell-stream }
-{ $subsection stream-write-table }
{ $see-also "io.timeouts" } ;
ARTICLE: "stdio" "Default input and output streams"
{ $subsection print }
{ $subsection nl }
{ $subsection bl }
-"Formatted output:"
-{ $subsection format }
-{ $subsection with-style }
-{ $subsection with-nesting }
-"Tabular output:"
-{ $subsection tabular-output }
-{ $subsection with-row }
-{ $subsection with-cell }
-{ $subsection write-cell }
"A pair of combinators for rebinding the " { $link output-stream } " variable:"
{ $subsection with-output-stream }
{ $subsection with-output-stream* }
-! Copyright (C) 2003, 2007 Slava Pestov.
+! Copyright (C) 2003, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: hashtables generic kernel math namespaces make sequences
continuations destructors assocs ;
GENERIC: stream-write ( str stream -- )
GENERIC: stream-flush ( stream -- )
GENERIC: stream-nl ( stream -- )
-GENERIC: stream-format ( str style stream -- )
-GENERIC: make-span-stream ( style stream -- stream' )
-GENERIC: make-block-stream ( style stream -- stream' )
-GENERIC: make-cell-stream ( style stream -- stream' )
-GENERIC: stream-write-table ( table-cells style stream -- )
: stream-print ( str stream -- )
[ stream-write ] keep stream-nl ;
: flush ( -- ) output-stream get stream-flush ;
: nl ( -- ) output-stream get stream-nl ;
-: format ( str style -- ) output-stream get stream-format ;
: with-input-stream* ( stream quot -- )
input-stream swap with-variable ; inline
[ [ drop dispose dispose ] 3curry ] 3bi
[ ] cleanup ; inline
-: tabular-output ( style quot -- )
- swap [ { } make ] dip output-stream get stream-write-table ; inline
-
-: with-row ( quot -- )
- { } make , ; inline
-
-: with-cell ( quot -- )
- H{ } output-stream get make-cell-stream
- [ swap with-output-stream ] keep , ; inline
-
-: write-cell ( str -- )
- [ write ] with-cell ; inline
-
-: with-style ( style quot -- )
- swap dup assoc-empty? [
- drop call
- ] [
- output-stream get make-span-stream swap with-output-stream
- ] if ; inline
-
-: with-nesting ( style quot -- )
- [ output-stream get make-block-stream ] dip
- with-output-stream ; inline
-
: print ( string -- ) output-stream get stream-print ;
: bl ( -- ) " " write ;
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: io io.streams.nested help.markup help.syntax ;
-
+++ /dev/null
-! Copyright (C) 2006, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays generic assocs kernel namespaces strings
-quotations io continuations destructors accessors sequences ;
-IN: io.streams.nested
-
-TUPLE: filter-writer stream ;
-
-M: filter-writer stream-format
- stream>> stream-format ;
-
-M: filter-writer stream-write
- stream>> stream-write ;
-
-M: filter-writer stream-write1
- stream>> stream-write1 ;
-
-M: filter-writer make-span-stream
- stream>> make-span-stream ;
-
-M: filter-writer make-block-stream
- stream>> make-block-stream ;
-
-M: filter-writer make-cell-stream
- stream>> make-cell-stream ;
-
-M: filter-writer stream-flush
- stream>> stream-flush ;
-
-M: filter-writer stream-nl
- stream>> stream-nl ;
-
-M: filter-writer stream-write-table
- stream>> stream-write-table ;
-
-M: filter-writer dispose
- stream>> dispose ;
-
-TUPLE: ignore-close-stream < filter-writer ;
-
-M: ignore-close-stream dispose drop ;
-
-C: <ignore-close-stream> ignore-close-stream
-
-TUPLE: style-stream < filter-writer style ;
-
-: do-nested-style ( style style-stream -- style stream )
- [ style>> swap assoc-union ] [ stream>> ] bi ; inline
-
-C: <style-stream> style-stream
-
-M: style-stream stream-format
- do-nested-style stream-format ;
-
-M: style-stream stream-write
- [ style>> ] [ stream>> ] bi stream-format ;
-
-M: style-stream stream-write1
- [ 1string ] dip stream-write ;
-
-M: style-stream make-span-stream
- do-nested-style make-span-stream ;
-
-M: style-stream make-block-stream
- [ do-nested-style make-block-stream ] [ style>> ] bi
- <style-stream> ;
-
-M: style-stream make-cell-stream
- [ do-nested-style make-cell-stream ] [ style>> ] bi
- <style-stream> ;
-
-M: style-stream stream-write-table
- [ [ [ stream>> ] map ] map ] [ ] [ stream>> ] tri*
- stream-write-table ;
+++ /dev/null
-Support for with-stream-style implementation
USING: help.markup help.syntax io ;
IN: io.streams.plain
-ARTICLE: "io.streams.plain" "Plain writer streams"
-"Plain writer streams wrap an underlying stream and provide a default implementation of "
-{ $link stream-nl } ", "
-{ $link stream-format } ", "
-{ $link make-span-stream } ", "
-{ $link make-block-stream } " and "
-{ $link make-cell-stream } "."
-{ $subsection plain-writer } ;
-
ABOUT: "io.streams.plain"
HELP: plain-writer
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel io io.streams.nested ;
+USING: kernel io ;
IN: io.streams.plain
MIXIN: plain-writer
M: plain-writer stream-nl
- CHAR: \n swap stream-write1 ;
-
-M: plain-writer stream-format
- nip stream-write ;
-
-M: plain-writer make-span-stream
- swap <style-stream> <ignore-close-stream> ;
-
-M: plain-writer make-block-stream
- nip <ignore-close-stream> ;
+ CHAR: \n swap stream-write1 ;
\ No newline at end of file
-! Copyright (C) 2003, 2008 Slava Pestov.
+! Copyright (C) 2003, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors io kernel math namespaces sequences sbufs
strings generic splitting continuations destructors
M: null-encoding decode-char drop stream-read1 ;
-: format-column ( seq ? -- seq )
- [
- [ 0 [ length max ] reduce ] keep
- swap [ CHAR: \s pad-right ] curry map
- ] unless ;
-
-: map-last ( seq quot -- seq )
- [ dup length <reversed> ] dip [ 0 = ] prepose 2map ; inline
-
PRIVATE>
-: format-table ( table -- seq )
- flip [ format-column ] map-last
- flip [ " " join ] map ;
-
M: growable dispose drop ;
M: growable stream-write1 push ;
[ <string-reader> ] dip with-input-stream ; inline
INSTANCE: growable plain-writer
-
-M: plain-writer stream-write-table
- [ drop format-table [ print ] each ] with-output-stream* ;
-
-M: plain-writer make-cell-stream 2drop <string-writer> ;
{ $see POSTPONE: SYMBOL: }
"The key factor in the definition of " { $link POSTPONE: SYMBOL: } " is " { $link CREATE } ", which reads a token from the input and creates a word with that name. This word is then passed to " { $link define-symbol } "."
{ $subsection CREATE }
+{ $subsection CREATE-WORD }
"Colon definitions are defined in a more elaborate way:"
{ $subsection POSTPONE: : }
"The " { $link POSTPONE: : } " word first calls " { $link CREATE } ", and then reads input until reaching " { $link POSTPONE: ; } " using a utility word:"
"V{ 1 2 3 }"
} } ;
+HELP: iota
+{ $values { "n" integer } { "iota" iota } }
+{ $description "Creates an immutable virtual sequence containing the integers from 0 to " { $snippet "n-1" } "." }
+{ $examples
+ { $example
+ "USING: math sequences prettyprint ;"
+ "3 iota [ sq ] map ."
+ "{ 0 1 4 }"
+ }
+} ;
+
ARTICLE: "sequences-unsafe" "Unsafe sequence operations"
"The " { $link nth-unsafe } " and " { $link set-nth-unsafe } " sequence protocol bypasses bounds checks for increased performance."
$nl
{ 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
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
+
+<PRIVATE
+
+M: iota length n>> ;
+M: iota nth-unsafe drop ;
+
+INSTANCE: iota immutable-sequence
+
: first-unsafe ( seq -- first )
0 swap nth-unsafe ; inline
{ $subsection diff }
{ $subsection intersect }
{ $subsection union }
+"Set-theoretic predicates:"
+{ $subsection intersects? }
{ $subsection subset? }
{ $subsection set= }
"A word used to implement the above:"
{ diff intersect union } related-words
+HELP: intersects?
+{ $values { "seq1" sequence } { "seq2" sequence } { "?" "a boolean" } }
+{ $description "Tests if " { $snippet "seq1" } " and " { $snippet "seq2" } " have any elements in common." }
+{ $notes "If one of the sequences is empty, the result is always " { $link f } "." } ;
+
HELP: subset?
{ $values { "seq1" sequence } { "seq2" sequence } { "?" "a boolean" } }
-{ $description "Tests if every element of " { $snippet "seq1" } " is contained in " { $snippet "seq2" } "." } ;
+{ $description "Tests if every element of " { $snippet "seq1" } " is contained in " { $snippet "seq2" } "." }
+{ $notes "If " { $snippet "seq1" } " is empty, the result is always " { $link t } "." } ;
HELP: set=
{ $values { "seq1" sequence } { "seq2" sequence } { "?" "a boolean" } }
[ V{ 1 2 3 } ]
[ 3 V{ 1 3 2 } clone [ adjoin ] keep ] unit-test
+
+[ t ] [ { 1 2 } { 1 3 } intersects? ] unit-test
+
+[ f ] [ { 4 2 } { 1 3 } intersects? ] unit-test
+
+[ f ] [ { } { 1 } intersects? ] unit-test
+
+[ f ] [ { 1 } { } intersects? ] unit-test
-! Copyright (C) 2008 Slava Pestov, Doug Coleman.
+! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs hashtables kernel sequences vectors ;
IN: sets
: all-unique? ( seq -- ? )
dup length <hashtable> [ (all-unique?) ] curry all? ;
+<PRIVATE
+
+: tester ( seq -- quot ) unique [ key? ] curry ; inline
+
+PRIVATE>
+
: intersect ( seq1 seq2 -- newseq )
- unique [ key? ] curry filter ;
+ tester filter ;
+
+: intersects? ( seq1 seq2 -- ? )
+ tester contains? ;
: diff ( seq1 seq2 -- newseq )
- unique [ key? not ] curry filter ;
+ tester [ not ] compose filter ;
: union ( seq1 seq2 -- newseq )
append prune ;
: subset? ( seq1 seq2 -- ? )
- unique [ key? ] curry all? ;
+ tester all? ;
: set= ( seq1 seq2 -- ? )
[ unique ] bi@ = ;
: split ( seq separators -- pieces ) [ split, ] { } make ;
: string-lines ( str -- seq )
- dup "\r\n" intersect empty? [
- 1array
- ] [
+ dup "\r\n" intersects? [
"\n" split [
but-last-slice [
"\r" ?tail drop "\r" split
] map
] keep peek "\r" split suffix concat
+ ] [
+ 1array
] if ;
SYMBOL: load-help?
-ERROR: circular-dependency name ;
-
<PRIVATE
: load-source ( vocab -- )
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: 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 ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
--- /dev/null
+
+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
+
\ No newline at end of file
-! 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
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 -- ) -- )
--- /dev/null
+Doug Coleman
--- /dev/null
+! 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
--- /dev/null
+! 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 ;
--- /dev/null
+! 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 ) ;
--- /dev/null
+unportable
--- /dev/null
+ncurses binding
--- /dev/null
+unportable
Jose Antonio Ortega Ruiz
-Eduardo Cavazos
--- /dev/null
+Jose Antonio Ortega Ruiz
\ No newline at end of file
--- /dev/null
+! 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
--- /dev/null
+! 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) ;
! 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 quotations prettyprint
-sequences sets sorting source-files strings summary tools.crossref
-tools.vocabs tools.vocabs.browser vectors vocabs 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
: 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
-
-M: sequence fuel-pprint
- "(" write [ " " write ] [ fuel-pprint ] interleave ")" write ; 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
-
-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 ;
: 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
: 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 ;
[ 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-find-articles ( title -- seq )
- [ [ article-title ] dip = ] curry fuel-articles-seq swap filter ;
-
-MEMO: fuel-find-article ( title -- article/f )
- fuel-find-articles dup empty? [ drop f ] [ first ] if ;
-
-MEMO: fuel-article-title ( name -- title/f )
- articles get at [ article-title ] [ f ] if* ;
-
-: fuel-get-article ( name -- )
- article 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 )
- \ 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-get-article ( name -- ) article fuel-eval-set-result ;
-: (fuel-index) ( seq -- seq )
- [ [ >link name>> ] [ article-title ] bi 2array \ $subsection prefix ] map ;
+MEMO: fuel-get-article-title ( name -- )
+ articles get at [ article-title ] [ f ] if* fuel-eval-set-result ;
-: fuel-index ( quot: ( -- seq ) -- )
- call (fuel-index) fuel-eval-set-result ; inline
+: fuel-word-help ( name -- ) (fuel-word-help) fuel-eval-set-result ;
-MEMO: (fuel-get-vocabs/author) ( author -- element )
- [ "Vocabularies by " prepend \ $heading swap 2array ]
- [ authored fuel-vocab-list ] bi 2array ;
+: fuel-word-see ( name -- ) (fuel-word-see) fuel-eval-set-result ;
-: fuel-get-vocabs/author ( author -- )
- (fuel-get-vocabs/author) fuel-eval-set-result ;
+: fuel-word-def ( name -- ) (fuel-word-def) fuel-eval-set-result ;
+
+: fuel-vocab-help ( name -- ) (fuel-vocab-help) 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/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 dup [ scaffold-vocab ] dip
+ dup require vocab-source-path (normalize-path) fuel-eval-set-result ;
-! -run=fuel support
+: fuel-scaffold-help ( name devname -- )
+ developer-name set
+ dup require dup scaffold-help vocab-docs-path
+ (normalize-path) fuel-eval-set-result ;
-: fuel-startup ( -- ) "listener" run-file ; inline
+: fuel-scaffold-get-root ( name -- ) find-vocab-root fuel-eval-set-result ;
-MAIN: fuel-startup
--- /dev/null
+Jose Antonio Ortega Ruiz
\ No newline at end of file
--- /dev/null
+! 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
--- /dev/null
+! 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) ( name -- elem )
+ 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-word-def) ( name -- str )
+ fuel-find-word [ [ def>> pprint ] with-string-writer ] [ f ] if* ; 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 ;
--- /dev/null
+Jose Antonio Ortega Ruiz
\ No newline at end of file
--- /dev/null
+! 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
--- /dev/null
+! 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 ;
--- /dev/null
+
+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 ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
HELP: define-inverse
{ $values { "word" "a word" } { "quot" "the inverse" } }
{ $description "Defines the inverse of a given word, taking no arguments from the quotation, only the stack." }
-{ $see-also define-pop-inverse } ;
+{ $see-also define-dual define-involution define-pop-inverse } ;
+
+HELP: define-dual
+{ $values { "word1" "a word" } { "word2" "a word" } }
+{ $description "Defines the inverse of each word as being the other one." }
+{ $see-also define-inverse define-involution } ;
+
+HELP: define-involution
+{ $values { "word" "a word" } }
+{ $description "Defines a word as being its own inverse." }
+{ $see-also define-dual define-inverse } ;
HELP: define-pop-inverse
{ $values { "word" "a word" } { "n" "number of arguments to be taken from the inverted quotation" } { "quot" "a quotation" } }
[ { 3 } ] [ { 1 2 3 } [ { 1 2 } prepend ] undo ] unit-test
[ { 1 2 3 } [ { 1 2 } append ] undo ] must-fail
[ { 1 2 3 } [ { 2 3 } prepend ] undo ] must-fail
+
+[ [ sq ] ] [ [ sqrt ] [undo] ] unit-test
+[ [ sqrt ] ] [ [ sq ] [undo] ] unit-test
+[ [ not ] ] [ [ not ] [undo] ] unit-test
+[ { 3 2 1 } ] [ { 1 2 3 } [ reverse ] undo ] unit-test
: define-inverse ( word quot -- ) "inverse" set-word-prop ;
+: define-dual ( word1 word2 -- )
+ 2dup swap [ 1quotation define-inverse ] 2bi@ ;
+
+: define-involution ( word -- ) dup 1quotation define-inverse ;
+
: define-math-inverse ( word quot1 quot2 -- )
pick 1quotation 3array "math-inverse" set-word-prop ;
! Inverse of selected words
-\ swap [ swap ] define-inverse
+\ swap define-involution
\ dup [ [ =/fail ] keep ] define-inverse
\ 2dup [ over =/fail over =/fail ] define-inverse
\ 3dup [ pick =/fail pick =/fail pick =/fail ] define-inverse
\ pick [ [ pick ] dip =/fail ] define-inverse
\ tuck [ swapd [ =/fail ] keep ] define-inverse
-\ not [ not ] define-inverse
+\ not define-involution
\ >boolean [ { t f } memq? assure ] define-inverse
-\ tuple>array [ >tuple ] define-inverse
-\ >tuple [ tuple>array ] define-inverse
-\ reverse [ reverse ] define-inverse
+\ tuple>array \ >tuple define-dual
+\ reverse define-involution
\ undo 1 [ [ call ] curry ] define-pop-inverse
\ map 1 [ [undo] [ over sequence? assure map ] curry ] define-pop-inverse
-\ exp [ log ] define-inverse
-\ log [ exp ] define-inverse
-\ not [ not ] define-inverse
-\ sq [ sqrt ] define-inverse
-\ sqrt [ sq ] define-inverse
+\ exp \ log define-dual
+\ sq \ sqrt define-dual
ERROR: missing-literal ;
\ first3 [ 3array ] define-inverse
\ first4 [ 4array ] define-inverse
-\ prefix [ unclip ] define-inverse
-\ unclip [ prefix ] define-inverse
+\ prefix \ unclip define-dual
\ suffix [ dup but-last swap peek ] define-inverse
\ append 1 [ [ ?tail assure ] curry ] define-pop-inverse
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: furnace.actions furnace.redirection
+USING: furnace furnace.actions furnace.redirection
http.server.dispatchers html.forms validators urls accessors
math ;
IN: webapps.calculator
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+<html>
<head> <title>Calculator</title> </head>
<body>
</t:form>
</body>
+</html>
</t:chloe>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
+<html>
<body>
<h1><t:label t:name="counter" /></h1>
<t:button t:action="$counter-app/inc">++</t:button>
<t:button t:action="$counter-app/dec">--</t:button>
</body>
+</html>
</t:chloe>
(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.
To start the listener, try M-x run-factor.
+ By default, FUEL will try to use the binary and image files in the
+ factor installation directory. You can customize them with:
+
+ (setq fuel-listener-factor-binary <full path to factor>)
+ (setq fuel-listener-factor-image <full path to factor image>)
+
Many aspects of the environment can be customized:
M-x customize-group fuel will show you how many.
+*** Faster listener startup
+
+ On startup, run-factor loads the fuel vocabulary, which can take a
+ while. If you want to speedup the load process, type 'save' in the
+ listener prompt just after invoking run-factor. This will save a
+ factor image (overwriting the current one) with all the needed
+ vocabs.
+
+*** Vocabulary creation
+
+ FUEL offers a basic interface with Factor's scaffolding utilities.
+ To create a new vocabulary directory and associated files:
+
+ M-x fuel-scaffold-vocab
+
+ and when in a vocab file, to create a docs file with boilerplate
+ for each word:
+
+ M-x fuel-scaffold-help
+
* Quick key reference
(Triple chords ending in a single letter <x> accept also C-<x> (e.g.
- C-cz : switch to listener
- C-co : cycle between code, tests and docs factor files
- - M-. : edit word at point in Emacs
+ - M-. : edit word at point in Emacs (see fuel-edit-word-method custom var)
+ - M-, : go back to where M-. was last invoked
- M-TAB : complete word at point
- C-cC-eu : update USING: line
- C-cC-ev : edit vocabulary (M-x fuel-edit-vocabulary)
- C-cC-xs : extract innermost sexp (up to point) as a separate word
- C-cC-xr : extract region as a separate word
+ - C-cC-xi : replace word at point by its definition
+ - C-cC-xv : extract region as a separate vocabulary
*** In the listener:
(= (- be (point)) (current-indentation))
(= ln (line-number-at-pos be)))
(fuel-syntax--indentation-at bs))
- ((or (fuel-syntax--is-eol bs)
+ ((or (fuel-syntax--is-last-char bs)
(not (eq ?\ (char-after (1+ bs)))))
(fuel-syntax--increased-indentation
(fuel-syntax--indentation-at bs)))
(cond ((or (fuel-syntax--at-end-of-def)
(fuel-syntax--at-setter-line))
(fuel-syntax--decreased-indentation))
- ((and (fuel-syntax--at-begin-of-def)
- (not (fuel-syntax--at-using)))
+ ((fuel-syntax--at-begin-of-indent-def)
(fuel-syntax--increased-indentation))
(t (current-indentation)))))
\f
;;; Keymap:
-(defun factor-mode-insert-and-indent (n)
- (interactive "p")
- (self-insert-command n)
+(defun factor-mode--insert-and-indent (n)
+ (interactive "*p")
+ (let ((start (point)))
+ (self-insert-command n)
+ (save-excursion (font-lock-fontify-region start (point))))
(indent-according-to-mode))
(defvar factor-mode-map
(let ((map (make-sparse-keymap)))
- (define-key map [?\]] 'factor-mode-insert-and-indent)
- (define-key map [?}] 'factor-mode-insert-and-indent)
+ (define-key map [?\]] 'factor-mode--insert-and-indent)
+ (define-key map [?}] 'factor-mode--insert-and-indent)
(define-key map "\C-m" 'newline-and-indent)
(define-key map "\C-co" 'factor-mode-visit-other-file)
(define-key map "\C-c\C-o" 'factor-mode-visit-other-file)
;;; fu.el --- Startup file for FUEL
-;; 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>
;;; Code:
-(add-to-list 'load-path (file-name-directory load-file-name))
+(setq fuel-factor-fuel-dir (file-name-directory load-file-name))
+
+(setq fuel-factor-root-dir (expand-file-name "../../" fuel-factor-fuel-dir))
+
+(add-to-list 'load-path fuel-factor-fuel-dir)
(add-to-list 'auto-mode-alist '("\\.factor\\'" . factor-mode))
(autoload 'factor-mode "factor-mode.el"
"Minor mode showing in the minibuffer a synopsis of Factor word at point."
t)
+(autoload 'fuel-scaffold-vocab "fuel-scaffold.el"
+ "Create a new Factor vocabulary." t)
+
+(autoload 'fuel-scaffold-help "fuel-scaffold.el"
+ "Create a Factor vocabulary help file." t)
\f
;;; fu.el ends here
;;; fuel-base.el --- Basic FUEL support code
-;; Copyright (C) 2008 Jose Antonio Ortega Ruiz
+;; Copyright (C) 2008 Jose Antonio Ortega Ruiz
;; See http://factorcode.org/license.txt for BSD license.
;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
(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)
;;; 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>
\f
;;; 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)
(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))
(defvar fuel-debug--uses-restarts nil))
(defsubst fuel-debug--uses-insert-title ()
- (insert "Infering USING: stanza for " fuel-debug--uses-file ".\n\n"))
+ (insert "Inferring USING: stanza for " fuel-debug--uses-file ".\n\n"))
(defun fuel-debug--uses-prepare (file)
(fuel--with-popup (fuel-debug--uses-buffer)
map))
(defconst fuel-debug--uses-header-regex
- (format "^%s.*$" (regexp-opt '("Infering USING: stanza for "
+ (format "^%s.*$" (regexp-opt '("Inferring USING: stanza for "
"Current USING: is already fine!"
"Current vocabulary list:"
"Correct vocabulary list:"
(require 'fuel-eval)
(require 'fuel-base)
+(require 'etags)
+
+\f
+;;; Customization
+
+(defcustom fuel-edit-word-method nil
+ "How the new buffer is opened when invoking
+\\[fuel-edit-word-at-point]."
+ :group 'fuel
+ :type '(choice (const :tag "Other window" window)
+ (const :tag "Other frame" frame)
+ (const :tag "Current window" nil)))
+
\f
;;; Auxiliar functions:
(error "Couldn't find edit location"))
(unless (file-readable-p (car loc))
(error "Couldn't open '%s' for read" (car loc)))
- (find-file-other-window (car loc))
+ (cond ((eq fuel-edit-word-method 'window) (find-file-other-window (car loc)))
+ ((eq fuel-edit-word-method 'frame) (find-file-other-frame (car loc)))
+ (t (find-file (car loc))))
(goto-line (if (numberp (cadr loc)) (cadr loc) 1))))
(defun fuel-edit--read-vocabulary-name (refresh)
(defvar fuel-edit--word-history nil)
(defvar fuel-edit--vocab-history nil)
+(defvar fuel-edit--previous-location nil)
(defun fuel-edit-vocabulary (&optional refresh vocab)
"Visits vocabulary file in Emacs.
(interactive "P")
(let* ((word (or (and (not arg) (fuel-syntax-symbol-at-point))
(fuel-completion--read-word "Edit word: ")))
- (cmd `(:fuel* ((:quote ,word) fuel-get-edit-location))))
+ (cmd `(:fuel* ((:quote ,word) fuel-get-edit-location)))
+ (marker (and (not arg) (point-marker))))
(condition-case nil
(fuel-edit--try-edit (fuel-eval--send/wait cmd))
- (error (fuel-edit-vocabulary nil word)))))
+ (error (fuel-edit-vocabulary nil word)))
+ (when marker (ring-insert find-tag-marker-ring marker))))
(defun fuel-edit-word-doc-at-point (&optional arg word)
"Opens a new window visiting the documentation file for the word at point.
(let* ((word (or word
(and (not arg) (fuel-syntax-symbol-at-point))
(fuel-completion--read-word "Edit word: ")))
- (cmd `(:fuel* ((:quote ,word) fuel-get-doc-location))))
+ (cmd `(:fuel* ((:quote ,word) fuel-get-doc-location)))
+ (marker (and (not arg) (point-marker))))
(condition-case nil
(fuel-edit--try-edit (fuel-eval--send/wait cmd))
(error
(y-or-n-p (concat "No documentation found. "
"Do you want to open the vocab's "
"doc file? ")))
+ (when marker (ring-insert find-tag-marker-ring marker))
(find-file-other-window
(format "%s-docs.factor"
(file-name-sans-extension (buffer-file-name)))))))))
+(defun fuel-edit-pop-edit-word-stack ()
+ "Pop back to where \\[fuel-edit-word-at-point] or \\[fuel-edit-word-doc-at-point]
+was last invoked."
+ (interactive)
+ (condition-case nil
+ (pop-tag-mark)
+ (error "No previous location for find word or vocab invokation")))
+
\f
(provide 'fuel-edit)
;;; fuel-edit.el ends here
(factor (case sexp
(:rs 'fuel-eval-restartable)
(:nrs 'fuel-eval-non-restartable)
- (:in (fuel-syntax--current-vocab))
+ (:in (or (fuel-syntax--current-vocab) "fuel"))
(:usings `(:array ,@(fuel-syntax--usings)))
(:get 'fuel-eval-set-result)
(:end '\;)
(defsubst factor--fuel-in (in)
(cond ((or (eq in :in) (null in)) :in)
((eq in 'f) 'f)
- ((eq in 't) "fuel-scratchpad")
+ ((eq in 't) "fuel")
((stringp in) in)
(t (error "Invalid 'in' (%s)" in))))
((comment comment "comments")
(constructor type "constructors (<foo>)")
(constant constant "constants and literal values")
+ (number constant "integers and floats")
+ (ratio constant "ratios")
(declaration keyword "declaration words")
(parsing-word keyword "parsing words")
(setter-word function-name "setter words (>>foo)")
(symbol variable-name "name of symbol being defined")
(type-name type "type names")
(vocabulary-name constant "vocabulary names")
- (word function-name "word, generic or method being defined")))
+ (word function-name "word, generic or method being defined")
+ (invalid-syntax warning "syntactically invalid constructs")))
\f
;;; Font lock:
(defconst fuel-font-lock--font-lock-keywords
- `((,fuel-syntax--parsing-words-regex . 'factor-font-lock-parsing-word)
+ `((,fuel-syntax--stack-effect-regex . 'factor-font-lock-stack-effect)
+ (,fuel-syntax--parsing-words-regex . 'factor-font-lock-parsing-word)
(,fuel-syntax--brace-words-regex 1 'factor-font-lock-parsing-word)
("\\(P\\|SBUF\\)\"" 1 'factor-font-lock-parsing-word)
- (,fuel-syntax--stack-effect-regex . 'factor-font-lock-stack-effect)
(,fuel-syntax--vocab-ref-regexp 2 'factor-font-lock-vocabulary-name)
(,fuel-syntax--declaration-words-regex . 'factor-font-lock-declaration)
(,fuel-syntax--word-definition-regex 2 'factor-font-lock-word)
(,fuel-syntax--alias-definition-regex (1 'factor-font-lock-word)
(2 'factor-font-lock-word))
(,fuel-syntax--int-constant-def-regex 2 'factor-font-lock-constant)
- (,fuel-syntax--number-regex . 'factor-font-lock-constant)
+ (,fuel-syntax--integer-regex . 'factor-font-lock-number)
+ (,fuel-syntax--float-regex . 'factor-font-lock-number)
+ (,fuel-syntax--ratio-regex . 'factor-font-lock-ratio)
(,fuel-syntax--type-definition-regex 2 'factor-font-lock-type-name)
(,fuel-syntax--method-definition-regex (1 'factor-font-lock-type-name)
(2 'factor-font-lock-word))
(,fuel-syntax--constructor-regex . 'factor-font-lock-constructor)
(,fuel-syntax--setter-regex . 'factor-font-lock-setter-word)
(,fuel-syntax--getter-regex . 'factor-font-lock-getter-word)
- (,fuel-syntax--symbol-definition-regex 2 'factor-font-lock-symbol))
- "Font lock keywords definition for Factor mode.")
+ (,fuel-syntax--symbol-definition-regex 2 'factor-font-lock-symbol)
+ (,fuel-syntax--bad-string-regex . 'factor-font-lock-invalid-syntax)))
(defun fuel-font-lock--font-lock-setup (&optional keywords no-syntax)
(set (make-local-variable 'comment-start) "! ")
(list (cons 'font-lock-syntactic-keywords
fuel-syntax--syntactic-keywords))))))
-\f
\f
;;; Fontify strings as Factor code:
"Interacting with a Factor listener inside Emacs."
:group 'fuel)
-(defcustom fuel-listener-factor-binary "~/factor/factor"
+(defcustom fuel-listener-factor-binary
+ (expand-file-name "factor" fuel-factor-root-dir)
"Full path to the factor executable to use when starting a listener."
:type '(file :must-match t)
:group 'fuel-listener)
-(defcustom fuel-listener-factor-image "~/factor/factor.image"
+(defcustom fuel-listener-factor-image
+ (expand-file-name "factor.image" fuel-factor-root-dir)
"Full path to the factor image to use when starting a listener."
:type '(file :must-match t)
:group 'fuel-listener)
(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))
(defun fuel-listener-nuke ()
(interactive)
+ (goto-char (point-max))
+ (comint-kill-region comint-last-input-start (point))
(comint-redirect-cleanup)
(fuel-con--setup-connection fuel-listener--buffer))
(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))))
(let ((heading `($heading ,(match-string-no-properties 0)))
(rows))
(forward-line)
- (when (looking-at "Word *Stack effect$")
- (push '("Word" "Stack effect") rows)
+ (when (looking-at "Word *\\(Stack effect\\|Syntax\\)$")
+ (push (list "Word" (match-string-no-properties 1)) rows)
(forward-line))
- (while (looking-at "\\(.+?\\)\\( +\\(( .*\\)\\)?$")
+ (while (looking-at "\\(.+?\\)\\( +\\(.+\\)\\)?$")
(let ((word `($link ,(match-string-no-properties 1)
,(match-string-no-properties 1)
word))
(define-key fuel-mode-map "\C-\M-x" 'fuel-eval-definition)
(define-key fuel-mode-map "\C-\M-r" 'fuel-eval-extended-region)
(define-key fuel-mode-map "\M-." 'fuel-edit-word-at-point)
+(define-key fuel-mode-map "\M-," 'fuel-edit-pop-edit-word-stack)
(define-key fuel-mode-map "\C-c\M-<" 'fuel-show-callers)
(define-key fuel-mode-map "\C-c\M->" 'fuel-show-callees)
(define-key fuel-mode-map (kbd "M-TAB") 'fuel-completion--complete-symbol)
(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 ?x ?i 'fuel-refactor-inline-word)
(fuel-mode--key ?d ?> 'fuel-show-callees)
(fuel-mode--key ?d ?< 'fuel-show-callers)
;;; Code:
+(require 'fuel-scaffold)
(require 'fuel-stack)
(require 'fuel-syntax)
(require 'fuel-base)
+\f
+;;; Word definitions in buffer
+
+(defconst fuel-refactor--next-defun-regex
+ (format "^\\(:\\|MEMO:\\|MACRO:\\):? +\\(\\w+\\)\\(%s\\)\\([^;]+?\\) ;\\_>"
+ fuel-syntax--stack-effect-regex))
+
+(defun fuel-refactor--previous-defun ()
+ (let ((pos) (result))
+ (while (and (not result)
+ (setq pos (fuel-syntax--beginning-of-defun)))
+ (setq result (looking-at fuel-refactor--next-defun-regex)))
+ (when (and result pos)
+ (let ((name (match-string-no-properties 2))
+ (body (match-string-no-properties 4))
+ (end (match-end 0)))
+ (list (split-string body nil t) name pos end)))))
+
+(defun fuel-refactor--find (code to)
+ (let ((candidate) (result))
+ (while (and (not result)
+ (setq candidate (fuel-refactor--previous-defun))
+ (> (point) to))
+ (when (equal (car candidate) code)
+ (setq result (cdr candidate))))
+ result))
+
+(defun fuel-refactor--reuse-p (word)
+ (save-excursion
+ (mark-defun)
+ (move-overlay fuel-stack--overlay (1+ (point)) (mark))
+ (unwind-protect
+ (and (y-or-n-p (format "Use existing word '%s'? " word)) word)
+ (delete-overlay fuel-stack--overlay))))
+
+(defun fuel-refactor--code-rx (code)
+ (let ((words (split-string code nil t)))
+ (mapconcat 'regexp-quote words "[ \n\f\r]+")))
+
\f
;;; Extract word:
+(defun fuel-refactor--reuse-existing (code)
+ (save-excursion
+ (mark-defun)
+ (let ((code (split-string (substring-no-properties code) nil t))
+ (down (mark))
+ (found)
+ (result))
+ (while (and (not result)
+ (setq found (fuel-refactor--find code (point-min))))
+ (when found (setq result (fuel-refactor--reuse-p (car found)))))
+ (goto-char (point-max))
+ (while (and (not result)
+ (setq found (fuel-refactor--find code down)))
+ (when found (setq result (fuel-refactor--reuse-p (car found)))))
+ (and result found))))
+
+(defun fuel-refactor--insert-word (word stack-effect code)
+ (let ((beg (save-excursion (fuel-syntax--beginning-of-defun) (point)))
+ (end (save-excursion
+ (re-search-backward fuel-syntax--end-of-def-regex nil t)
+ (forward-line 1)
+ (skip-syntax-forward "-"))))
+ (let ((start (goto-char (max beg end))))
+ (open-line 1)
+ (insert ": " word " " stack-effect "\n" code " ;\n")
+ (indent-region start (point))
+ (move-overlay fuel-stack--overlay start (point)))))
+
+(defun fuel-refactor--extract-other (start end code)
+ (unwind-protect
+ (when (y-or-n-p "Apply refactoring to rest of buffer? ")
+ (save-excursion
+ (let ((rx (fuel-refactor--code-rx code))
+ (end (point)))
+ (query-replace-regexp rx word t (point-min) start)
+ (query-replace-regexp rx word t end (point-max)))))
+ (delete-overlay fuel-stack--overlay)))
+
(defun fuel-refactor--extract (begin end)
- (let* ((word (read-string "New word name: "))
- (code (buffer-substring begin end))
- (code-str (fuel--region-to-string begin end))
- (stack-effect (or (fuel-stack--infer-effect code-str)
- (read-string "Stack effect: "))))
- (unless (< begin end) (error "No proper region to extract"))
+ (unless (< begin end) (error "No proper region to extract"))
+ (let* ((code (buffer-substring begin end))
+ (existing (fuel-refactor--reuse-existing code))
+ (code-str (or existing (fuel--region-to-string begin end)))
+ (stack-effect (or existing
+ (fuel-stack--infer-effect code-str)
+ (read-string "Stack effect: ")))
+ (word (or (car existing) (read-string "New word name: "))))
(goto-char begin)
(delete-region begin end)
(insert word)
(indent-region begin (point))
- (set-mark (point))
- (let ((beg (save-excursion (fuel-syntax--beginning-of-defun) (point)))
- (end (save-excursion
- (re-search-backward fuel-syntax--end-of-def-regex nil t)
- (forward-line 1)
- (skip-syntax-forward "-")
- (point))))
- (goto-char (max beg end)))
- (open-line 1)
- (let ((start (point)))
- (insert ": " word " " stack-effect "\n" code " ;\n")
- (indent-region start (point))
- (move-overlay fuel-stack--overlay start (point))
- (goto-char (mark))
- (sit-for fuel-stack-highlight-period)
- (delete-overlay fuel-stack--overlay))))
+ (save-excursion
+ (let ((start (or (cadr existing) (point))))
+ (unless existing
+ (fuel-refactor--insert-word word stack-effect code))
+ (fuel-refactor--extract-other start
+ (or (car (cddr existing)) (point))
+ code)))))
(defun fuel-refactor-extract-region (begin end)
"Extracts current region as a separate word."
(if (looking-at-p ";") (point)
(fuel-syntax--end-of-symbol-pos))))
+\f
+;;; Inline word:
+
+(defun fuel-refactor--word-def (word)
+ (let ((def (fuel-eval--retort-result
+ (fuel-eval--send/wait `(:fuel* (,word fuel-word-def) "fuel")))))
+ (when def
+ (substring (substring def 2) 0 -2))))
+
+(defun fuel-refactor-inline-word ()
+ "Inserts definition of word at point."
+ (interactive)
+ (let ((word (fuel-syntax-symbol-at-point)))
+ (unless word (error "No word at point"))
+ (let ((code (fuel-refactor--word-def word)))
+ (unless code (error "Word's definition not found"))
+ (fuel-syntax--beginning-of-symbol)
+ (kill-word 1)
+ (let ((start (point)))
+ (insert code)
+ (save-excursion (font-lock-fontify-region start (point)))
+ (indent-region start (point))))))
\f
+;;; 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))))
+\f
(provide 'fuel-refactor)
;;; fuel-refactor.el ends here
--- /dev/null
+;;; fuel-scaffold.el -- interaction with tools.scaffold
+
+;; Copyright (C) 2009 Jose Antonio Ortega Ruiz
+;; See http://factorcode.org/license.txt for BSD license.
+
+;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
+;; Keywords: languages, fuel, factor
+;; Start date: Sun Jan 11, 2009 18:40
+
+;;; Comentary:
+
+;; Utilities for creating new vocabulary files and other boilerplate.
+;; Mainly, an interface to Factor's tools.scaffold.
+
+;;; Code:
+
+(require 'fuel-eval)
+(require 'fuel-edit)
+(require 'fuel-syntax)
+(require 'fuel-base)
+
+\f
+;;; Customisation:
+
+(defgroup fuel-scaffold nil
+ "Options for FUEL's scaffolding."
+ :group 'fuel)
+
+(defcustom fuel-scaffold-developer-name user-full-name
+ "The name to be inserted as yours in scaffold templates."
+ :type 'string
+ :group 'fuel-scaffold)
+
+\f
+;;; Auxiliary functions:
+
+(defun fuel-scaffold--vocab-roots ()
+ (let ((cmd '(:fuel* (vocab-roots get :get) "fuel")))
+ (fuel-eval--retort-result (fuel-eval--send/wait cmd))))
+
+\f
+;;; User interface:
+
+(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: " name-hint))
+ (root (completing-read "Vocab root: "
+ (fuel-scaffold--vocab-roots)
+ 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))))
+ (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
+scaffolded help for each word in the current vocabulary.
+
+With prefix argument, ask for the vocabulary name.
+You can configure `fuel-scaffold-developer-name' (set by default to
+`user-full-name') for the name to be inserted in the generated file."
+ (interactive "P")
+ (let* ((vocab (or (and (not arg) (fuel-syntax--current-vocab))
+ (fuel-edit--read-vocabulary-name nil)))
+ (cmd `(:fuel* (,vocab ,fuel-scaffold-developer-name fuel-scaffold-help)
+ "fuel"))
+ (ret (fuel-eval--send/wait cmd))
+ (file (fuel-eval--retort-result ret)))
+ (unless file
+ (error "Error creating help file" (car (fuel-eval--retort-error ret))))
+ (find-file file)))
+
+\f
+(provide 'fuel-scaffold)
+;;; fuel-scaffold.el ends here
(defconst fuel-syntax--parsing-words
'(":" "::" ";" "<<" "<PRIVATE" ">>"
- "ALIAS:"
+ "ABOUT:" "ALIAS:" "ARTICLE:"
"B" "BIN:"
"C:" "C-STRUCT:" "C-UNION:" "CHAR:" "CONSTANT:" "call-next-method"
"DEFER:"
"ERROR:" "EXCLUDE:"
"f" "FORGET:" "FROM:"
"GENERIC#" "GENERIC:"
- "HEX:" "HOOK:"
+ "HELP:" "HEX:" "HOOK:"
"IN:" "initial:" "INSTANCE:" "INTERSECTION:"
"M:" "MACRO:" "MACRO::" "MAIN:" "MATH:" "MEMO:" "MEMO:" "METHOD:" "MIXIN:"
"OCT:"
"UNION:" "USE:" "USING:"
"VARS:"))
-(defconst fuel-syntax--bracers
- '("B" "BV" "C" "CS" "H" "T" "V" "W"))
-
(defconst fuel-syntax--parsing-words-regex
(regexp-opt fuel-syntax--parsing-words 'words))
+(defconst fuel-syntax--bracers
+ '("B" "BV" "C" "CS" "H" "T" "V" "W"))
+
(defconst fuel-syntax--brace-words-regex
(format "%s{" (regexp-opt fuel-syntax--bracers t)))
(defconst fuel-syntax--method-definition-regex
"^M: +\\([^ ]+\\) +\\([^ ]+\\)")
-(defconst fuel-syntax--number-regex
- "\\(\\+\\|-\\)?\\([0-9]+\\.?[0-9]*\\|\\.[0-9]+\\)\\([eE]\\(\\+\\|-\\)?[0-9]+\\)?")
+(defconst fuel-syntax--integer-regex
+ "\\_<-?[0-9]+\\_>")
+
+(defconst fuel-syntax--ratio-regex
+ "\\_<-?\\([0-9]+\\+\\)?[0-9]+/-?[0-9]+\\_>")
+
+(defconst fuel-syntax--float-regex
+ "\\_<-?[0-9]+\\.[0-9]*\\([eE][+-]?[0-9]+\\)?\\_>")
+
+(defconst fuel-syntax--bad-string-regex
+ "\"\\([^\"]\\|\\\\\"\\)*\n")
(defconst fuel-syntax--word-definition-regex
(fuel-syntax--second-word-regex
(defconst fuel-syntax--sub-vocab-regex "^<\\([^ \n]+\\) *$")
+(defconst fuel-syntax--indent-def-starts '("" ":"
+ "FROM"
+ "INTERSECTION:"
+ "M" "MACRO" "MACRO:"
+ "MEMO" "MEMO:" "METHOD"
+ "PREDICATE" "PRIMITIVE"
+ "UNION"))
+
+(defconst fuel-syntax--no-indent-def-starts '("SINGLETONS"
+ "SYMBOLS"
+ "TUPLE"
+ "VARS"))
+
+(defconst fuel-syntax--indent-def-start-regex
+ (format "^\\(%s:\\) " (regexp-opt fuel-syntax--indent-def-starts)))
+
+(defconst fuel-syntax--no-indent-def-start-regex
+ (format "^\\(%s:\\) " (regexp-opt fuel-syntax--no-indent-def-starts)))
+
(defconst fuel-syntax--definition-start-regex
- (format "^\\(%s:\\) " (regexp-opt '("" ":"
- "FROM"
- "INTERSECTION:"
- "MACRO" "MACRO:" "M" "MEMO" "MEMO:" "METHOD"
- "PREDICATE" "PRIMITIVE"
- "SINGLETONS" "SYMBOLS"
- "TUPLE"
- "UNION"
- "VARS"))))
+ (format "^\\(%s:\\) " (regexp-opt (append fuel-syntax--no-indent-def-starts
+ fuel-syntax--indent-def-starts))))
(defconst fuel-syntax--definition-end-regex
(format "\\(\\(^\\| +\\);\\( *%s\\)*\\($\\| +\\)\\)"
fuel-syntax--declaration-words-regex))
(defconst fuel-syntax--single-liner-regex
- (format "^%s" (regexp-opt '("ALIAS:"
+ (format "^%s" (regexp-opt '("ABOUT:"
+ "ARTICLE:"
+ "ALIAS:"
"CONSTANT:" "C:"
"DEFER:"
"FORGET:"
"GENERIC:" "GENERIC#"
- "HEX:" "HOOK:"
+ "HELP:" "HEX:" "HOOK:"
"IN:" "INSTANCE:"
"MAIN:" "MATH:" "MIXIN:"
"OCT:"
(modify-syntax-entry ?\ " " table)
(modify-syntax-entry ?\n " " table)
- ;; Strings
- (modify-syntax-entry ?\" "\"" table)
+ ;; Char quote
(modify-syntax-entry ?\\ "/" table)
table))
("\\_<\\(#?!\\)\\(\n\\|$\\)" (1 "<") (2 ">"))
;; CHARs:
("CHAR: \\(.\\)\\( \\|$\\)" (1 "w"))
+ ;; Strings
+ ("\\(\"\\)\\([^\n\r\f\\\"]\\|\\\\\"?\\)*\\(\"\\)" (1 "\"") (3 "\""))
;; Let and lambda:
("\\_<\\(!(\\) .* \\()\\)" (1 "<") (2 ">"))
("\\(\\[\\)\\(let\\|wlet\\|let\\*\\)\\( \\|$\\)" (1 "(]"))
(" \\(|\\) " (1 "(|"))
(" \\(|\\)$" (1 ")"))
;; Opening brace words:
- (,(format "\\_<%s\\({\\)\\_>" (regexp-opt fuel-syntax--bracers)) (1 "(}"))
- ("\\_<\\({\\)\\_>" (1 "(}"))
+ ("\\_<\\w*\\({\\)\\_>" (1 "(}"))
("\\_<\\(}\\)\\_>" (1 "){"))
;; Parenthesis:
("\\_<\\((\\)\\_>" (1 "()"))
(defsubst fuel-syntax--at-begin-of-def ()
(looking-at fuel-syntax--begin-of-def-regex))
+(defsubst fuel-syntax--at-begin-of-indent-def ()
+ (looking-at fuel-syntax--indent-def-start-regex))
+
(defsubst fuel-syntax--at-end-of-def ()
(looking-at fuel-syntax--end-of-def-regex))
(defsubst fuel-syntax--looking-at-emptiness ()
(looking-at "^[ ]*$\\|$"))
-(defsubst fuel-syntax--is-eol (pos)
+(defsubst fuel-syntax--is-last-char (pos)
(save-excursion
(goto-char (1+ pos))
(fuel-syntax--looking-at-emptiness)))
projects / factor.git / commitdiff