Merge branch 'master' of git://factorcode.org/git/factor
commit
cedd0813cd
|
@ -98,26 +98,36 @@ H{ } clone class<map set
|
|||
H{ } clone update-map set
|
||||
|
||||
! Builtin classes
|
||||
: builtin-predicate ( class predicate -- )
|
||||
: builtin-predicate-quot ( class -- quot )
|
||||
[
|
||||
over "type" word-prop dup
|
||||
"type" word-prop dup
|
||||
\ tag-mask get < \ tag \ type ? , , \ eq? ,
|
||||
] [ ] make define-predicate* ;
|
||||
] [ ] make ;
|
||||
|
||||
: register-builtin ( class -- )
|
||||
dup "type" word-prop builtins get set-nth ;
|
||||
: define-builtin-predicate ( class -- )
|
||||
dup
|
||||
dup builtin-predicate-quot define-predicate
|
||||
predicate-word make-inline ;
|
||||
|
||||
: lookup-type-number ( word -- n )
|
||||
global [ target-word ] bind type-number ;
|
||||
|
||||
: define-builtin ( symbol predicate slotspec -- )
|
||||
>r dup make-inline >r
|
||||
dup dup lookup-type-number "type" set-word-prop
|
||||
: register-builtin ( class -- )
|
||||
dup
|
||||
dup lookup-type-number "type" set-word-prop
|
||||
dup "type" word-prop builtins get set-nth ;
|
||||
|
||||
: define-builtin-slots ( symbol slotspec -- )
|
||||
dupd 1 simple-slots
|
||||
2dup "slots" set-word-prop
|
||||
define-slots ;
|
||||
|
||||
: define-builtin ( symbol slotspec -- )
|
||||
>r
|
||||
dup register-builtin
|
||||
dup f f builtin-class define-class
|
||||
dup r> builtin-predicate
|
||||
dup r> 1 simple-slots 2dup "slots" set-word-prop
|
||||
dupd define-slots
|
||||
register-builtin ;
|
||||
dup define-builtin-predicate
|
||||
r> define-builtin-slots ;
|
||||
|
||||
H{ } clone typemap set
|
||||
num-types get f <array> builtins set
|
||||
|
@ -128,17 +138,15 @@ num-types get f <array> builtins set
|
|||
|
||||
"null" "kernel" create drop
|
||||
|
||||
"fixnum" "math" create "fixnum?" "math" create { } define-builtin
|
||||
"fixnum" "math" create { } define-builtin
|
||||
"fixnum" "math" create ">fixnum" "math" create 1quotation "coercer" set-word-prop
|
||||
|
||||
"bignum" "math" create "bignum?" "math" create { } define-builtin
|
||||
"bignum" "math" create { } define-builtin
|
||||
"bignum" "math" create ">bignum" "math" create 1quotation "coercer" set-word-prop
|
||||
|
||||
"tuple" "kernel" create "tuple?" "kernel" create
|
||||
{ } define-builtin
|
||||
"tuple" "kernel" create { } define-builtin
|
||||
|
||||
"ratio" "math" create "ratio?" "math" create
|
||||
{
|
||||
"ratio" "math" create {
|
||||
{
|
||||
{ "integer" "math" }
|
||||
"numerator"
|
||||
|
@ -153,11 +161,10 @@ num-types get f <array> builtins set
|
|||
}
|
||||
} define-builtin
|
||||
|
||||
"float" "math" create "float?" "math" create { } define-builtin
|
||||
"float" "math" create { } define-builtin
|
||||
"float" "math" create ">float" "math" create 1quotation "coercer" set-word-prop
|
||||
|
||||
"complex" "math" create "complex?" "math" create
|
||||
{
|
||||
"complex" "math" create {
|
||||
{
|
||||
{ "real" "math" }
|
||||
"real-part"
|
||||
|
@ -172,14 +179,13 @@ num-types get f <array> builtins set
|
|||
}
|
||||
} define-builtin
|
||||
|
||||
"f" "syntax" lookup "not" "kernel" create
|
||||
{ } define-builtin
|
||||
"f" "syntax" lookup { } define-builtin
|
||||
|
||||
"array" "arrays" create "array?" "arrays" create
|
||||
{ } define-builtin
|
||||
! do not word...
|
||||
|
||||
"wrapper" "kernel" create "wrapper?" "kernel" create
|
||||
{
|
||||
"array" "arrays" create { } define-builtin
|
||||
|
||||
"wrapper" "kernel" create {
|
||||
{
|
||||
{ "object" "kernel" }
|
||||
"wrapped"
|
||||
|
@ -188,8 +194,7 @@ num-types get f <array> builtins set
|
|||
}
|
||||
} define-builtin
|
||||
|
||||
"string" "strings" create "string?" "strings" create
|
||||
{
|
||||
"string" "strings" create {
|
||||
{
|
||||
{ "array-capacity" "sequences.private" }
|
||||
"length"
|
||||
|
@ -203,8 +208,7 @@ num-types get f <array> builtins set
|
|||
}
|
||||
} define-builtin
|
||||
|
||||
"quotation" "quotations" create "quotation?" "quotations" create
|
||||
{
|
||||
"quotation" "quotations" create {
|
||||
{
|
||||
{ "object" "kernel" }
|
||||
"array"
|
||||
|
@ -219,8 +223,7 @@ num-types get f <array> builtins set
|
|||
}
|
||||
} define-builtin
|
||||
|
||||
"dll" "alien" create "dll?" "alien" create
|
||||
{
|
||||
"dll" "alien" create {
|
||||
{
|
||||
{ "byte-array" "byte-arrays" }
|
||||
"path"
|
||||
|
@ -230,8 +233,7 @@ num-types get f <array> builtins set
|
|||
}
|
||||
define-builtin
|
||||
|
||||
"alien" "alien" create "alien?" "alien" create
|
||||
{
|
||||
"alien" "alien" create {
|
||||
{
|
||||
{ "c-ptr" "alien" }
|
||||
"alien"
|
||||
|
@ -246,8 +248,7 @@ define-builtin
|
|||
}
|
||||
define-builtin
|
||||
|
||||
"word" "words" create "word?" "words" create
|
||||
{
|
||||
"word" "words" create {
|
||||
f
|
||||
{
|
||||
{ "object" "kernel" }
|
||||
|
@ -287,26 +288,25 @@ define-builtin
|
|||
}
|
||||
} define-builtin
|
||||
|
||||
"byte-array" "byte-arrays" create
|
||||
"byte-array?" "byte-arrays" create
|
||||
{ } define-builtin
|
||||
"byte-array" "byte-arrays" create { } define-builtin
|
||||
|
||||
"bit-array" "bit-arrays" create
|
||||
"bit-array?" "bit-arrays" create
|
||||
{ } define-builtin
|
||||
"bit-array" "bit-arrays" create { } define-builtin
|
||||
|
||||
"float-array" "float-arrays" create
|
||||
"float-array?" "float-arrays" create
|
||||
{ } define-builtin
|
||||
"float-array" "float-arrays" create { } define-builtin
|
||||
|
||||
"callstack" "kernel" create "callstack?" "kernel" create
|
||||
{ } define-builtin
|
||||
"callstack" "kernel" create { } define-builtin
|
||||
|
||||
! Define general-t type, which is any object that is not f.
|
||||
"general-t" "kernel" create
|
||||
"f" "syntax" lookup builtins get remove [ ] subset f union-class
|
||||
define-class
|
||||
|
||||
"f" "syntax" create [ not ] "predicate" set-word-prop
|
||||
"f?" "syntax" create "syntax" vocab-words delete-at
|
||||
|
||||
"general-t" "kernel" create [ ] "predicate" set-word-prop
|
||||
"general-t?" "kernel" create "syntax" vocab-words delete-at
|
||||
|
||||
! Catch-all class for providing a default method.
|
||||
"object" "kernel" create [ drop t ] "predicate" set-word-prop
|
||||
"object" "kernel" create
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
USING: help.markup help.syntax kernel kernel.private
|
||||
namespaces sequences words arrays layouts help effects math
|
||||
layouts classes.private classes.union classes.mixin
|
||||
classes.predicate ;
|
||||
classes.predicate quotations ;
|
||||
IN: classes
|
||||
|
||||
ARTICLE: "builtin-classes" "Built-in classes"
|
||||
|
@ -114,24 +114,9 @@ HELP: predicate-word
|
|||
{ $values { "word" "a word" } { "predicate" "a predicate word" } }
|
||||
{ $description "Suffixes the word's name with \"?\" and creates a word with that name in the same vocabulary as the word itself." } ;
|
||||
|
||||
HELP: define-predicate*
|
||||
{ $values { "class" class } { "predicate" "a predicate word" } { "quot" "a quotation" } }
|
||||
{ $description
|
||||
"Defines a predicate word. This is identical to a word definition associating " { $snippet "quot" } " with " { $snippet "predicate" } " with the added perk that three word properties are set:"
|
||||
{ $list
|
||||
{ "the class word's " { $snippet "\"predicate\"" } " property is set to a quotation that calls the predicate" }
|
||||
{ "the predicate word's " { $snippet "\"predicating\"" } " property is set to the class word" }
|
||||
{ "the predicate word's " { $snippet "\"declared-effect\"" } " word property is set to a descriptive " { $link effect } }
|
||||
}
|
||||
"These properties are used by method dispatch and the help system."
|
||||
}
|
||||
$low-level-note ;
|
||||
|
||||
HELP: define-predicate
|
||||
{ $values { "class" class } { "quot" "a quotation" } }
|
||||
{ $description
|
||||
"Defines a predicate word named " { $snippet "class?" } " with " { $link define-predicate* } "."
|
||||
}
|
||||
{ $values { "class" class } { "quot" quotation } }
|
||||
{ $description "Defines a predicate word for a class." }
|
||||
$low-level-note ;
|
||||
|
||||
HELP: superclass
|
||||
|
|
|
@ -178,39 +178,39 @@ UNION: forget-class-bug-2 forget-class-bug-1 dll ;
|
|||
|
||||
[ f ] [ forget-class-bug-2 typemap get values [ memq? ] with contains? ] unit-test
|
||||
|
||||
DEFER: mixin-forget-test-g
|
||||
|
||||
[ "mixin-forget-test" forget-source ] with-compilation-unit
|
||||
|
||||
[ ] [
|
||||
{
|
||||
"USING: sequences ;"
|
||||
"IN: classes.tests"
|
||||
"MIXIN: mixin-forget-test"
|
||||
"INSTANCE: sequence mixin-forget-test"
|
||||
"GENERIC: mixin-forget-test-g ( x -- y )"
|
||||
"M: mixin-forget-test mixin-forget-test-g ;"
|
||||
} "\n" join <string-reader> "mixin-forget-test"
|
||||
parse-stream drop
|
||||
] unit-test
|
||||
|
||||
[ { } ] [ { } mixin-forget-test-g ] unit-test
|
||||
[ H{ } mixin-forget-test-g ] must-fail
|
||||
|
||||
[ ] [
|
||||
{
|
||||
"USING: hashtables ;"
|
||||
"IN: classes.tests"
|
||||
"MIXIN: mixin-forget-test"
|
||||
"INSTANCE: hashtable mixin-forget-test"
|
||||
"GENERIC: mixin-forget-test-g ( x -- y )"
|
||||
"M: mixin-forget-test mixin-forget-test-g ;"
|
||||
} "\n" join <string-reader> "mixin-forget-test"
|
||||
parse-stream drop
|
||||
] unit-test
|
||||
|
||||
[ { } mixin-forget-test-g ] must-fail
|
||||
[ H{ } ] [ H{ } mixin-forget-test-g ] unit-test
|
||||
2 [
|
||||
[ "mixin-forget-test" forget-source ] with-compilation-unit
|
||||
|
||||
[ ] [
|
||||
{
|
||||
"USING: sequences ;"
|
||||
"IN: classes.tests"
|
||||
"MIXIN: mixin-forget-test"
|
||||
"INSTANCE: sequence mixin-forget-test"
|
||||
"GENERIC: mixin-forget-test-g ( x -- y )"
|
||||
"M: mixin-forget-test mixin-forget-test-g ;"
|
||||
} "\n" join <string-reader> "mixin-forget-test"
|
||||
parse-stream drop
|
||||
] unit-test
|
||||
|
||||
[ { } ] [ { } "mixin-forget-test-g" "classes.tests" lookup execute ] unit-test
|
||||
[ H{ } "mixin-forget-test-g" "classes.tests" lookup execute ] must-fail
|
||||
|
||||
[ ] [
|
||||
{
|
||||
"USING: hashtables ;"
|
||||
"IN: classes.tests"
|
||||
"MIXIN: mixin-forget-test"
|
||||
"INSTANCE: hashtable mixin-forget-test"
|
||||
"GENERIC: mixin-forget-test-g ( x -- y )"
|
||||
"M: mixin-forget-test mixin-forget-test-g ;"
|
||||
} "\n" join <string-reader> "mixin-forget-test"
|
||||
parse-stream drop
|
||||
] unit-test
|
||||
|
||||
[ { } "mixin-forget-test-g" "classes.tests" lookup execute ] must-fail
|
||||
[ H{ } ] [ H{ } "mixin-forget-test-g" "classes.tests" lookup execute ] unit-test
|
||||
] times
|
||||
|
||||
! Method flattening interfered with mixin update
|
||||
MIXIN: flat-mx-1
|
||||
|
|
|
@ -31,17 +31,9 @@ PREDICATE: class tuple-class
|
|||
|
||||
PREDICATE: word predicate "predicating" word-prop >boolean ;
|
||||
|
||||
: define-predicate* ( class predicate quot -- )
|
||||
over [
|
||||
dupd predicate-effect define-declared
|
||||
2dup 1quotation "predicate" set-word-prop
|
||||
swap "predicating" set-word-prop
|
||||
] [ 3drop ] if ;
|
||||
|
||||
: define-predicate ( class quot -- )
|
||||
over "forgotten" word-prop [ 2drop ] [
|
||||
>r dup predicate-word r> define-predicate*
|
||||
] if ;
|
||||
>r "predicate" word-prop first
|
||||
r> predicate-effect define-declared ;
|
||||
|
||||
: superclass ( class -- super )
|
||||
"superclass" word-prop ;
|
||||
|
@ -257,6 +249,8 @@ PRIVATE>
|
|||
over reset-class
|
||||
over deferred? [ over define-symbol ] when
|
||||
>r dup word-props r> union over set-word-props
|
||||
dup predicate-word 2dup 1quotation "predicate" set-word-prop
|
||||
over "predicating" set-word-prop
|
||||
t "class" set-word-prop ;
|
||||
|
||||
GENERIC: update-predicate ( class -- )
|
||||
|
|
|
@ -9,7 +9,7 @@ ARTICLE: "compiler-errors" "Compiler warnings and errors"
|
|||
{ $subsection :errors }
|
||||
{ $subsection :warnings }
|
||||
{ $subsection :linkage }
|
||||
"Words such as " { $link require } " and " { $link refresh-all } " use a combinator which counts errors and prints a report at the end:"
|
||||
"Words such as " { $link require } " use a combinator which counts errors and prints a report at the end:"
|
||||
{ $link with-compiler-errors } ;
|
||||
|
||||
HELP: compiler-errors
|
||||
|
|
|
@ -4,7 +4,7 @@ USING: alien.c-types arrays cpu.x86.assembler
|
|||
cpu.x86.architecture cpu.x86.intrinsics cpu.x86.sse2
|
||||
cpu.x86.allot cpu.architecture kernel kernel.private math
|
||||
namespaces sequences generator.registers generator.fixup system
|
||||
alien alien.accessors alien.compiler alien.structs slots
|
||||
layouts alien alien.accessors alien.compiler alien.structs slots
|
||||
splitting assocs ;
|
||||
IN: cpu.x86.64
|
||||
|
||||
|
|
|
@ -1,5 +1,5 @@
|
|||
USING: help.markup help.syntax io io.styles strings
|
||||
io.backend io.files.private quotations ;
|
||||
io.backend io.files.private quotations ;
|
||||
IN: io.files
|
||||
|
||||
ARTICLE: "file-streams" "Reading and writing files"
|
||||
|
@ -43,11 +43,19 @@ ARTICLE: "directories" "Directories"
|
|||
{ $subsection make-directory }
|
||||
{ $subsection make-directories } ;
|
||||
|
||||
! ARTICLE: "file-types" "File Types"
|
||||
|
||||
! { $table { +directory+ "" } }
|
||||
|
||||
! ;
|
||||
|
||||
ARTICLE: "fs-meta" "File meta-data"
|
||||
|
||||
{ $subsection file-info }
|
||||
{ $subsection link-info }
|
||||
{ $subsection exists? }
|
||||
{ $subsection directory? }
|
||||
{ $subsection file-length }
|
||||
{ $subsection file-modified }
|
||||
! { $subsection file-modified }
|
||||
{ $subsection stat } ;
|
||||
|
||||
ARTICLE: "delete-move-copy" "Deleting, moving, copying files"
|
||||
|
@ -114,6 +122,42 @@ HELP: file-name
|
|||
{ $example "USING: io.files prettyprint ;" "\"/usr/libexec/awk/\" file-name ." "\"awk\"" }
|
||||
} ;
|
||||
|
||||
! need a $class-description file-info
|
||||
|
||||
HELP: file-info
|
||||
|
||||
{ $values { "path" "a pathname string" }
|
||||
{ "info" file-info } }
|
||||
{ $description "Queries the file system for meta data. "
|
||||
"If path refers to a symbolic link, it is followed."
|
||||
"If the file does not exist, an exception is thrown." }
|
||||
|
||||
{ $class-description "File meta data" }
|
||||
|
||||
{ $table
|
||||
{ "type" { "One of the following:"
|
||||
{ $list { $link +regular-file+ }
|
||||
{ $link +directory+ }
|
||||
{ $link +symbolic-link+ } } } }
|
||||
|
||||
{ "size" "Size of the file in bytes" }
|
||||
{ "modified" "Last modification timestamp." } }
|
||||
|
||||
;
|
||||
|
||||
! need a see also to link-info
|
||||
|
||||
HELP: link-info
|
||||
{ $values { "path" "a pathname string" }
|
||||
{ "info" "a file-info tuple" } }
|
||||
{ $description "Queries the file system for meta data. "
|
||||
"If path refers to a symbolic link, information about "
|
||||
"the symbolic link itself is returned."
|
||||
"If the file does not exist, an exception is thrown." } ;
|
||||
! need a see also to file-info
|
||||
|
||||
{ file-info link-info } related-words
|
||||
|
||||
HELP: <file-reader>
|
||||
{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" { "stream" "an input stream" } }
|
||||
{ "stream" "an input stream" } }
|
||||
|
@ -178,7 +222,7 @@ HELP: stat ( path -- directory? permissions length modified )
|
|||
"Queries the file system for file meta data. If the file does not exist, outputs " { $link f } " for all four values."
|
||||
} ;
|
||||
|
||||
{ stat exists? directory? file-length file-modified } related-words
|
||||
{ stat exists? directory? } related-words
|
||||
|
||||
HELP: path+
|
||||
{ $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } }
|
||||
|
@ -206,13 +250,9 @@ HELP: directory*
|
|||
{ $description "Outputs the contents of a directory named by " { $snippet "path" } "." }
|
||||
{ $notes "Unlike " { $link directory } ", this word prepends the directory's path to all file names in the list." } ;
|
||||
|
||||
HELP: file-length
|
||||
{ $values { "path" "a pathname string" } { "n" "a non-negative integer or " { $link f } } }
|
||||
{ $description "Outputs the length of the file in bytes, or " { $link f } " if it does not exist." } ;
|
||||
|
||||
HELP: file-modified
|
||||
{ $values { "path" "a pathname string" } { "n" "a non-negative integer or " { $link f } } }
|
||||
{ $description "Outputs a file's last modification time, since midnight January 1, 1970. If the file does not exist, outputs " { $link f } "." } ;
|
||||
! HELP: file-modified
|
||||
! { $values { "path" "a pathname string" } { "n" "a non-negative integer or " { $link f } } }
|
||||
! { $description "Outputs a file's last modification time, since midnight January 1, 1970. If the file does not exist, outputs " { $link f } "." } ;
|
||||
|
||||
HELP: resource-path
|
||||
{ $values { "path" "a pathname string" } { "newpath" "a pathname string" } }
|
||||
|
|
|
@ -86,11 +86,11 @@ SYMBOL: +unknown+
|
|||
: stat ( path -- directory? permissions length modified )
|
||||
normalize-pathname (stat) ;
|
||||
|
||||
: file-length ( path -- n ) stat drop 2nip ;
|
||||
! : file-length ( path -- n ) stat drop 2nip ;
|
||||
|
||||
: file-modified ( path -- n ) stat >r 3drop r> ;
|
||||
|
||||
: file-permissions ( path -- perm ) stat 2drop nip ;
|
||||
! : file-permissions ( path -- perm ) stat 2drop nip ;
|
||||
|
||||
: exists? ( path -- ? ) file-modified >boolean ;
|
||||
|
||||
|
@ -220,7 +220,10 @@ M: pathname <=> [ pathname-string ] compare ;
|
|||
>r <file-reader> r> with-stream ; inline
|
||||
|
||||
: file-contents ( path encoding -- str )
|
||||
dupd [ file-length read ] with-file-reader ;
|
||||
dupd [ file-info file-info-size read ] with-file-reader ;
|
||||
|
||||
! : file-contents ( path encoding -- str )
|
||||
! dupd [ file-length read ] with-file-reader ;
|
||||
|
||||
: with-file-writer ( path encoding quot -- )
|
||||
>r <file-writer> r> with-stream ; inline
|
||||
|
|
|
@ -430,3 +430,20 @@ IN: parser.tests
|
|||
[ "resource:core/parser/test/assert-depth.factor" run-file ]
|
||||
[ relative-overflow-stack { 1 2 3 } sequence= ]
|
||||
must-fail-with
|
||||
|
||||
2 [
|
||||
[ ] [
|
||||
"IN: parser.tests DEFER: d-f-s d-f-s SYMBOL: d-f-s d-f-s"
|
||||
<string-reader> "d-f-s-test" parse-stream drop
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"IN: parser.tests DEFER: d-f-s d-f-s FORGET: d-f-s SYMBOL: d-f-s d-f-s"
|
||||
<string-reader> "d-f-s-test" parse-stream drop
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"IN: parser.tests DEFER: d-f-s d-f-s SYMBOL: d-f-s d-f-s"
|
||||
<string-reader> "d-f-s-test" parse-stream drop
|
||||
] unit-test
|
||||
] times
|
||||
|
|
|
@ -416,6 +416,7 @@ SYMBOL: interactive-vocabs
|
|||
"tools.test"
|
||||
"tools.threads"
|
||||
"tools.time"
|
||||
"tools.vocabs"
|
||||
"vocabs"
|
||||
"vocabs.loader"
|
||||
"words"
|
||||
|
@ -483,7 +484,6 @@ SYMBOL: interactive-vocabs
|
|||
: finish-parsing ( lines quot -- )
|
||||
file get
|
||||
[ record-form ] keep
|
||||
[ record-modified ] keep
|
||||
[ record-definitions ] keep
|
||||
record-checksum ;
|
||||
|
||||
|
|
|
@ -3,16 +3,13 @@ definitions quotations compiler.units ;
|
|||
IN: source-files
|
||||
|
||||
ARTICLE: "source-files" "Source files"
|
||||
"Words in the " { $vocab-link "source-files" } " vocabulary are used to keep track of loaded source files. This is used to implement features such as " { $link refresh-all } "."
|
||||
"Words in the " { $vocab-link "source-files" } " vocabulary are used to keep track of loaded source files. This is used to implement " { $link "tools.vocabs" } "."
|
||||
$nl
|
||||
"The source file database:"
|
||||
{ $subsection source-files }
|
||||
"The class of source files:"
|
||||
{ $subsection source-file }
|
||||
"Testing if a source file has been changed on disk:"
|
||||
{ $subsection source-modified? }
|
||||
"Words intended for the parser:"
|
||||
{ $subsection record-modified }
|
||||
{ $subsection record-checksum }
|
||||
{ $subsection record-form }
|
||||
{ $subsection xref-source }
|
||||
|
@ -34,22 +31,12 @@ HELP: source-file
|
|||
{ $class-description "Instances retain information about loaded source files, and have the following slots:"
|
||||
{ $list
|
||||
{ { $link source-file-path } " - a pathname string." }
|
||||
{ { $link source-file-modified } " - the result of " { $link file-modified } " at the time the source file was most recently loaded." }
|
||||
{ { $link source-file-checksum } " - the CRC32 checksum of the source file's contents at the time it was most recently loaded." }
|
||||
{ { $link source-file-uses } " - an assoc whose keys are words referenced from this source file's top level form." }
|
||||
{ { $link source-file-definitions } " - a pair of assocs, containing definitions and classes defined in this source file, respectively" }
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: source-modified?
|
||||
{ $values { "path" "a pathname string" } { "?" "a boolean" } }
|
||||
{ $description "Tests if the source file has been modified since it was last loaded. This compares the file's modification time and CRC32 checksum of the file's contents against previously-recorded values." } ;
|
||||
|
||||
HELP: record-modified
|
||||
{ $values { "source-file" source-file } }
|
||||
{ $description "Records the modification time of the source file." }
|
||||
$low-level-note ;
|
||||
|
||||
HELP: record-checksum
|
||||
{ $values { "source-file" source-file } { "lines" "a sequence of strings" } }
|
||||
{ $description "Records the CRC32 checksm of the source file's contents." }
|
||||
|
@ -75,7 +62,7 @@ HELP: record-form
|
|||
$low-level-note ;
|
||||
|
||||
HELP: reset-checksums
|
||||
{ $description "Resets recorded modification times and CRC32 checksums for all loaded source files, creating a checkpoint for " { $link refresh } "." } ;
|
||||
{ $description "Resets recorded modification times and CRC32 checksums for all loaded source files, creating a checkpoint for " { $link "tools.vocabs" } "." } ;
|
||||
|
||||
HELP: forget-source
|
||||
{ $values { "path" "a pathname string" } }
|
||||
|
|
|
@ -1,44 +1,25 @@
|
|||
! Copyright (C) 2007 Slava Pestov.
|
||||
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays definitions generic assocs kernel math
|
||||
namespaces prettyprint sequences strings vectors words
|
||||
quotations inspector io.styles io combinators sorting
|
||||
splitting math.parser effects continuations debugger
|
||||
io.files io.crc32 io.streams.string vocabs
|
||||
hashtables graphs compiler.units io.encodings.utf8 ;
|
||||
USING: arrays definitions generic assocs kernel math namespaces
|
||||
prettyprint sequences strings vectors words quotations inspector
|
||||
io.styles io combinators sorting splitting math.parser effects
|
||||
continuations debugger io.files io.crc32 vocabs hashtables
|
||||
graphs compiler.units io.encodings.utf8 ;
|
||||
IN: source-files
|
||||
|
||||
SYMBOL: source-files
|
||||
|
||||
TUPLE: source-file
|
||||
path
|
||||
modified checksum
|
||||
checksum
|
||||
uses definitions ;
|
||||
|
||||
: (source-modified?) ( path modified checksum -- ? )
|
||||
pick file-modified rot [ 0 or ] 2apply >
|
||||
[ swap utf8 file-lines lines-crc32 = not ] [ 2drop f ] if ;
|
||||
|
||||
: source-modified? ( path -- ? )
|
||||
dup source-files get at [
|
||||
dup source-file-path ?resource-path
|
||||
over source-file-modified
|
||||
rot source-file-checksum
|
||||
(source-modified?)
|
||||
] [
|
||||
resource-exists?
|
||||
] ?if ;
|
||||
|
||||
: record-modified ( source-file -- )
|
||||
dup source-file-path ?resource-path file-modified
|
||||
swap set-source-file-modified ;
|
||||
|
||||
: record-checksum ( lines source-file -- )
|
||||
swap lines-crc32 swap set-source-file-checksum ;
|
||||
>r lines-crc32 r> set-source-file-checksum ;
|
||||
|
||||
: (xref-source) ( source-file -- pathname uses )
|
||||
dup source-file-path <pathname> swap source-file-uses
|
||||
[ crossref? ] subset ;
|
||||
dup source-file-path <pathname>
|
||||
swap source-file-uses [ crossref? ] subset ;
|
||||
|
||||
: xref-source ( source-file -- )
|
||||
(xref-source) crossref get add-vertex ;
|
||||
|
@ -67,9 +48,7 @@ uses definitions ;
|
|||
|
||||
: reset-checksums ( -- )
|
||||
source-files get [
|
||||
swap ?resource-path dup exists?
|
||||
[
|
||||
over record-modified
|
||||
swap ?resource-path dup exists? [
|
||||
utf8 file-lines swap record-checksum
|
||||
] [ 2drop ] if
|
||||
] assoc-each ;
|
||||
|
|
|
@ -23,9 +23,6 @@ $nl
|
|||
"Application vocabularies can define a main entry point, giving the user a convenient way to run the application:"
|
||||
{ $subsection POSTPONE: MAIN: }
|
||||
{ $subsection run }
|
||||
"Reloading source files changed on disk:"
|
||||
{ $subsection refresh }
|
||||
{ $subsection refresh-all }
|
||||
{ $see-also "vocabularies" "parser-files" "source-files" } ;
|
||||
|
||||
ABOUT: "vocabs.loader"
|
||||
|
@ -42,20 +39,12 @@ HELP: vocab-main
|
|||
HELP: vocab-roots
|
||||
{ $var-description "A sequence of pathname strings to search for vocabularies." } ;
|
||||
|
||||
HELP: vocab-tests
|
||||
{ $values { "vocab" "a vocabulary specifier" } { "tests" "a sequence of pathname strings" } }
|
||||
{ $description "Outputs a sequence of pathnames where the unit tests for " { $snippet "vocab" } " are located." } ;
|
||||
|
||||
HELP: find-vocab-root
|
||||
{ $values { "vocab" "a vocabulary specifier" } { "path/f" "a pathname string" } }
|
||||
{ $description "Searches for a vocabulary in the vocabulary roots." } ;
|
||||
|
||||
{ vocab-root find-vocab-root } related-words
|
||||
|
||||
HELP: vocab-files
|
||||
{ $values { "vocab" "a vocabulary specifier" } { "seq" "a sequence of pathname strings" } }
|
||||
{ $description "Outputs a sequence of files comprising this vocabulary, or " { $link f } " if the vocabulary does not have a directory on disk." } ;
|
||||
|
||||
HELP: no-vocab
|
||||
{ $values { "name" "a vocabulary name" } }
|
||||
{ $description "Throws a " { $link no-vocab } "." }
|
||||
|
@ -80,7 +69,7 @@ HELP: reload
|
|||
HELP: require
|
||||
{ $values { "vocab" "a vocabulary specifier" } }
|
||||
{ $description "Loads a vocabulary if it has not already been loaded." }
|
||||
{ $notes "To unconditionally reload a vocabulary, use " { $link reload } ". To reload changed source files, use " { $link refresh } " or " { $link refresh-all } "." } ;
|
||||
{ $notes "To unconditionally reload a vocabulary, use " { $link reload } ". To reload changed source files only, use the words in " { $link "tools.vocabs" } "." } ;
|
||||
|
||||
HELP: run
|
||||
{ $values { "vocab" "a vocabulary specifier" } }
|
||||
|
@ -93,12 +82,3 @@ HELP: vocab-source-path
|
|||
HELP: vocab-docs-path
|
||||
{ $values { "vocab" "a vocabulary specifier" } { "path/f" "a pathname string or " { $link f } } }
|
||||
{ $description "Outputs a pathname where the documentation for " { $snippet "vocab" } " might be found. Outputs " { $link f } " if the vocabulary does not have a directory on disk." } ;
|
||||
|
||||
HELP: refresh
|
||||
{ $values { "prefix" string } }
|
||||
{ $description "Reloads source files and documentation belonging to loaded vocabularies whose names are prefixed by " { $snippet "prefix" } " which have been modified on disk." } ;
|
||||
|
||||
HELP: refresh-all
|
||||
{ $description "Reloads source files and documentation for all loaded vocabularies which have been modified on disk." } ;
|
||||
|
||||
{ refresh refresh-all } related-words
|
||||
|
|
|
@ -3,7 +3,7 @@ IN: vocabs.loader.tests
|
|||
USING: vocabs.loader tools.test continuations vocabs math
|
||||
kernel arrays sequences namespaces io.streams.string
|
||||
parser source-files words assocs tuples definitions
|
||||
debugger compiler.units ;
|
||||
debugger compiler.units tools.vocabs ;
|
||||
|
||||
! This vocab should not exist, but just in case...
|
||||
[ ] [
|
||||
|
|
|
@ -48,27 +48,6 @@ M: string vocab-root
|
|||
M: vocab-link vocab-root
|
||||
vocab-link-root ;
|
||||
|
||||
: vocab-tests ( vocab -- tests )
|
||||
dup vocab-root [
|
||||
[
|
||||
f >vocab-link dup
|
||||
|
||||
dup "-tests.factor" vocab-dir+ vocab-path+
|
||||
dup resource-exists? [ , ] [ drop ] if
|
||||
|
||||
dup vocab-dir "tests" path+ vocab-path+ dup
|
||||
?resource-path directory keys [ ".factor" tail? ] subset
|
||||
[ path+ , ] with each
|
||||
] { } make
|
||||
] [ drop f ] if ;
|
||||
|
||||
: vocab-files ( vocab -- seq )
|
||||
f >vocab-link [
|
||||
dup vocab-source-path [ , ] when*
|
||||
dup vocab-docs-path [ , ] when*
|
||||
vocab-tests %
|
||||
] { } make ;
|
||||
|
||||
SYMBOL: load-help?
|
||||
|
||||
: source-was-loaded t swap set-vocab-source-loaded? ;
|
||||
|
@ -119,68 +98,7 @@ SYMBOL: load-help?
|
|||
"To define one, refer to \\ MAIN: help" print
|
||||
] ?if ;
|
||||
|
||||
: modified ( seq quot -- seq )
|
||||
[ dup ] swap compose { } map>assoc
|
||||
[ nip ] assoc-subset
|
||||
[ nip source-modified? ] assoc-subset keys ; inline
|
||||
|
||||
: modified-sources ( vocabs -- seq )
|
||||
[ vocab-source-path ] modified ;
|
||||
|
||||
: modified-docs ( vocabs -- seq )
|
||||
[ vocab-docs-path ] modified ;
|
||||
|
||||
: update-roots ( vocabs -- )
|
||||
[ dup find-vocab-root swap vocab set-vocab-root ] each ;
|
||||
|
||||
: to-refresh ( prefix -- modified-sources modified-docs )
|
||||
child-vocabs
|
||||
dup update-roots
|
||||
dup modified-sources swap modified-docs ;
|
||||
|
||||
: vocab-heading. ( vocab -- )
|
||||
nl
|
||||
"==== " write
|
||||
dup vocab-name swap vocab write-object ":" print
|
||||
nl ;
|
||||
|
||||
: load-error. ( triple -- )
|
||||
dup first vocab-heading.
|
||||
dup second print-error
|
||||
drop ;
|
||||
|
||||
: load-failures. ( failures -- )
|
||||
[ load-error. nl ] each ;
|
||||
|
||||
SYMBOL: blacklist
|
||||
SYMBOL: failures
|
||||
|
||||
: require-all ( vocabs -- failures )
|
||||
[
|
||||
V{ } clone blacklist set
|
||||
V{ } clone failures set
|
||||
[
|
||||
[ require ]
|
||||
[ swap vocab-name failures get set-at ]
|
||||
recover
|
||||
] each
|
||||
failures get
|
||||
] with-compiler-errors ;
|
||||
|
||||
: do-refresh ( modified-sources modified-docs -- )
|
||||
2dup
|
||||
[ f swap set-vocab-docs-loaded? ] each
|
||||
[ f swap set-vocab-source-loaded? ] each
|
||||
append prune require-all load-failures. ;
|
||||
|
||||
: refresh ( prefix -- ) to-refresh do-refresh ;
|
||||
|
||||
SYMBOL: sources-changed?
|
||||
|
||||
[ t sources-changed? set-global ] "vocabs.loader" add-init-hook
|
||||
|
||||
: refresh-all ( -- )
|
||||
"" refresh f sources-changed? set-global ;
|
||||
|
||||
GENERIC: (load-vocab) ( name -- vocab )
|
||||
|
||||
|
|
|
@ -1,28 +1,28 @@
|
|||
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel vocabs vocabs.loader tools.time tools.browser
|
||||
USING: kernel vocabs vocabs.loader tools.time tools.vocabs
|
||||
arrays assocs io.styles io help.markup prettyprint sequences
|
||||
continuations debugger ;
|
||||
continuations debugger combinators.cleave ;
|
||||
IN: benchmark
|
||||
|
||||
: run-benchmark ( vocab -- result )
|
||||
[ dup require [ run ] benchmark ] [ error. drop f f ] recover 2array ;
|
||||
[ [ require ] [ [ run ] benchmark nip ] bi ] curry
|
||||
[ error. f ] recover ;
|
||||
|
||||
: run-benchmarks ( -- assoc )
|
||||
"benchmark" all-child-vocabs values concat [ vocab-name ] map
|
||||
"benchmark" all-child-vocabs-seq
|
||||
[ dup run-benchmark ] { } map>assoc ;
|
||||
|
||||
: benchmarks. ( assoc -- )
|
||||
standard-table-style [
|
||||
[
|
||||
[ "Benchmark" write ] with-cell
|
||||
[ "Run time (ms)" write ] with-cell
|
||||
[ "GC time (ms)" write ] with-cell
|
||||
[ "Time (ms)" write ] with-cell
|
||||
] with-row
|
||||
[
|
||||
[
|
||||
swap [ dup ($vocab-link) ] with-cell
|
||||
first2 pprint-cell pprint-cell
|
||||
[ [ 1array $vocab-link ] with-cell ]
|
||||
[ pprint-cell ] bi*
|
||||
] with-row
|
||||
] assoc-each
|
||||
] tabular-output ;
|
||||
|
|
|
@ -51,7 +51,7 @@ HINTS: random fixnum ;
|
|||
dup keys >byte-array
|
||||
swap values >float-array unclip [ + ] accumulate swap add ;
|
||||
|
||||
:: select-random ( seed chars floats -- elt )
|
||||
:: select-random ( seed chars floats -- seed elt )
|
||||
floats seed random -rot
|
||||
[ >= ] curry find drop
|
||||
chars nth-unsafe ; inline
|
||||
|
@ -71,7 +71,7 @@ HINTS: random fixnum ;
|
|||
write-description
|
||||
[ make-random-fasta ] 2curry split-lines ; inline
|
||||
|
||||
:: make-repeat-fasta ( k len alu -- )
|
||||
:: make-repeat-fasta ( k len alu -- k' )
|
||||
[let | kn [ alu length ] |
|
||||
len [ k + kn mod alu nth-unsafe ] B{ } map-as print
|
||||
k len +
|
||||
|
|
|
@ -11,5 +11,7 @@ USING: vocabs.loader sequences ;
|
|||
"tools.test"
|
||||
"tools.time"
|
||||
"tools.threads"
|
||||
"tools.vocabs"
|
||||
"tools.vocabs.browser"
|
||||
"editors"
|
||||
} [ require ] each
|
||||
|
|
|
@ -21,7 +21,7 @@ IN: builder.benchmark
|
|||
[ benchmark-difference ] with map ;
|
||||
|
||||
: benchmark-deltas ( -- table )
|
||||
"../../benchmarks" "../benchmarks" [ eval-file ] 2apply
|
||||
"../benchmarks" "benchmarks" [ eval-file ] 2apply
|
||||
compare-tables
|
||||
sort-values ;
|
||||
|
||||
|
|
|
@ -4,6 +4,7 @@ USING: kernel namespaces sequences splitting system combinators continuations
|
|||
bootstrap.image benchmark vars bake smtp builder.util accessors
|
||||
io.encodings.utf8
|
||||
calendar
|
||||
tools.test
|
||||
builder.common
|
||||
builder.benchmark
|
||||
builder.release ;
|
||||
|
@ -131,7 +132,10 @@ SYMBOL: build-status
|
|||
"Test time: " write "test-time" eval-file milli-seconds>time print nl
|
||||
|
||||
"Did not pass load-everything: " print "load-everything-vocabs" cat
|
||||
|
||||
"Did not pass test-all: " print "test-all-vocabs" cat
|
||||
"test-all-vocabs" eval-file test-failures.
|
||||
|
||||
"help-lint results:" print "help-lint" cat
|
||||
|
||||
"Benchmarks: " print "benchmarks" eval-file benchmarks.
|
||||
|
|
|
@ -4,7 +4,7 @@ USING: kernel namespaces sequences assocs builder continuations
|
|||
io
|
||||
io.files
|
||||
prettyprint
|
||||
tools.browser
|
||||
tools.vocabs
|
||||
tools.test
|
||||
io.encodings.utf8
|
||||
combinators.cleave
|
||||
|
@ -21,13 +21,19 @@ IN: builder.test
|
|||
|
||||
: do-tests ( -- )
|
||||
run-all-tests
|
||||
"../test-all-vocabs" utf8
|
||||
[
|
||||
[ keys . ]
|
||||
[ test-failures. ]
|
||||
bi
|
||||
]
|
||||
with-file-writer ;
|
||||
[ keys "../test-all-vocabs" utf8 [ . ] with-file-writer ]
|
||||
[ "../test-failures" utf8 [ test-failures. ] with-file-writer ]
|
||||
bi ;
|
||||
|
||||
! : do-tests ( -- )
|
||||
! run-all-tests
|
||||
! "../test-all-vocabs" utf8
|
||||
! [
|
||||
! [ keys . ]
|
||||
! [ test-failures. ]
|
||||
! bi
|
||||
! ]
|
||||
! with-file-writer ;
|
||||
|
||||
: do-help-lint ( -- )
|
||||
"" run-help-lint "../help-lint" utf8 [ typos. ] with-file-writer ;
|
||||
|
|
|
@ -1,12 +1,14 @@
|
|||
USING: tools.deploy.config ;
|
||||
V{
|
||||
H{
|
||||
{ deploy-math? t }
|
||||
{ deploy-reflection 1 }
|
||||
{ deploy-name "Bunny" }
|
||||
{ deploy-threads? t }
|
||||
{ deploy-word-props? f }
|
||||
{ "stop-after-last-window?" t }
|
||||
{ deploy-ui? t }
|
||||
{ deploy-io 3 }
|
||||
{ deploy-reflection 1 }
|
||||
{ deploy-compiler? t }
|
||||
{ deploy-math? t }
|
||||
{ deploy-word-props? f }
|
||||
{ deploy-word-defs? f }
|
||||
{ deploy-c-types? f }
|
||||
{ "stop-after-last-window?" t }
|
||||
{ deploy-name "Bunny" }
|
||||
}
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
USING: arrays bunny.model bunny.cel-shaded
|
||||
combinators.lib continuations kernel math multiline
|
||||
opengl opengl.shaders opengl.framebuffers opengl.gl
|
||||
opengl.capabilities sequences ui.gadgets ;
|
||||
opengl.capabilities sequences ui.gadgets combinators.cleave ;
|
||||
IN: bunny.outlined
|
||||
|
||||
STRING: outlined-pass1-fragment-shader-main-source
|
||||
|
@ -177,7 +177,7 @@ TUPLE: bunny-outlined
|
|||
[ bunny-outlined-normal-texture [ delete-texture ] when* ]
|
||||
[ bunny-outlined-depth-texture [ delete-texture ] when* ]
|
||||
[ f swap set-bunny-outlined-framebuffer-dim ]
|
||||
} call-with
|
||||
} cleave
|
||||
] [ drop ] if ;
|
||||
|
||||
: remake-framebuffer-if-needed ( draw -- )
|
||||
|
@ -237,4 +237,4 @@ M: bunny-outlined dispose
|
|||
[ bunny-outlined-pass1-program [ delete-gl-program ] when* ]
|
||||
[ bunny-outlined-pass2-program [ delete-gl-program ] when* ]
|
||||
[ dispose-framebuffer ]
|
||||
} call-with ;
|
||||
} cleave ;
|
||||
|
|
|
@ -0,0 +1,108 @@
|
|||
|
||||
USING: kernel quotations help.syntax help.markup ;
|
||||
|
||||
IN: combinators.cleave
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
ARTICLE: "cleave-combinators" "Cleave Combinators"
|
||||
|
||||
"Basic cleavers:"
|
||||
|
||||
{ $subsection bi }
|
||||
{ $subsection tri }
|
||||
|
||||
"General cleave: "
|
||||
{ $subsection cleave }
|
||||
|
||||
"Cleave combinators for quotations with arity 2:"
|
||||
{ $subsection 2bi }
|
||||
{ $subsection 2tri }
|
||||
|
||||
{ $notes
|
||||
"From the Merriam-Webster Dictionary: "
|
||||
$nl
|
||||
{ $strong "cleave" }
|
||||
{ $list
|
||||
{ $emphasis "To divide by or as if by a cutting blow" }
|
||||
{ $emphasis "To separate into distinct parts and especially into "
|
||||
"groups having divergent views" } }
|
||||
$nl
|
||||
"The Joy programming language has a " { $emphasis "cleave" } " combinator." }
|
||||
|
||||
;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
HELP: bi
|
||||
|
||||
{ $values { "x" object }
|
||||
{ "p" quotation }
|
||||
{ "q" quotation }
|
||||
|
||||
{ "p(x)" "p applied to x" }
|
||||
{ "q(x)" "q applied to x" } } ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
HELP: tri
|
||||
|
||||
{ $values { "x" object }
|
||||
{ "p" quotation }
|
||||
{ "q" quotation }
|
||||
{ "r" quotation }
|
||||
|
||||
{ "p(x)" "p applied to x" }
|
||||
{ "q(x)" "q applied to x" }
|
||||
{ "r(x)" "r applied to x" } } ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
HELP: cleave
|
||||
|
||||
{ $code "( obj { q1 q2 ... qN } -- q1(obj) q2(obj) ... qN(obj) )" } ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
{ bi tri cleave 2bi 2tri } related-words
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
ARTICLE: "spread-combinators" "Spread Combinators"
|
||||
|
||||
{ $subsection bi* }
|
||||
{ $subsection tri* }
|
||||
{ $subsection spread } ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
HELP: bi*
|
||||
|
||||
{ $values { "x" object }
|
||||
{ "y" object }
|
||||
{ "p" quotation }
|
||||
{ "q" quotation }
|
||||
|
||||
{ "p(x)" "p applied to x" }
|
||||
{ "q(y)" "q applied to y" } } ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
HELP: tri*
|
||||
|
||||
{ $values { "x" object }
|
||||
{ "y" object }
|
||||
{ "z" object }
|
||||
{ "p" quotation }
|
||||
{ "q" quotation }
|
||||
{ "r" quotation }
|
||||
|
||||
{ "p(x)" "p applied to x" }
|
||||
{ "q(y)" "q applied to y" }
|
||||
{ "r(z)" "r applied to z" } } ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
HELP: spread
|
||||
|
||||
{ $code "( v1 v2 ... vN { q1 q2 ... qN } -- q1(v1) q2(v2) ... qN(vN) )" } ;
|
|
@ -7,17 +7,18 @@ IN: combinators.cleave
|
|||
! The cleaver family
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: bi ( obj quot quot -- val val ) >r keep r> call ; inline
|
||||
|
||||
: tri ( obj quot quot quot -- val val val )
|
||||
>r pick >r bi r> r> call ; inline
|
||||
: bi ( x p q -- p(x) q(x) ) >r keep r> call ; inline
|
||||
: tri ( x p q r -- p(x) q(x) r(x) ) >r pick >r bi r> r> call ; inline
|
||||
|
||||
: tetra ( obj quot quot quot quot -- val val val val )
|
||||
>r >r pick >r bi r> r> r> bi ; inline
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: 2bi ( obj obj quot quot -- val val ) >r 2keep r> call ; inline
|
||||
: 2bi ( x y p q -- p(x,y) q(x,y) ) >r 2keep r> call ; inline
|
||||
|
||||
: 2tri ( x y z p q r -- p(x,y,z) q(x,y,z) r(x,y,z) )
|
||||
>r >r 2keep r> 2keep r> call ; inline
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
@ -35,13 +36,25 @@ MACRO: cleave ( seq -- )
|
|||
[ drop ]
|
||||
append ;
|
||||
|
||||
MACRO: 2cleave ( seq -- )
|
||||
dup
|
||||
[ drop [ 2dup ] ] map concat
|
||||
swap
|
||||
dup
|
||||
[ drop [ >r >r ] ] map concat
|
||||
swap
|
||||
[ [ r> r> ] append ] map concat
|
||||
3append
|
||||
[ 2drop ]
|
||||
append ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! The spread family
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: bi* ( obj obj quot quot -- val val ) >r swap slip r> call ; inline
|
||||
: bi* ( x y p q -- p(x) q(y) ) >r swap slip r> call ; inline
|
||||
|
||||
: tri* ( obj obj obj quot quot quot -- val val val )
|
||||
: tri* ( x y z p q r -- p(x) q(y) r(z) )
|
||||
>r rot >r bi* r> r> call ; inline
|
||||
|
||||
: tetra* ( obj obj obj obj quot quot quot quot -- val val val val )
|
||||
|
|
|
@ -133,9 +133,6 @@ MACRO: parallel-call ( quots -- )
|
|||
: (make-call-with) ( quots -- quot )
|
||||
[ [ keep ] curry ] map concat [ drop ] append ;
|
||||
|
||||
MACRO: call-with ( quots -- )
|
||||
(make-call-with) ;
|
||||
|
||||
MACRO: map-call-with ( quots -- )
|
||||
[ (make-call-with) ] keep length [ narray ] curry compose ;
|
||||
|
||||
|
@ -143,9 +140,6 @@ MACRO: map-call-with ( quots -- )
|
|||
[ [ 2dup >r >r ] swap append [ r> r> ] append ] map concat
|
||||
[ 2drop ] append ;
|
||||
|
||||
MACRO: call-with2 ( quots -- )
|
||||
(make-call-with2) ;
|
||||
|
||||
MACRO: map-call-with2 ( quots -- )
|
||||
[ (make-call-with2) ] keep length [ narray ] curry append ;
|
||||
|
||||
|
|
|
@ -30,9 +30,11 @@ SYMBOL: person3
|
|||
SYMBOL: person4
|
||||
|
||||
: test-tuples ( -- )
|
||||
[ person drop-table ] [ drop ] recover
|
||||
[ ] [ person ensure-table ] unit-test
|
||||
[ ] [ person drop-table ] unit-test
|
||||
[ ] [ person create-table ] unit-test
|
||||
[ person create-table ] must-fail
|
||||
[ ] [ person ensure-table ] unit-test
|
||||
|
||||
[ ] [ person1 get insert-tuple ] unit-test
|
||||
|
||||
|
@ -191,8 +193,8 @@ TUPLE: annotation n paste-id summary author mode contents ;
|
|||
[ native-person-schema test-tuples ] test-sqlite
|
||||
[ assigned-person-schema test-tuples ] test-sqlite
|
||||
|
||||
[ native-person-schema test-tuples ] test-postgresql
|
||||
[ assigned-person-schema test-tuples ] test-postgresql
|
||||
! [ native-person-schema test-tuples ] test-postgresql
|
||||
! [ assigned-person-schema test-tuples ] test-postgresql
|
||||
|
||||
TUPLE: serialize-me id data ;
|
||||
|
||||
|
@ -211,7 +213,7 @@ TUPLE: serialize-me id data ;
|
|||
] [ T{ serialize-me f 1 } select-tuples ] unit-test ;
|
||||
|
||||
[ test-serialize ] test-sqlite
|
||||
[ test-serialize ] test-postgresql
|
||||
! [ test-serialize ] test-postgresql
|
||||
|
||||
TUPLE: exam id name score ;
|
||||
|
||||
|
|
|
@ -3,7 +3,8 @@
|
|||
USING: arrays assocs classes db kernel namespaces
|
||||
tuples words sequences slots math
|
||||
math.parser io prettyprint db.types continuations
|
||||
mirrors sequences.lib tools.walker combinators.lib ;
|
||||
mirrors sequences.lib tools.walker combinators.lib
|
||||
combinators.cleave ;
|
||||
IN: db.tuples
|
||||
|
||||
: define-persistent ( class table columns -- )
|
||||
|
@ -73,6 +74,9 @@ HOOK: insert-tuple* db ( tuple statement -- )
|
|||
: drop-table ( class -- )
|
||||
drop-sql-statement [ execute-statement ] with-disposals ;
|
||||
|
||||
: ensure-table ( class -- )
|
||||
[ dup drop-table ] ignore-errors create-table ;
|
||||
|
||||
: insert-native ( tuple -- )
|
||||
dup class
|
||||
db get db-insert-statements [ <insert-native-statement> ] cache
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2005, 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: parser kernel namespaces sequences definitions io.files
|
||||
inspector continuations tuples tools.crossref tools.browser
|
||||
inspector continuations tuples tools.crossref tools.vocabs
|
||||
io prettyprint source-files assocs vocabs vocabs.loader ;
|
||||
IN: editors
|
||||
|
||||
|
@ -13,8 +13,7 @@ M: no-edit-hook summary
|
|||
SYMBOL: edit-hook
|
||||
|
||||
: available-editors ( -- seq )
|
||||
"editors" all-child-vocabs
|
||||
values concat [ vocab-name ] map ;
|
||||
"editors" all-child-vocabs-seq [ vocab-name ] map ;
|
||||
|
||||
: editor-restarts ( -- alist )
|
||||
available-editors
|
||||
|
|
|
@ -0,0 +1,10 @@
|
|||
! Generate a new factor.vim file for syntax highlighting
|
||||
USING: http.server.templating.fhtml io.files ;
|
||||
IN: editors.vim.generate-syntax
|
||||
|
||||
: generate-vim-syntax ( -- )
|
||||
"misc/factor.vim.fgen" resource-path
|
||||
"misc/factor.vim" resource-path
|
||||
template-convert ;
|
||||
|
||||
MAIN: generate-vim-syntax
|
|
@ -1,10 +0,0 @@
|
|||
! Generate a new factor.vim file for syntax highlighting
|
||||
REQUIRES: apps/http-server ;
|
||||
|
||||
IN: vim
|
||||
|
||||
USING: embedded io ;
|
||||
|
||||
"extras/factor.vim.fgen" resource-path
|
||||
"extras/factor.vim" resource-path
|
||||
embedded-convert
|
|
@ -43,6 +43,21 @@ IN: farkup.tests
|
|||
[ "<p><strong>foo</strong>\n</p><h1>aheading</h1>\n<p>adfasd</p>" ]
|
||||
[ "*foo*\n=aheading=\nadfasd" convert-farkup ] unit-test
|
||||
|
||||
[ "<p>=foo\n</p>" ] [ "=foo\n" convert-farkup ] unit-test
|
||||
[ "<h1>foo</h1>\n" ] [ "=foo=\n" convert-farkup ] unit-test
|
||||
[ "<p>lol</p><h1>foo</h1>\n" ] [ "lol=foo=\n" convert-farkup ] unit-test
|
||||
[ "<p>=foo\n</p>" ] [ "=foo\n" convert-farkup ] unit-test
|
||||
[ "<p>=foo</p>" ] [ "=foo" convert-farkup ] unit-test
|
||||
[ "<p>==foo</p>" ] [ "==foo" convert-farkup ] unit-test
|
||||
[ "<p>=</p><h1>foo</h1>" ] [ "==foo=" convert-farkup ] unit-test
|
||||
[ "<h2>foo</h2>" ] [ "==foo==" convert-farkup ] unit-test
|
||||
[ "<h2>foo</h2>" ] [ "==foo==" convert-farkup ] unit-test
|
||||
[ "<p>=</p><h2>foo</h2>" ] [ "===foo==" convert-farkup ] unit-test
|
||||
[ "<h1>foo</h1><p>=</p>" ] [ "=foo==" convert-farkup ] unit-test
|
||||
|
||||
[ "<span class='KEYWORD3'>int</span> <span class='FUNCTION'>main</span><span class='OPERATOR'>(</span><span class='OPERATOR'>)</span><br/>" ]
|
||||
[ "[c{int main()}]" convert-farkup ] unit-test
|
||||
|
||||
[ "<p><img src=\"lol.jpg\"/></p>" ] [ "[[image:lol.jpg]]" convert-farkup ] unit-test
|
||||
[ "<p><img src=\"lol.jpg\" alt=\"teh lol\"/></p>" ] [ "[[image:lol.jpg|teh lol]]" convert-farkup ] unit-test
|
||||
[ "<p><a href=\"lol.com\"></a></p>" ] [ "[[lol.com]]" convert-farkup ] unit-test
|
||||
[ "<p><a href=\"lol.com\">haha</a></p>" ] [ "[[lol.com|haha]]" convert-farkup ] unit-test
|
||||
|
|
|
@ -42,14 +42,44 @@ MEMO: h2 ( -- parser ) "==" "h2" delimited ;
|
|||
MEMO: h3 ( -- parser ) "===" "h3" delimited ;
|
||||
MEMO: h4 ( -- parser ) "====" "h4" delimited ;
|
||||
|
||||
MEMO: eq ( -- parser )
|
||||
[
|
||||
h1 ensure-not ,
|
||||
h2 ensure-not ,
|
||||
h3 ensure-not ,
|
||||
h4 ensure-not ,
|
||||
"=" token ,
|
||||
] seq* ;
|
||||
|
||||
: render-code ( string mode -- string' )
|
||||
>r string-lines r>
|
||||
[ [ htmlize-lines ] with-html-stream ] with-string-writer ;
|
||||
|
||||
: escape-link ( href text -- href-esc text-esc )
|
||||
>r escape-quoted-string r> escape-string ;
|
||||
|
||||
: make-link ( href text -- seq )
|
||||
>r escape-quoted-string r> escape-string
|
||||
escape-link
|
||||
[ "<a href=\"" , >r , r> "\">" , [ , ] when* "</a>" , ] { } make ;
|
||||
|
||||
: make-image-link ( href alt -- seq )
|
||||
escape-link
|
||||
[
|
||||
"<img src=\"" , swap , "\"" ,
|
||||
dup empty? [ drop ] [ " alt=\"" , , "\"" , ] if
|
||||
"/>" , ]
|
||||
{ } make ;
|
||||
|
||||
MEMO: image-link ( -- parser )
|
||||
[
|
||||
"[[image:" token hide ,
|
||||
[ "|]" member? not ] satisfy repeat1 [ >string ] action ,
|
||||
"|" token hide
|
||||
[ CHAR: ] = not ] satisfy repeat0 2seq
|
||||
[ first >string ] action optional ,
|
||||
"]]" token hide ,
|
||||
] seq* [ first2 make-image-link ] action ;
|
||||
|
||||
MEMO: simple-link ( -- parser )
|
||||
[
|
||||
"[[" token hide ,
|
||||
|
@ -66,7 +96,7 @@ MEMO: labelled-link ( -- parser )
|
|||
"]]" token hide ,
|
||||
] seq* [ first2 make-link ] action ;
|
||||
|
||||
MEMO: link ( -- parser ) [ simple-link , labelled-link , ] choice* ;
|
||||
MEMO: link ( -- parser ) [ image-link , simple-link , labelled-link , ] choice* ;
|
||||
|
||||
DEFER: line
|
||||
MEMO: list-item ( -- parser )
|
||||
|
@ -92,20 +122,17 @@ MEMO: table ( -- parser )
|
|||
MEMO: code ( -- parser )
|
||||
[
|
||||
"[" token hide ,
|
||||
[ "{" member? not ] satisfy repeat1 optional [ >string ] action ,
|
||||
[ CHAR: { = not ] satisfy repeat1 optional [ >string ] action ,
|
||||
"{" token hide ,
|
||||
[
|
||||
[ any-char , "}]" token ensure-not , ] seq*
|
||||
repeat1 [ concat >string ] action ,
|
||||
[ any-char , "}]" token hide , ] seq* optional [ >string ] action ,
|
||||
] seq* [ concat ] action ,
|
||||
"}]" token ensure-not any-char 2seq repeat0 [ concat >string ] action ,
|
||||
"}]" token hide ,
|
||||
] seq* [ first2 swap render-code ] action ;
|
||||
|
||||
MEMO: line ( -- parser )
|
||||
[
|
||||
text , strong , emphasis , link ,
|
||||
superscript , subscript , inline-code ,
|
||||
escaped-char , delimiter ,
|
||||
escaped-char , delimiter , eq ,
|
||||
] choice* repeat1 ;
|
||||
|
||||
MEMO: paragraph ( -- parser )
|
||||
|
|
|
@ -199,7 +199,7 @@ ARTICLE: "cookbook-io" "Input and output cookbook"
|
|||
}
|
||||
"Convert a file of 4-byte cells from little to big endian or vice versa, by directly mapping it into memory and operating on it with sequence words:"
|
||||
{ $code
|
||||
"\"mydata.dat\" dup file-length ["
|
||||
"\"mydata.dat\" dup file-info file-info-length ["
|
||||
" 4 <sliced-groups> [ reverse-here ] change-each"
|
||||
"] with-mapped-file"
|
||||
}
|
||||
|
|
|
@ -196,6 +196,7 @@ ARTICLE: "io" "Input and output"
|
|||
{ $subsection "io.timeouts" } ;
|
||||
|
||||
ARTICLE: "tools" "Developer tools"
|
||||
{ $subsection "tools.vocabs" }
|
||||
"Exploratory tools:"
|
||||
{ $subsection "editor" }
|
||||
{ $subsection "tools.crossref" }
|
||||
|
|
|
@ -344,7 +344,7 @@ HELP: $side-effects
|
|||
|
||||
HELP: $notes
|
||||
{ $values { "element" "a markup element" } }
|
||||
{ $description "Prints the errors subheading found on the help page of some words. This section should usage tips and pitfalls." } ;
|
||||
{ $description "Prints the notes subheading found on the help page of some words. This section should document usage tips and pitfalls." } ;
|
||||
|
||||
HELP: $see
|
||||
{ $values { "element" "a markup element of the form " { $snippet "{ word }" } } }
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2006, 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: sequences parser kernel help help.markup help.topics
|
||||
words strings classes tools.browser namespaces io
|
||||
words strings classes tools.vocabs namespaces io
|
||||
io.streams.string prettyprint definitions arrays vectors
|
||||
combinators splitting debugger hashtables sorting effects vocabs
|
||||
vocabs.loader assocs editors continuations classes.predicate
|
||||
|
|
|
@ -169,7 +169,8 @@ M: f print-element drop ;
|
|||
] if
|
||||
] ($subsection) ;
|
||||
|
||||
: $vocab-link ( element -- ) first dup ($vocab-link) ;
|
||||
: $vocab-link ( element -- )
|
||||
first dup vocab-name swap ($vocab-link) ;
|
||||
|
||||
: $vocabulary ( element -- )
|
||||
first word-vocabulary [
|
||||
|
|
|
@ -7,6 +7,10 @@ IN: help.topics
|
|||
|
||||
TUPLE: link name ;
|
||||
|
||||
MIXIN: topic
|
||||
INSTANCE: link topic
|
||||
INSTANCE: word topic
|
||||
|
||||
GENERIC: >link ( obj -- obj )
|
||||
M: link >link ;
|
||||
M: vocab-spec >link ;
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
USING: help.markup help.syntax ui.commands ui.operations
|
||||
ui.tools.search ui.tools.workspace editors vocabs.loader
|
||||
kernel sequences prettyprint tools.test strings
|
||||
kernel sequences prettyprint tools.test tools.vocabs strings
|
||||
unicode.categories unicode.case ;
|
||||
IN: help.tutorial
|
||||
|
||||
|
|
|
@ -95,5 +95,4 @@ PRIVATE>
|
|||
swap >>post-data-type ;
|
||||
|
||||
: http-post ( content-type content url -- response string )
|
||||
#! The content is URL encoded for you.
|
||||
>r url-encode r> <post-request> http-request contents ;
|
||||
<post-request> http-request contents ;
|
||||
|
|
|
@ -4,7 +4,8 @@ USING: fry hashtables io io.streams.string kernel math
|
|||
namespaces math.parser assocs sequences strings splitting ascii
|
||||
io.encodings.utf8 io.encodings.string namespaces unicode.case
|
||||
combinators vectors sorting new-slots accessors calendar
|
||||
calendar.format quotations arrays ;
|
||||
calendar.format quotations arrays combinators.cleave
|
||||
combinators.lib byte-arrays ;
|
||||
IN: http
|
||||
|
||||
: http-port 80 ; inline
|
||||
|
@ -12,18 +13,21 @@ IN: http
|
|||
: url-quotable? ( ch -- ? )
|
||||
#! In a URL, can this character be used without
|
||||
#! URL-encoding?
|
||||
dup letter?
|
||||
over LETTER? or
|
||||
over digit? or
|
||||
swap "/_-." member? or ; foldable
|
||||
{
|
||||
[ dup letter? ]
|
||||
[ dup LETTER? ]
|
||||
[ dup digit? ]
|
||||
[ dup "/_-.:" member? ]
|
||||
} || nip ; foldable
|
||||
|
||||
: push-utf8 ( ch -- )
|
||||
1string utf8 encode [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ;
|
||||
1string utf8 encode
|
||||
[ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ;
|
||||
|
||||
: url-encode ( str -- str )
|
||||
[ [
|
||||
dup url-quotable? [ , ] [ push-utf8 ] if
|
||||
] each ] "" make ;
|
||||
[
|
||||
[ dup url-quotable? [ , ] [ push-utf8 ] if ] each
|
||||
] "" make ;
|
||||
|
||||
: url-decode-hex ( index str -- )
|
||||
2dup length 2 - >= [
|
||||
|
@ -108,7 +112,12 @@ IN: http
|
|||
] when ;
|
||||
|
||||
: assoc>query ( hash -- str )
|
||||
[ [ url-encode ] 2apply "=" swap 3append ] { } assoc>map
|
||||
[
|
||||
[ url-encode ]
|
||||
[ dup number? [ number>string ] when url-encode ]
|
||||
bi*
|
||||
"=" swap 3append
|
||||
] { } assoc>map
|
||||
"&" join ;
|
||||
|
||||
TUPLE: cookie name value path domain expires http-only ;
|
||||
|
@ -169,10 +178,10 @@ cookies ;
|
|||
|
||||
: <request>
|
||||
request construct-empty
|
||||
"1.1" >>version
|
||||
http-port >>port
|
||||
H{ } clone >>query
|
||||
V{ } clone >>cookies ;
|
||||
"1.1" >>version
|
||||
http-port >>port
|
||||
H{ } clone >>query
|
||||
V{ } clone >>cookies ;
|
||||
|
||||
: query-param ( request key -- value )
|
||||
swap query>> at ;
|
||||
|
@ -245,6 +254,10 @@ SYMBOL: max-post-request
|
|||
: extract-post-data-type ( request -- request )
|
||||
dup "content-type" header >>post-data-type ;
|
||||
|
||||
: parse-post-data ( request -- request )
|
||||
dup post-data-type>> "application/x-www-form-urlencoded" =
|
||||
[ dup post-data>> query>assoc >>post-data ] when ;
|
||||
|
||||
: extract-cookies ( request -- request )
|
||||
dup "cookie" header [ parse-cookies >>cookies ] when* ;
|
||||
|
||||
|
@ -257,24 +270,31 @@ SYMBOL: max-post-request
|
|||
read-post-data
|
||||
extract-host
|
||||
extract-post-data-type
|
||||
parse-post-data
|
||||
extract-cookies ;
|
||||
|
||||
: write-method ( request -- request )
|
||||
dup method>> write bl ;
|
||||
|
||||
: write-url ( request -- request )
|
||||
dup path>> url-encode write
|
||||
dup query>> dup assoc-empty? [ drop ] [
|
||||
"?" write
|
||||
assoc>query write
|
||||
] if ;
|
||||
: (link>string) ( url query -- url' )
|
||||
[ url-encode ] [ assoc>query ] bi*
|
||||
dup empty? [ drop ] [ "?" swap 3append ] if ;
|
||||
|
||||
: write-url ( request -- )
|
||||
[ path>> ] [ query>> ] bi (link>string) write ;
|
||||
|
||||
: write-request-url ( request -- request )
|
||||
write-url bl ;
|
||||
dup write-url bl ;
|
||||
|
||||
: write-version ( request -- request )
|
||||
"HTTP/" write dup request-version write crlf ;
|
||||
|
||||
: unparse-post-data ( request -- request )
|
||||
dup post-data>> dup sequence? [ drop ] [
|
||||
assoc>query >>post-data
|
||||
"application/x-www-form-urlencoded" >>post-data-type
|
||||
] if ;
|
||||
|
||||
: write-request-header ( request -- request )
|
||||
dup header>> >hashtable
|
||||
over host>> [ "host" pick set-at ] when*
|
||||
|
@ -287,6 +307,7 @@ SYMBOL: max-post-request
|
|||
dup post-data>> [ write ] when* ;
|
||||
|
||||
: write-request ( request -- )
|
||||
unparse-post-data
|
||||
write-method
|
||||
write-request-url
|
||||
write-version
|
||||
|
@ -297,15 +318,16 @@ SYMBOL: max-post-request
|
|||
|
||||
: request-url ( request -- url )
|
||||
[
|
||||
dup host>> [
|
||||
"http://" write
|
||||
dup host>> url-encode write
|
||||
":" write
|
||||
dup port>> number>string write
|
||||
] when
|
||||
dup path>> "/" head? [ "/" write ] unless
|
||||
write-url
|
||||
drop
|
||||
[
|
||||
dup host>> [
|
||||
[ "http://" write host>> url-encode write ]
|
||||
[ ":" write port>> number>string write ]
|
||||
bi
|
||||
] [ drop ] if
|
||||
]
|
||||
[ path>> "/" head? [ "/" write ] unless ]
|
||||
[ write-url ]
|
||||
tri
|
||||
] with-string-writer ;
|
||||
|
||||
: set-header ( request/response value key -- request/response )
|
||||
|
|
|
@ -29,6 +29,7 @@ blah
|
|||
STRING: action-request-test-2
|
||||
POST http://foo/bar/baz HTTP/1.1
|
||||
content-length: 5
|
||||
content-type: application/x-www-form-urlencoded
|
||||
|
||||
xxx=4
|
||||
;
|
||||
|
|
|
@ -17,14 +17,6 @@ TUPLE: action init display submit get-params post-params ;
|
|||
[ <400> ] >>display
|
||||
[ <400> ] >>submit ;
|
||||
|
||||
: extract-params ( path -- assoc )
|
||||
+path+ associate
|
||||
request get dup method>> {
|
||||
{ "GET" [ query>> ] }
|
||||
{ "HEAD" [ query>> ] }
|
||||
{ "POST" [ post-data>> query>assoc ] }
|
||||
} case union ;
|
||||
|
||||
: with-validator ( string quot -- result error? )
|
||||
'[ , @ f ] [
|
||||
dup validation-error? [ t ] [ rethrow ] if
|
||||
|
@ -50,12 +42,10 @@ TUPLE: action init display submit get-params post-params ;
|
|||
action get display>> call exit-with ;
|
||||
|
||||
M: action call-responder ( path action -- response )
|
||||
[ extract-params params set ]
|
||||
[
|
||||
action set
|
||||
request get method>> {
|
||||
{ "GET" [ handle-get ] }
|
||||
{ "HEAD" [ handle-get ] }
|
||||
{ "POST" [ handle-post ] }
|
||||
} case
|
||||
] bi* ;
|
||||
[ +path+ associate request-params union params set ]
|
||||
[ action set ] bi*
|
||||
request get method>> {
|
||||
{ "GET" [ handle-get ] }
|
||||
{ "HEAD" [ handle-get ] }
|
||||
{ "POST" [ handle-post ] }
|
||||
} case ;
|
||||
|
|
|
@ -30,7 +30,8 @@ SYMBOL: login-failed?
|
|||
|
||||
: successful-login ( user -- response )
|
||||
logged-in-user sset
|
||||
post-login-url sget f <permanent-redirect> ;
|
||||
post-login-url sget "" or f <permanent-redirect>
|
||||
f post-login-url sset ;
|
||||
|
||||
:: <login-action> ( -- action )
|
||||
[let | form [ <login-form> ] |
|
||||
|
|
|
@ -1,10 +1,13 @@
|
|||
<% USING: http.server.auth.login http.server.components kernel
|
||||
namespaces ; %>
|
||||
<% USING: http.server.auth.login http.server.components http.server
|
||||
kernel namespaces ; %>
|
||||
<html>
|
||||
<body>
|
||||
<h1>Login required</h1>
|
||||
|
||||
<form method="POST" action="login">
|
||||
|
||||
<% hidden-form-field %>
|
||||
|
||||
<table>
|
||||
|
||||
<tr>
|
||||
|
@ -30,10 +33,12 @@ login-failed? get
|
|||
|
||||
<p>
|
||||
<% allow-registration? [ %>
|
||||
<a href="register">Register</a>
|
||||
<a href="<% "register" f write-link %>">Register</a>
|
||||
<% ] when %>
|
||||
<% allow-password-recovery? [ %>
|
||||
<a href="recover-password">Recover Password</a>
|
||||
<a href="<% "recover-password" f write-link %>">
|
||||
Recover Password
|
||||
</a>
|
||||
<% ] when %>
|
||||
</p>
|
||||
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
<% USING: http.server.components ; %>
|
||||
<% USING: http.server.components http.server ; %>
|
||||
<html>
|
||||
<body>
|
||||
<h1>Recover lost password: step 1 of 4</h1>
|
||||
|
@ -6,6 +6,9 @@
|
|||
<p>Enter the username and e-mail address you used to register for this site, and you will receive a link for activating a new password.</p>
|
||||
|
||||
<form method="POST" action="recover-password">
|
||||
|
||||
<% hidden-form-field %>
|
||||
|
||||
<table>
|
||||
|
||||
<tr>
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
<% USING: http.server.components http.server.auth.login
|
||||
<% USING: http.server.components http.server.auth.login http.server
|
||||
namespaces kernel combinators ; %>
|
||||
<html>
|
||||
<body>
|
||||
|
@ -7,6 +7,9 @@ namespaces kernel combinators ; %>
|
|||
<p>Choose a new password for your account.</p>
|
||||
|
||||
<form method="POST" action="new-password">
|
||||
|
||||
<% hidden-form-field %>
|
||||
|
||||
<table>
|
||||
|
||||
<% "username" component render-edit %>
|
||||
|
@ -32,7 +35,7 @@ namespaces kernel combinators ; %>
|
|||
<p><input type="submit" value="Set password" />
|
||||
|
||||
<% password-mismatch? get [
|
||||
"passwords do not match" render-error
|
||||
"passwords do not match" render-error
|
||||
] when %>
|
||||
|
||||
</p>
|
||||
|
|
|
@ -1,10 +1,10 @@
|
|||
<% USING: http.server.components http.server.auth.login
|
||||
namespaces kernel combinators ; %>
|
||||
<% USING: http.server ; %>
|
||||
<html>
|
||||
<body>
|
||||
<h1>Recover lost password: step 4 of 4</h1>
|
||||
|
||||
<p>Your password has been reset. You may now <a href="login">log in</a>.</p>
|
||||
<p>Your password has been reset.
|
||||
You may now <a href="<% "login" f write-link %>">log in</a>.</p>
|
||||
|
||||
</body>
|
||||
</html>
|
||||
|
|
|
@ -1,10 +1,12 @@
|
|||
<% USING: http.server.components http.server.auth.login
|
||||
namespaces kernel combinators ; %>
|
||||
http.server namespaces kernel combinators ; %>
|
||||
<html>
|
||||
<body>
|
||||
<h1>New user registration</h1>
|
||||
|
||||
<form method="POST" action="register">
|
||||
<% hidden-form-field %>
|
||||
|
||||
<table>
|
||||
|
||||
<tr>
|
||||
|
|
|
@ -14,9 +14,7 @@ user "USERS"
|
|||
{ "profile" "PROFILE" FACTOR-BLOB }
|
||||
} define-persistent
|
||||
|
||||
: init-users-table ( -- )
|
||||
[ user drop-table ] ignore-errors
|
||||
user create-table ;
|
||||
: init-users-table user ensure-table ;
|
||||
|
||||
TUPLE: from-db ;
|
||||
|
||||
|
|
|
@ -3,15 +3,23 @@
|
|||
USING: assocs kernel namespaces io io.timeouts strings splitting
|
||||
threads http sequences prettyprint io.server logging calendar
|
||||
new-slots html.elements accessors math.parser combinators.lib
|
||||
vocabs.loader debugger html continuations random combinators
|
||||
tools.vocabs debugger html continuations random combinators
|
||||
destructors io.encodings.latin1 fry combinators.cleave ;
|
||||
IN: http.server
|
||||
|
||||
GENERIC: call-responder ( path responder -- response )
|
||||
|
||||
: request-params ( -- assoc )
|
||||
request get dup method>> {
|
||||
{ "GET" [ query>> ] }
|
||||
{ "HEAD" [ query>> ] }
|
||||
{ "POST" [ post-data>> ] }
|
||||
} case ;
|
||||
|
||||
: <content> ( content-type -- response )
|
||||
<response>
|
||||
200 >>code
|
||||
"Document follows" >>message
|
||||
swap set-content-type ;
|
||||
|
||||
TUPLE: trivial-responder response ;
|
||||
|
@ -44,19 +52,27 @@ SYMBOL: 404-responder
|
|||
|
||||
[ <404> ] <trivial-responder> 404-responder set-global
|
||||
|
||||
: url-redirect ( to query -- url )
|
||||
#! Different host.
|
||||
dup assoc-empty? [
|
||||
drop
|
||||
] [
|
||||
assoc>query "?" swap 3append
|
||||
] if ;
|
||||
SYMBOL: link-hook
|
||||
|
||||
: modify-query ( query -- query )
|
||||
link-hook get [ ] or call ;
|
||||
|
||||
: link>string ( url query -- url' )
|
||||
modify-query (link>string) ;
|
||||
|
||||
: write-link ( url query -- )
|
||||
link>string write ;
|
||||
|
||||
SYMBOL: form-hook
|
||||
|
||||
: hidden-form-field ( -- )
|
||||
form-hook get [ ] or call ;
|
||||
|
||||
: absolute-redirect ( to query -- url )
|
||||
#! Same host.
|
||||
request get clone
|
||||
swap [ >>query ] when*
|
||||
swap >>path
|
||||
swap url-encode >>path
|
||||
request-url ;
|
||||
|
||||
: replace-last-component ( path with -- path' )
|
||||
|
@ -66,11 +82,12 @@ SYMBOL: 404-responder
|
|||
request get clone
|
||||
swap [ >>query ] when*
|
||||
swap [ '[ , replace-last-component ] change-path ] when*
|
||||
dup query>> modify-query >>query
|
||||
request-url ;
|
||||
|
||||
: derive-url ( to query -- url )
|
||||
{
|
||||
{ [ over "http://" head? ] [ url-redirect ] }
|
||||
{ [ over "http://" head? ] [ link>string ] }
|
||||
{ [ over "/" head? ] [ absolute-redirect ] }
|
||||
{ [ t ] [ relative-redirect ] }
|
||||
} cond ;
|
||||
|
|
|
@ -2,6 +2,8 @@ IN: http.server.sessions.tests
|
|||
USING: tools.test http.server.sessions math namespaces
|
||||
kernel accessors ;
|
||||
|
||||
[ H{ } ] [ H{ } add-session-id ] unit-test
|
||||
|
||||
: with-session \ session swap with-variable ; inline
|
||||
|
||||
TUPLE: foo ;
|
||||
|
@ -10,7 +12,9 @@ C: <foo> foo
|
|||
|
||||
M: foo init-session* drop 0 "x" sset ;
|
||||
|
||||
f <session> [
|
||||
f <session> "123" >>id [
|
||||
[ H{ { "factorsessid" "123" } } ] [ H{ } add-session-id ] unit-test
|
||||
|
||||
[ ] [ 3 "x" sset ] unit-test
|
||||
|
||||
[ 9 ] [ "x" sget sq ] unit-test
|
||||
|
|
|
@ -2,7 +2,8 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs calendar kernel math.parser namespaces random
|
||||
boxes alarms new-slots accessors http http.server
|
||||
quotations hashtables sequences fry combinators.cleave ;
|
||||
quotations hashtables sequences fry combinators.cleave
|
||||
html.elements ;
|
||||
IN: http.server.sessions
|
||||
|
||||
! ! ! ! ! !
|
||||
|
@ -67,12 +68,6 @@ TUPLE: session manager id namespace alarm ;
|
|||
: sessions ( -- manager/f )
|
||||
\ session get dup [ manager>> ] when ;
|
||||
|
||||
GENERIC: session-link* ( url query sessions -- string )
|
||||
|
||||
M: object session-link* 2drop url-encode ;
|
||||
|
||||
: session-link ( url query -- string ) sessions session-link* ;
|
||||
|
||||
TUPLE: null-sessions ;
|
||||
|
||||
: <null-sessions>
|
||||
|
@ -88,23 +83,30 @@ TUPLE: url-sessions ;
|
|||
|
||||
: sess-id "factorsessid" ;
|
||||
|
||||
: current-session ( responder request -- session )
|
||||
sess-id query-param swap get-session ;
|
||||
: current-session ( responder -- session )
|
||||
>r request-params sess-id swap at r> get-session ;
|
||||
|
||||
: add-session-id ( query -- query' )
|
||||
\ session get [ id>> sess-id associate union ] when* ;
|
||||
|
||||
: session-form-field ( -- )
|
||||
<input
|
||||
"hidden" =type
|
||||
sess-id =id
|
||||
sess-id =name
|
||||
\ session get id>> =value
|
||||
input/> ;
|
||||
|
||||
M: url-sessions call-responder ( path responder -- response )
|
||||
dup request get current-session [
|
||||
[ add-session-id ] link-hook set
|
||||
[ session-form-field ] form-hook set
|
||||
dup current-session [
|
||||
call-responder/session
|
||||
] [
|
||||
nip
|
||||
f swap new-session sess-id associate <temporary-redirect>
|
||||
] if* ;
|
||||
|
||||
M: url-sessions session-link*
|
||||
drop
|
||||
url-encode
|
||||
\ session get id>> sess-id associate union assoc>query
|
||||
dup assoc-empty? [ drop ] [ "?" swap 3append ] if ;
|
||||
|
||||
TUPLE: cookie-sessions ;
|
||||
|
||||
: <cookie-sessions> ( responder -- responder' )
|
||||
|
|
|
@ -7,16 +7,11 @@ calendar.format new-slots accessors io.encodings.binary
|
|||
combinators.cleave fry ;
|
||||
IN: http.server.static
|
||||
|
||||
SYMBOL: responder
|
||||
|
||||
! special maps mime types to quots with effect ( path -- )
|
||||
TUPLE: file-responder root hook special ;
|
||||
|
||||
: unix-time>timestamp ( n -- timestamp )
|
||||
>r unix-1970 r> seconds time+ ;
|
||||
|
||||
: file-http-date ( filename -- string )
|
||||
file-modified unix-time>timestamp timestamp>http-string ;
|
||||
file-info file-info-modified timestamp>http-string ;
|
||||
|
||||
: last-modified-matches? ( filename -- ? )
|
||||
file-http-date dup [
|
||||
|
@ -33,7 +28,7 @@ TUPLE: file-responder root hook special ;
|
|||
[
|
||||
<content>
|
||||
swap
|
||||
[ file-length "content-length" set-header ]
|
||||
[ file-info file-info-size "content-length" set-header ]
|
||||
[ file-http-date "last-modified" set-header ]
|
||||
[ '[ , binary <file-reader> stdio get stream-copy ] >>body ]
|
||||
tri
|
||||
|
|
|
@ -0,0 +1,9 @@
|
|||
USING: io.encodings.string io.encodings.ascii tools.test strings arrays ;
|
||||
IN: io.encodings.ascii.tests
|
||||
|
||||
[ B{ CHAR: f CHAR: o CHAR: o } ] [ "foo" ascii encode ] unit-test
|
||||
[ { 128 } >string ascii encode ] must-fail
|
||||
[ B{ 127 } ] [ { 127 } ascii encode ] unit-test
|
||||
|
||||
[ "bar" ] [ "bar" ascii decode ] unit-test
|
||||
[ { CHAR: b HEX: fffd CHAR: r } ] [ { CHAR: b 233 CHAR: r } ascii decode >array ] unit-test
|
|
@ -3,13 +3,16 @@
|
|||
USING: io io.encodings strings kernel math sequences byte-arrays io.encodings ;
|
||||
IN: io.encodings.ascii
|
||||
|
||||
: encode-check<= ( string stream max -- )
|
||||
: encode-check< ( string stream max -- )
|
||||
[ pick <= [ encode-error ] [ stream-write1 ] if ] 2curry each ;
|
||||
|
||||
: push-if< ( sbuf character max -- )
|
||||
over <= [ drop HEX: fffd ] when swap push ;
|
||||
|
||||
TUPLE: ascii ;
|
||||
|
||||
M: ascii stream-write-encoded ( string stream encoding -- )
|
||||
drop 128 encode-check<= ;
|
||||
drop 128 encode-check< ;
|
||||
|
||||
M: ascii decode-step
|
||||
drop dup 128 >= [ decode-error ] [ swap push ] if ;
|
||||
drop 128 push-if< ;
|
||||
|
|
|
@ -0,0 +1,9 @@
|
|||
USING: io.encodings.string io.encodings.latin1 tools.test strings arrays ;
|
||||
IN: io.encodings.latin1.tests
|
||||
|
||||
[ B{ CHAR: f CHAR: o CHAR: o } ] [ "foo" latin1 encode ] unit-test
|
||||
[ { 256 } >string latin1 encode ] must-fail
|
||||
[ B{ 255 } ] [ { 255 } latin1 encode ] unit-test
|
||||
|
||||
[ "bar" ] [ "bar" latin1 decode ] unit-test
|
||||
[ { CHAR: b 233 CHAR: r } ] [ { CHAR: b 233 CHAR: r } latin1 decode >array ] unit-test
|
|
@ -6,7 +6,7 @@ IN: io.encodings.latin1
|
|||
TUPLE: latin1 ;
|
||||
|
||||
M: latin1 stream-write-encoded
|
||||
drop 256 encode-check<= ;
|
||||
drop 256 encode-check< ;
|
||||
|
||||
M: latin1 decode-step
|
||||
drop swap push ;
|
||||
|
|
|
@ -4,7 +4,7 @@ IN: io.mmap.tests
|
|||
|
||||
[ "mmap-test-file.txt" resource-path delete-file ] ignore-errors
|
||||
[ ] [ "12345" "mmap-test-file.txt" resource-path ascii set-file-contents ] unit-test
|
||||
[ ] [ "mmap-test-file.txt" resource-path dup file-length [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test
|
||||
[ 5 ] [ "mmap-test-file.txt" resource-path dup file-length [ length ] with-mapped-file ] unit-test
|
||||
[ ] [ "mmap-test-file.txt" resource-path dup file-info file-info-size [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test
|
||||
[ 5 ] [ "mmap-test-file.txt" resource-path dup file-info file-info-size [ length ] with-mapped-file ] unit-test
|
||||
[ "22345" ] [ "mmap-test-file.txt" resource-path ascii file-contents ] unit-test
|
||||
[ "mmap-test-file.txt" resource-path delete-file ] ignore-errors
|
||||
|
|
|
@ -1,15 +1,15 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io.backend io.nonblocking io.unix.backend io.files io
|
||||
unix unix.stat unix.time kernel math continuations math.bitfields
|
||||
byte-arrays alien combinators combinators.cleave calendar
|
||||
io.encodings.binary ;
|
||||
unix unix.stat unix.time kernel math continuations
|
||||
math.bitfields byte-arrays alien combinators combinators.cleave
|
||||
calendar io.encodings.binary ;
|
||||
|
||||
IN: io.unix.files
|
||||
|
||||
M: unix-io cwd
|
||||
MAXPATHLEN dup <byte-array> swap
|
||||
getcwd [ (io-error) ] unless* ;
|
||||
MAXPATHLEN [ <byte-array> ] [ ] bi getcwd
|
||||
[ (io-error) ] unless* ;
|
||||
|
||||
M: unix-io cd
|
||||
chdir io-error ;
|
||||
|
@ -68,7 +68,9 @@ M: unix-io delete-directory ( path -- )
|
|||
] with-disposal ;
|
||||
|
||||
M: unix-io copy-file ( from to -- )
|
||||
[ (copy-file) ] 2keep swap file-permissions chmod io-error ;
|
||||
[ (copy-file) ]
|
||||
[ swap file-info file-info-permissions chmod io-error ]
|
||||
2bi ;
|
||||
|
||||
: stat>type ( stat -- type )
|
||||
stat-st_mode {
|
||||
|
@ -82,8 +84,8 @@ M: unix-io copy-file ( from to -- )
|
|||
{ [ t ] [ +unknown+ ] }
|
||||
} cond nip ;
|
||||
|
||||
M: unix-io file-info ( path -- info )
|
||||
stat* {
|
||||
: stat>file-info ( stat -- info )
|
||||
{
|
||||
[ stat>type ]
|
||||
[ stat-st_size ]
|
||||
[ stat-st_mode ]
|
||||
|
@ -91,11 +93,8 @@ M: unix-io file-info ( path -- info )
|
|||
} cleave
|
||||
\ file-info construct-boa ;
|
||||
|
||||
M: unix-io file-info ( path -- info )
|
||||
stat* stat>file-info ;
|
||||
|
||||
M: unix-io link-info ( path -- info )
|
||||
lstat* {
|
||||
[ stat>type ]
|
||||
[ stat-st_size ]
|
||||
[ stat-st_mode ]
|
||||
[ stat-st_mtim timespec-sec seconds unix-1970 time+ ]
|
||||
} cleave
|
||||
\ file-info construct-boa ;
|
||||
lstat* stat>file-info ;
|
||||
|
|
|
@ -4,4 +4,4 @@ combinators namespaces system vocabs.loader sequences ;
|
|||
|
||||
"io.unix." os append require
|
||||
|
||||
"vocabs.monitor" require
|
||||
"tools.vocabs.monitor" require
|
||||
|
|
|
@ -3,7 +3,7 @@
|
|||
USING: alien.c-types io.files io.windows kernel
|
||||
math windows windows.kernel32 combinators.cleave
|
||||
windows.time calendar combinators math.functions
|
||||
sequences combinators.lib namespaces words symbols ;
|
||||
sequences namespaces words symbols ;
|
||||
IN: io.windows.files
|
||||
|
||||
SYMBOLS: +read-only+ +hidden+ +system+
|
||||
|
@ -11,34 +11,27 @@ SYMBOLS: +read-only+ +hidden+ +system+
|
|||
+sparse-file+ +reparse-point+ +compressed+ +offline+
|
||||
+not-content-indexed+ +encrypted+ ;
|
||||
|
||||
: expand-constants ( word/obj -- obj'/obj )
|
||||
dup word? [ execute ] when ;
|
||||
|
||||
: get-flags ( n seq -- seq' )
|
||||
[
|
||||
[
|
||||
first2 expand-constants
|
||||
[ swapd mask? [ , ] [ drop ] if ] 2curry
|
||||
] map call-with
|
||||
] { } make ;
|
||||
: win32-file-attribute ( n attr symbol -- n )
|
||||
>r dupd mask? [ r> , ] [ r> drop ] if ;
|
||||
|
||||
: win32-file-attributes ( n -- seq )
|
||||
{
|
||||
{ +read-only+ FILE_ATTRIBUTE_READONLY }
|
||||
{ +hidden+ FILE_ATTRIBUTE_HIDDEN }
|
||||
{ +system+ FILE_ATTRIBUTE_SYSTEM }
|
||||
{ +directory+ FILE_ATTRIBUTE_DIRECTORY }
|
||||
{ +archive+ FILE_ATTRIBUTE_ARCHIVE }
|
||||
{ +device+ FILE_ATTRIBUTE_DEVICE }
|
||||
{ +normal+ FILE_ATTRIBUTE_NORMAL }
|
||||
{ +temporary+ FILE_ATTRIBUTE_TEMPORARY }
|
||||
{ +sparse-file+ FILE_ATTRIBUTE_SPARSE_FILE }
|
||||
{ +reparse-point+ FILE_ATTRIBUTE_REPARSE_POINT }
|
||||
{ +compressed+ FILE_ATTRIBUTE_COMPRESSED }
|
||||
{ +offline+ FILE_ATTRIBUTE_OFFLINE }
|
||||
{ +not-content-indexed+ FILE_ATTRIBUTE_NOT_CONTENT_INDEXED }
|
||||
{ +encrypted+ FILE_ATTRIBUTE_ENCRYPTED }
|
||||
} get-flags ;
|
||||
[
|
||||
FILE_ATTRIBUTE_READONLY +read-only+ win32-file-attribute
|
||||
FILE_ATTRIBUTE_HIDDEN +hidden+ win32-file-attribute
|
||||
FILE_ATTRIBUTE_SYSTEM +system+ win32-file-attribute
|
||||
FILE_ATTRIBUTE_DIRECTORY +directory+ win32-file-attribute
|
||||
FILE_ATTRIBUTE_ARCHIVE +archive+ win32-file-attribute
|
||||
FILE_ATTRIBUTE_DEVICE +device+ win32-file-attribute
|
||||
FILE_ATTRIBUTE_NORMAL +normal+ win32-file-attribute
|
||||
FILE_ATTRIBUTE_TEMPORARY +temporary+ win32-file-attribute
|
||||
FILE_ATTRIBUTE_SPARSE_FILE +sparse-file+ win32-file-attribute
|
||||
FILE_ATTRIBUTE_REPARSE_POINT +reparse-point+ win32-file-attribute
|
||||
FILE_ATTRIBUTE_COMPRESSED +compressed+ win32-file-attribute
|
||||
FILE_ATTRIBUTE_OFFLINE +offline+ win32-file-attribute
|
||||
FILE_ATTRIBUTE_NOT_CONTENT_INDEXED +not-content-indexed+ win32-file-attribute
|
||||
FILE_ATTRIBUTE_ENCRYPTED +encrypted+ win32-file-attribute
|
||||
drop
|
||||
] { } make ;
|
||||
|
||||
: win32-file-type ( n -- symbol )
|
||||
FILE_ATTRIBUTE_DIRECTORY mask? +directory+ +regular-file+ ? ;
|
||||
|
|
|
@ -5,7 +5,7 @@ io.windows io.windows.nt.pipes libc io.nonblocking
|
|||
io.streams.duplex windows.types math windows.kernel32 windows
|
||||
namespaces io.launcher kernel sequences windows.errors assocs
|
||||
splitting system threads init strings combinators
|
||||
io.backend new-slots accessors ;
|
||||
io.backend new-slots accessors concurrency.flags ;
|
||||
IN: io.windows.launcher
|
||||
|
||||
TUPLE: CreateProcess-args
|
||||
|
@ -137,18 +137,18 @@ M: windows-io kill-process* ( handle -- )
|
|||
dup HEX: ffffffff = [ win32-error ] when
|
||||
dup WAIT_TIMEOUT = [ 2drop t ] [ swap nth process-exited f ] if ;
|
||||
|
||||
SYMBOL: wait-flag
|
||||
|
||||
: wait-loop ( -- )
|
||||
processes get dup assoc-empty?
|
||||
[ drop f sleep-until ]
|
||||
[ drop wait-flag get-global lower-flag ]
|
||||
[ wait-for-processes [ 100 sleep ] when ] if ;
|
||||
|
||||
SYMBOL: wait-thread
|
||||
|
||||
: start-wait-thread ( -- )
|
||||
[ wait-loop t ] "Process wait" spawn-server
|
||||
wait-thread set-global ;
|
||||
<flag> wait-flag set-global
|
||||
[ wait-loop t ] "Process wait" spawn-server drop ;
|
||||
|
||||
M: windows-io register-process
|
||||
drop wait-thread get-global interrupt ;
|
||||
drop wait-flag get-global raise-flag ;
|
||||
|
||||
[ start-wait-thread ] "io.windows.launcher" add-init-hook
|
||||
|
|
|
@ -14,4 +14,4 @@ USE: io.backend
|
|||
|
||||
T{ windows-nt-io } set-io-backend
|
||||
|
||||
"vocabs.monitor" require
|
||||
"tools.vocabs.monitor" require
|
||||
|
|
|
@ -76,7 +76,7 @@ M: win32-file close-handle ( handle -- )
|
|||
] when drop ;
|
||||
|
||||
: open-append ( path -- handle length )
|
||||
dup file-length dup [
|
||||
dup file-info file-info-size dup [
|
||||
>r (open-append) r> 2dup set-file-pointer
|
||||
] [
|
||||
drop open-write
|
||||
|
|
|
@ -59,7 +59,7 @@ M: jamshred-gadget ungraft* ( gadget -- )
|
|||
|
||||
USE: vocabs.loader
|
||||
jamshred-gadget H{
|
||||
{ T{ key-down f f "r" } [ jamshred-restart refresh-all ] }
|
||||
{ T{ key-down f f "r" } [ jamshred-restart ] }
|
||||
{ T{ key-down f f " " } [ jamshred-gadget-jamshred toggle-running ] }
|
||||
{ T{ motion } [ handle-mouse-motion ] }
|
||||
} set-gestures
|
||||
|
|
|
@ -5,7 +5,7 @@ inference.transforms parser words quotations debugger macros
|
|||
arrays macros splitting combinators prettyprint.backend
|
||||
definitions prettyprint hashtables combinators.lib
|
||||
prettyprint.sections sequences.private effects generic
|
||||
compiler.units ;
|
||||
compiler.units combinators.cleave ;
|
||||
IN: locals
|
||||
|
||||
! Inspired by
|
||||
|
@ -108,8 +108,8 @@ UNION: special local quote local-word local-reader local-writer ;
|
|||
if ;
|
||||
|
||||
: (point-free) ( quot args -- newquot )
|
||||
{ [ load-locals ] [ point-free-body ] [ point-free-end ] }
|
||||
map-call-with2 concat >quotation ;
|
||||
[ load-locals ] [ point-free-body ] [ point-free-end ]
|
||||
2tri 3append >quotation ;
|
||||
|
||||
: point-free ( quot args -- newquot )
|
||||
over empty? [ drop ] [ (point-free) ] if ;
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2005, 2007 Slava Pestov.
|
||||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays kernel sequences math math.functions
|
||||
math.vectors ;
|
||||
math.vectors combinators.cleave ;
|
||||
IN: math.matrices
|
||||
|
||||
! Matrices
|
||||
|
@ -33,23 +33,22 @@ IN: math.matrices
|
|||
: mmax ( m -- n ) >r -1/0. r> [ [ max ] each ] each ;
|
||||
: mnorm ( m -- n ) dup mmax abs m/n ;
|
||||
|
||||
: cross-i ( vec1 vec2 -- i )
|
||||
over third over second * >r
|
||||
swap second swap third * r> - ;
|
||||
<PRIVATE
|
||||
|
||||
: cross-j ( vec1 vec2 -- j )
|
||||
over first over third * >r
|
||||
swap third swap first * r> - ;
|
||||
: x first ; inline
|
||||
: y second ; inline
|
||||
: z third ; inline
|
||||
|
||||
: cross-k ( vec1 vec2 -- k )
|
||||
over first over second * >r
|
||||
swap second swap first * r> - ;
|
||||
: i [ [ y ] [ z ] bi* * ] [ [ z ] [ y ] bi* * ] 2bi - ;
|
||||
: j [ [ z ] [ x ] bi* * ] [ [ x ] [ z ] bi* * ] 2bi - ;
|
||||
: k [ [ y ] [ x ] bi* * ] [ [ x ] [ y ] bi* * ] 2bi - ;
|
||||
|
||||
: cross ( vec1 vec2 -- vec3 )
|
||||
[ cross-i ] 2keep [ cross-j ] 2keep cross-k 3array ;
|
||||
PRIVATE>
|
||||
|
||||
: cross ( vec1 vec2 -- vec3 ) [ i ] [ j ] [ k ] 2tri 3array ;
|
||||
|
||||
: proj ( v u -- w )
|
||||
[ [ v. ] keep norm-sq / ] keep n*v ;
|
||||
[ [ v. ] [ norm-sq ] bi / ] keep n*v ;
|
||||
|
||||
: (gram-schmidt) ( v seq -- newseq )
|
||||
[ dupd proj v- ] each ;
|
||||
|
|
|
@ -1,5 +1,5 @@
|
|||
USING: arrays combinators.lib kernel math math.functions math.vectors namespaces
|
||||
opengl opengl.gl sequences ui ui.gadgets ui.gestures ui.render ;
|
||||
opengl opengl.gl sequences ui ui.gadgets ui.gestures ui.render combinators.cleave ;
|
||||
IN: opengl.demo-support
|
||||
|
||||
: NEAR-PLANE 1.0 64.0 / ; inline
|
||||
|
@ -47,14 +47,15 @@ M: demo-gadget pref-dim* ( gadget -- dim )
|
|||
GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
|
||||
GL_MODELVIEW glMatrixMode
|
||||
glLoadIdentity
|
||||
{ [ >r 0.0 0.0 r> demo-gadget-distance neg glTranslatef ]
|
||||
[ demo-gadget-pitch 1.0 0.0 0.0 glRotatef ]
|
||||
[ demo-gadget-yaw 0.0 1.0 0.0 glRotatef ] } call-with ;
|
||||
[ >r 0.0 0.0 r> demo-gadget-distance neg glTranslatef ]
|
||||
[ demo-gadget-pitch 1.0 0.0 0.0 glRotatef ]
|
||||
[ demo-gadget-yaw 0.0 1.0 0.0 glRotatef ]
|
||||
tri ;
|
||||
|
||||
: reset-last-drag-rel ( -- )
|
||||
{ 0 0 } last-drag-loc set ;
|
||||
{ 0 0 } last-drag-loc set-global ;
|
||||
: last-drag-rel ( -- rel )
|
||||
drag-loc [ last-drag-loc get v- ] keep last-drag-loc set ;
|
||||
drag-loc [ last-drag-loc get v- ] keep last-drag-loc set-global ;
|
||||
|
||||
: drag-yaw-pitch ( -- yaw pitch )
|
||||
last-drag-rel MOUSE-MOTION-SCALE v*n first2 ;
|
||||
|
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel opengl.gl alien.c-types continuations namespaces
|
||||
assocs alien libc opengl math sequences combinators.lib
|
||||
macros arrays ;
|
||||
macros arrays combinators.cleave ;
|
||||
IN: opengl.shaders
|
||||
|
||||
: with-gl-shader-source-ptr ( string quot -- )
|
||||
|
@ -117,7 +117,7 @@ PREDICATE: gl-shader fragment-shader (fragment-shader?) ;
|
|||
: (make-with-gl-program) ( uniforms quot -- q )
|
||||
[
|
||||
\ dup ,
|
||||
[ swap (with-gl-program-uniforms) , \ call-with , % ]
|
||||
[ swap (with-gl-program-uniforms) , \ cleave , % ]
|
||||
[ ] make ,
|
||||
\ (with-gl-program) ,
|
||||
] [ ] make ;
|
||||
|
|
|
@ -88,7 +88,7 @@ M: string b, ( n string -- ) heap-size b, ;
|
|||
read [ zero? ] right-trim dup empty? [ drop f ] when ;
|
||||
|
||||
: (read-128-ber) ( n -- n )
|
||||
1 read first
|
||||
read1
|
||||
[ >r 7 shift r> 7 clear-bit bitor ] keep
|
||||
7 bit? [ (read-128-ber) ] when ;
|
||||
|
||||
|
|
|
@ -1,9 +1,19 @@
|
|||
! Copyright (C) 2007 Chris Double.
|
||||
! Copyright (C) 2008 Chris Double, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax peg peg.parsers.private
|
||||
unicode.categories ;
|
||||
IN: peg.parsers
|
||||
|
||||
HELP: 1token
|
||||
{ $values
|
||||
{ "ch" "a character" }
|
||||
{ "parser" "a parser" }
|
||||
} { $description
|
||||
"Calls 1string on a character and returns a parser that matches that character."
|
||||
} { $examples
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"a\" CHAR: a 1token parse parse-result-ast ." "\"a\"" }
|
||||
} { $see-also 'string' } ;
|
||||
|
||||
HELP: (list-of)
|
||||
{ $values
|
||||
{ "items" "a sequence" }
|
||||
|
|
|
@ -21,6 +21,8 @@ M: just-parser compile ( parser -- quot )
|
|||
MEMO: just ( parser -- parser )
|
||||
just-parser construct-boa init-parser ;
|
||||
|
||||
MEMO: 1token ( ch -- parser ) 1string token ;
|
||||
|
||||
<PRIVATE
|
||||
MEMO: (list-of) ( items separator repeat1? -- parser )
|
||||
>r over 2seq r> [ repeat1 ] [ repeat0 ] if [ concat ] action 2seq
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors db.tuples kernel new-slots semantic-db
|
||||
semantic-db.relations sorting sequences sequences.deep ;
|
||||
USING: accessors db.tuples hashtables kernel new-slots
|
||||
semantic-db semantic-db.relations sequences sequences.deep ;
|
||||
IN: semantic-db.hierarchy
|
||||
|
||||
TUPLE: tree id children ;
|
||||
|
@ -34,9 +34,6 @@ C: <tree> tree
|
|||
: get-node-hierarchy ( node-id -- tree )
|
||||
dup children [ get-node-hierarchy ] map <tree> ;
|
||||
|
||||
: uniq ( sorted-seq -- seq )
|
||||
f swap [ tuck = not ] subset nip ;
|
||||
|
||||
: (get-root-nodes) ( node-id -- root-nodes/node-id )
|
||||
dup parents dup empty? [
|
||||
drop
|
||||
|
@ -45,4 +42,4 @@ C: <tree> tree
|
|||
] if ;
|
||||
|
||||
: get-root-nodes ( node-id -- root-nodes )
|
||||
(get-root-nodes) flatten natural-sort uniq ;
|
||||
(get-root-nodes) flatten prune ;
|
||||
|
|
|
@ -1,6 +1,7 @@
|
|||
USING: accessors arrays continuations db db.sqlite db.tuples io.files
|
||||
kernel math namespaces semantic-db semantic-db.context
|
||||
semantic-db.hierarchy semantic-db.relations sequences tools.test
|
||||
USING: accessors arrays continuations db db.sqlite
|
||||
db.tuples io.files kernel math namespaces semantic-db
|
||||
semantic-db.context semantic-db.hierarchy
|
||||
semantic-db.relations sequences sorting tools.test
|
||||
tools.walker ;
|
||||
IN: semantic-db.tests
|
||||
|
||||
|
@ -63,7 +64,7 @@ test-db [
|
|||
[ { "bob" "fran" } ] [ "eve" get children [ node-content ] map ] unit-test
|
||||
[ { "adam" "eve" } ] [ "bob" get parents [ node-content ] map ] unit-test
|
||||
[ "fran" { "charlie" } ] [ "fran" get get-node-hierarchy dup tree-id node-content swap tree-children [ tree-id node-content ] map ] unit-test
|
||||
[ { "adam" "eve" } ] [ "charlie" get get-root-nodes [ node-content ] map ] unit-test
|
||||
[ { "adam" "eve" } ] [ "charlie" get get-root-nodes [ node-content ] map natural-sort >array ] unit-test
|
||||
[ { } ] [ "fran" get "charlie" get tuck un-parent-child parents [ node-content ] map ] unit-test
|
||||
] with-context
|
||||
] with-db
|
||||
|
|
|
@ -1,4 +0,0 @@
|
|||
IN: tools.browser.tests
|
||||
USING: tools.browser tools.test help.markup ;
|
||||
|
||||
[ ] [ { $describe-vocab "scratchpad" } print-content ] unit-test
|
|
@ -1,364 +0,0 @@
|
|||
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces splitting sequences io.files kernel assocs
|
||||
words vocabs vocabs.loader definitions parser continuations
|
||||
inspector debugger io io.styles hashtables
|
||||
sorting prettyprint source-files arrays combinators strings
|
||||
system math.parser help.markup help.topics help.syntax
|
||||
help.stylesheet memoize io.encodings.utf8 ;
|
||||
IN: tools.browser
|
||||
|
||||
MEMO: (vocab-file-contents) ( path -- lines )
|
||||
?resource-path dup exists?
|
||||
[ utf8 file-lines ] [ drop f ] if ;
|
||||
|
||||
: vocab-file-contents ( vocab name -- seq )
|
||||
vocab-path+ dup [ (vocab-file-contents) ] when ;
|
||||
|
||||
: set-vocab-file-contents ( seq vocab name -- )
|
||||
dupd vocab-path+ [
|
||||
?resource-path utf8 set-file-lines
|
||||
] [
|
||||
"The " swap vocab-name
|
||||
" vocabulary was not loaded from the file system"
|
||||
3append throw
|
||||
] ?if ;
|
||||
|
||||
: vocab-summary-path ( vocab -- string )
|
||||
vocab-dir "summary.txt" path+ ;
|
||||
|
||||
: vocab-summary ( vocab -- summary )
|
||||
dup dup vocab-summary-path vocab-file-contents
|
||||
dup empty? [
|
||||
drop vocab-name " vocabulary" append
|
||||
] [
|
||||
nip first
|
||||
] if ;
|
||||
|
||||
M: vocab summary
|
||||
[
|
||||
dup vocab-summary %
|
||||
" (" %
|
||||
vocab-words assoc-size #
|
||||
" words)" %
|
||||
] "" make ;
|
||||
|
||||
M: vocab-link summary vocab-summary ;
|
||||
|
||||
: set-vocab-summary ( string vocab -- )
|
||||
>r 1array r>
|
||||
dup vocab-summary-path
|
||||
set-vocab-file-contents ;
|
||||
|
||||
: vocab-tags-path ( vocab -- string )
|
||||
vocab-dir "tags.txt" path+ ;
|
||||
|
||||
: vocab-tags ( vocab -- tags )
|
||||
dup vocab-tags-path vocab-file-contents ;
|
||||
|
||||
: set-vocab-tags ( tags vocab -- )
|
||||
dup vocab-tags-path set-vocab-file-contents ;
|
||||
|
||||
: add-vocab-tags ( tags vocab -- )
|
||||
[ vocab-tags append prune ] keep set-vocab-tags ;
|
||||
|
||||
: vocab-authors-path ( vocab -- string )
|
||||
vocab-dir "authors.txt" path+ ;
|
||||
|
||||
: vocab-authors ( vocab -- authors )
|
||||
dup vocab-authors-path vocab-file-contents ;
|
||||
|
||||
: set-vocab-authors ( authors vocab -- )
|
||||
dup vocab-authors-path set-vocab-file-contents ;
|
||||
|
||||
: subdirs ( dir -- dirs )
|
||||
directory [ second ] subset keys natural-sort ;
|
||||
|
||||
: (all-child-vocabs) ( root name -- vocabs )
|
||||
[ vocab-dir path+ ?resource-path subdirs ] keep
|
||||
dup empty? [
|
||||
drop
|
||||
] [
|
||||
swap [ "." swap 3append ] with map
|
||||
] if ;
|
||||
|
||||
: vocabs-in-dir ( root name -- )
|
||||
dupd (all-child-vocabs) [
|
||||
2dup vocab-dir? [ 2dup swap >vocab-link , ] when
|
||||
vocabs-in-dir
|
||||
] with each ;
|
||||
|
||||
: all-vocabs ( -- assoc )
|
||||
vocab-roots get [
|
||||
dup [ "" vocabs-in-dir ] { } make
|
||||
] { } map>assoc ;
|
||||
|
||||
MEMO: all-vocabs-seq ( -- seq )
|
||||
all-vocabs values concat ;
|
||||
|
||||
: dangerous? ( name -- ? )
|
||||
#! Hack
|
||||
{
|
||||
{ [ "cpu." ?head ] [ t ] }
|
||||
{ [ "io.unix" ?head ] [ t ] }
|
||||
{ [ "io.windows" ?head ] [ t ] }
|
||||
{ [ "ui.x11" ?head ] [ t ] }
|
||||
{ [ "ui.windows" ?head ] [ t ] }
|
||||
{ [ "ui.cocoa" ?head ] [ t ] }
|
||||
{ [ "cocoa" ?head ] [ t ] }
|
||||
{ [ "core-foundation" ?head ] [ t ] }
|
||||
{ [ "vocabs.loader.test" ?head ] [ t ] }
|
||||
{ [ "editors." ?head ] [ t ] }
|
||||
{ [ ".windows" ?tail ] [ t ] }
|
||||
{ [ ".unix" ?tail ] [ t ] }
|
||||
{ [ "unix." ?head ] [ t ] }
|
||||
{ [ ".linux" ?tail ] [ t ] }
|
||||
{ [ ".bsd" ?tail ] [ t ] }
|
||||
{ [ ".macosx" ?tail ] [ t ] }
|
||||
{ [ "windows." ?head ] [ t ] }
|
||||
{ [ "cocoa" ?head ] [ t ] }
|
||||
{ [ ".test" ?tail ] [ t ] }
|
||||
{ [ "raptor" ?head ] [ t ] }
|
||||
{ [ dup "tools.deploy.app" = ] [ t ] }
|
||||
{ [ t ] [ f ] }
|
||||
} cond nip ;
|
||||
|
||||
: filter-dangerous ( seq -- seq' )
|
||||
[ vocab-name dangerous? not ] subset ;
|
||||
|
||||
: try-everything ( -- failures )
|
||||
all-vocabs-seq
|
||||
filter-dangerous
|
||||
require-all ;
|
||||
|
||||
: load-everything ( -- )
|
||||
try-everything load-failures. ;
|
||||
|
||||
: unrooted-child-vocabs ( prefix -- seq )
|
||||
dup empty? [ CHAR: . add ] unless
|
||||
vocabs
|
||||
[ vocab-root not ] subset
|
||||
[
|
||||
vocab-name swap ?head CHAR: . rot member? not and
|
||||
] with subset
|
||||
[ vocab ] map ;
|
||||
|
||||
: all-child-vocabs ( prefix -- assoc )
|
||||
vocab-roots get [
|
||||
over dupd dupd (all-child-vocabs)
|
||||
swap [ >vocab-link ] curry map
|
||||
] { } map>assoc
|
||||
f rot unrooted-child-vocabs 2array add ;
|
||||
|
||||
: load-children ( prefix -- )
|
||||
all-child-vocabs values concat
|
||||
filter-dangerous
|
||||
require-all
|
||||
load-failures. ;
|
||||
|
||||
: vocab-status-string ( vocab -- string )
|
||||
{
|
||||
{ [ dup not ] [ drop "" ] }
|
||||
{ [ dup vocab-main ] [ drop "[Runnable]" ] }
|
||||
{ [ t ] [ drop "[Loaded]" ] }
|
||||
} cond ;
|
||||
|
||||
: write-status ( vocab -- )
|
||||
vocab vocab-status-string write ;
|
||||
|
||||
: vocab. ( vocab -- )
|
||||
[
|
||||
dup [ write-status ] with-cell
|
||||
dup [ ($link) ] with-cell
|
||||
[ vocab-summary write ] with-cell
|
||||
] with-row ;
|
||||
|
||||
: vocab-headings. ( -- )
|
||||
[
|
||||
[ "State" write ] with-cell
|
||||
[ "Vocabulary" write ] with-cell
|
||||
[ "Summary" write ] with-cell
|
||||
] with-row ;
|
||||
|
||||
: root-heading. ( root -- )
|
||||
[ "Children from " swap append ] [ "Children" ] if*
|
||||
$heading ;
|
||||
|
||||
: vocabs. ( assoc -- )
|
||||
[
|
||||
dup empty? [
|
||||
2drop
|
||||
] [
|
||||
swap root-heading.
|
||||
standard-table-style [
|
||||
vocab-headings. [ vocab. ] each
|
||||
] ($grid)
|
||||
] if
|
||||
] assoc-each ;
|
||||
|
||||
: describe-summary ( vocab -- )
|
||||
vocab-summary [
|
||||
"Summary" $heading print-element
|
||||
] when* ;
|
||||
|
||||
TUPLE: vocab-tag name ;
|
||||
|
||||
C: <vocab-tag> vocab-tag
|
||||
|
||||
: tags. ( seq -- ) [ <vocab-tag> ] map $links ;
|
||||
|
||||
: describe-tags ( vocab -- )
|
||||
vocab-tags f like [
|
||||
"Tags" $heading tags.
|
||||
] when* ;
|
||||
|
||||
TUPLE: vocab-author name ;
|
||||
|
||||
C: <vocab-author> vocab-author
|
||||
|
||||
: authors. ( seq -- ) [ <vocab-author> ] map $links ;
|
||||
|
||||
: describe-authors ( vocab -- )
|
||||
vocab-authors f like [
|
||||
"Authors" $heading authors.
|
||||
] when* ;
|
||||
|
||||
: describe-help ( vocab -- )
|
||||
vocab-help [
|
||||
"Documentation" $heading nl ($link)
|
||||
] when* ;
|
||||
|
||||
: describe-children ( vocab -- )
|
||||
vocab-name all-child-vocabs vocabs. ;
|
||||
|
||||
: describe-files ( vocab -- )
|
||||
vocab-files [ <pathname> ] map [
|
||||
"Files" $heading
|
||||
[
|
||||
snippet-style get [
|
||||
code-style get [
|
||||
stack.
|
||||
] with-nesting
|
||||
] with-style
|
||||
] ($block)
|
||||
] when* ;
|
||||
|
||||
: describe-words ( vocab -- )
|
||||
words dup empty? [
|
||||
"Words" $heading
|
||||
dup natural-sort $links
|
||||
] unless drop ;
|
||||
|
||||
: map>set ( seq quot -- )
|
||||
map concat prune natural-sort ; inline
|
||||
|
||||
: vocab-xref ( vocab quot -- vocabs )
|
||||
>r dup vocab-name swap words r> map
|
||||
[ [ word? ] subset [ word-vocabulary ] map ] map>set
|
||||
remove [ ] subset [ vocab ] map ; inline
|
||||
|
||||
: vocab-uses ( vocab -- vocabs ) [ uses ] vocab-xref ;
|
||||
|
||||
: vocab-usage ( vocab -- vocabs ) [ usage ] vocab-xref ;
|
||||
|
||||
: describe-uses ( vocab -- )
|
||||
vocab-uses dup empty? [
|
||||
"Uses" $heading
|
||||
dup $links
|
||||
] unless drop ;
|
||||
|
||||
: describe-usage ( vocab -- )
|
||||
vocab-usage dup empty? [
|
||||
"Used by" $heading
|
||||
dup $links
|
||||
] unless drop ;
|
||||
|
||||
: $describe-vocab ( element -- )
|
||||
first
|
||||
dup describe-children
|
||||
dup vocab-root over vocab-dir? [
|
||||
dup describe-summary
|
||||
dup describe-tags
|
||||
dup describe-authors
|
||||
dup describe-files
|
||||
] when
|
||||
dup vocab [
|
||||
dup describe-help
|
||||
dup describe-words
|
||||
dup describe-uses
|
||||
dup describe-usage
|
||||
] when drop ;
|
||||
|
||||
: keyed-vocabs ( str quot -- seq )
|
||||
all-vocabs [
|
||||
swap >r
|
||||
[ >r 2dup r> swap call member? ] subset
|
||||
r> swap
|
||||
] assoc-map 2nip ; inline
|
||||
|
||||
: tagged ( tag -- assoc )
|
||||
[ vocab-tags ] keyed-vocabs ;
|
||||
|
||||
: authored ( author -- assoc )
|
||||
[ vocab-authors ] keyed-vocabs ;
|
||||
|
||||
: $tagged-vocabs ( element -- )
|
||||
first tagged vocabs. ;
|
||||
|
||||
MEMO: all-tags ( -- seq )
|
||||
all-vocabs-seq [ vocab-tags ] map>set ;
|
||||
|
||||
: $authored-vocabs ( element -- )
|
||||
first authored vocabs. ;
|
||||
|
||||
MEMO: all-authors ( -- seq )
|
||||
all-vocabs-seq [ vocab-authors ] map>set ;
|
||||
|
||||
: $tags ( element -- )
|
||||
drop "Tags" $heading all-tags tags. ;
|
||||
|
||||
: $authors ( element -- )
|
||||
drop "Authors" $heading all-authors authors. ;
|
||||
|
||||
M: vocab-spec article-title vocab-name " vocabulary" append ;
|
||||
|
||||
M: vocab-spec article-name vocab-name ;
|
||||
|
||||
M: vocab-spec article-content
|
||||
vocab-name \ $describe-vocab swap 2array ;
|
||||
|
||||
M: vocab-spec article-parent drop "vocab-index" ;
|
||||
|
||||
M: vocab-tag >link ;
|
||||
|
||||
M: vocab-tag article-title
|
||||
vocab-tag-name "Vocabularies tagged ``" swap "''" 3append ;
|
||||
|
||||
M: vocab-tag article-name vocab-tag-name ;
|
||||
|
||||
M: vocab-tag article-content
|
||||
\ $tagged-vocabs swap vocab-tag-name 2array ;
|
||||
|
||||
M: vocab-tag article-parent drop "vocab-index" ;
|
||||
|
||||
M: vocab-tag summary article-title ;
|
||||
|
||||
M: vocab-author >link ;
|
||||
|
||||
M: vocab-author article-title
|
||||
vocab-author-name "Vocabularies by " swap append ;
|
||||
|
||||
M: vocab-author article-name vocab-author-name ;
|
||||
|
||||
M: vocab-author article-content
|
||||
\ $authored-vocabs swap vocab-author-name 2array ;
|
||||
|
||||
M: vocab-author article-parent drop "vocab-index" ;
|
||||
|
||||
M: vocab-author summary article-title ;
|
||||
|
||||
: reset-cache ( -- )
|
||||
\ (vocab-file-contents) reset-memoized
|
||||
\ all-vocabs-seq reset-memoized
|
||||
\ all-authors reset-memoized
|
||||
\ all-tags reset-memoized ;
|
|
@ -34,31 +34,33 @@ IN: tools.deploy.backend
|
|||
|
||||
: ?, [ , ] [ drop ] if ;
|
||||
|
||||
: bootstrap-profile ( config -- profile )
|
||||
: bootstrap-profile ( -- profile )
|
||||
[
|
||||
[
|
||||
"math" deploy-math? get ?,
|
||||
"compiler" deploy-compiler? get ?,
|
||||
"ui" deploy-ui? get ?,
|
||||
"io" native-io? ?,
|
||||
] { } make
|
||||
] bind ;
|
||||
"math" deploy-math? get ?,
|
||||
"compiler" deploy-compiler? get ?,
|
||||
"ui" deploy-ui? get ?,
|
||||
"io" native-io? ?,
|
||||
] { } make ;
|
||||
|
||||
: staging-image-name ( profile -- name )
|
||||
"staging." swap bootstrap-profile "-" join ".image" 3append ;
|
||||
: staging-image-name ( -- name )
|
||||
"staging."
|
||||
bootstrap-profile strip-word-names? [ "strip" add ] when
|
||||
"-" join ".image" 3append ;
|
||||
|
||||
: staging-command-line ( config -- flags )
|
||||
[
|
||||
"-i=" my-boot-image-name append ,
|
||||
[
|
||||
"-i=" my-boot-image-name append ,
|
||||
|
||||
"-output-image=" over staging-image-name append ,
|
||||
"-output-image=" staging-image-name append ,
|
||||
|
||||
"-include=" swap bootstrap-profile " " join append ,
|
||||
"-include=" bootstrap-profile " " join append ,
|
||||
|
||||
"-no-stack-traces" ,
|
||||
strip-word-names? [ "-no-stack-traces" , ] when
|
||||
|
||||
"-no-user-init" ,
|
||||
] { } make ;
|
||||
"-no-user-init" ,
|
||||
] { } make
|
||||
] bind ;
|
||||
|
||||
: run-factor ( vm flags -- )
|
||||
swap add* dup . run-with-output ; inline
|
||||
|
@ -68,16 +70,18 @@ IN: tools.deploy.backend
|
|||
|
||||
: deploy-command-line ( image vocab config -- flags )
|
||||
[
|
||||
"-i=" swap staging-image-name append ,
|
||||
[
|
||||
"-i=" staging-image-name append ,
|
||||
|
||||
"-run=tools.deploy.shaker" ,
|
||||
"-run=tools.deploy.shaker" ,
|
||||
|
||||
"-deploy-vocab=" swap append ,
|
||||
"-deploy-vocab=" swap append ,
|
||||
|
||||
"-output-image=" swap append ,
|
||||
"-output-image=" swap append ,
|
||||
|
||||
"-no-stack-traces" ,
|
||||
] { } make ;
|
||||
strip-word-names? [ "-no-stack-traces" , ] when
|
||||
] { } make
|
||||
] bind ;
|
||||
|
||||
: make-deploy-image ( vm image vocab config -- )
|
||||
make-boot-image
|
||||
|
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: vocabs.loader io.files io kernel sequences assocs
|
||||
splitting parser prettyprint namespaces math vocabs
|
||||
hashtables tools.browser ;
|
||||
hashtables tools.vocabs ;
|
||||
IN: tools.deploy.config
|
||||
|
||||
SYMBOL: deploy-name
|
||||
|
|
|
@ -1,22 +1,44 @@
|
|||
IN: tools.deploy.tests
|
||||
USING: tools.test system io.files kernel tools.deploy.config
|
||||
tools.deploy.backend math ;
|
||||
tools.deploy.backend math sequences io.launcher ;
|
||||
|
||||
: shake-and-bake
|
||||
"." resource-path [
|
||||
vm
|
||||
"hello.image" temp-file
|
||||
"test.image" temp-file
|
||||
rot dup deploy-config make-deploy-image
|
||||
] with-directory ;
|
||||
|
||||
[ ] [ "hello-world" shake-and-bake ] unit-test
|
||||
|
||||
[ t ] [
|
||||
"hello.image" temp-file file-length 500000 <=
|
||||
"hello.image" temp-file file-info file-info-size 500000 <=
|
||||
] unit-test
|
||||
|
||||
[ ] [ "sudoku" shake-and-bake ] unit-test
|
||||
|
||||
[ t ] [
|
||||
"hello.image" temp-file file-info file-info-size 1500000 <=
|
||||
] unit-test
|
||||
|
||||
[ ] [ "hello-ui" shake-and-bake ] unit-test
|
||||
|
||||
[ t ] [
|
||||
"hello.image" temp-file file-length 2000000 <=
|
||||
"hello.image" temp-file file-info file-info-size 2000000 <=
|
||||
] unit-test
|
||||
|
||||
[ ] [ "bunny" shake-and-bake ] unit-test
|
||||
|
||||
[ t ] [
|
||||
"hello.image" temp-file file-info file-info-size 3000000 <=
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"tools.deploy.test.1" shake-and-bake
|
||||
vm "-i=" "test.image" temp-file append try-process
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"tools.deploy.test.2" shake-and-bake
|
||||
vm "-i=" "test.image" temp-file append try-process
|
||||
] unit-test
|
||||
|
|
|
@ -1,11 +1,29 @@
|
|||
! Copyright (C) 2007 Slava Pestov.
|
||||
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces continuations.private kernel.private init
|
||||
assocs kernel vocabs words sequences memory io system arrays
|
||||
continuations math definitions mirrors splitting parser classes
|
||||
inspector layouts vocabs.loader prettyprint.config prettyprint
|
||||
debugger io.streams.c io.streams.duplex io.files io.backend
|
||||
quotations words.private tools.deploy.config compiler.units ;
|
||||
USING: qualified io.streams.c init fry namespaces assocs kernel
|
||||
parser tools.deploy.config vocabs sequences words words.private
|
||||
memory kernel.private continuations io prettyprint
|
||||
vocabs.loader debugger system strings ;
|
||||
QUALIFIED: bootstrap.stage2
|
||||
QUALIFIED: classes
|
||||
QUALIFIED: compiler.errors.private
|
||||
QUALIFIED: compiler.units
|
||||
QUALIFIED: continuations
|
||||
QUALIFIED: definitions
|
||||
QUALIFIED: init
|
||||
QUALIFIED: inspector
|
||||
QUALIFIED: io.backend
|
||||
QUALIFIED: io.nonblocking
|
||||
QUALIFIED: io.thread
|
||||
QUALIFIED: layouts
|
||||
QUALIFIED: libc.private
|
||||
QUALIFIED: libc.private
|
||||
QUALIFIED: listener
|
||||
QUALIFIED: prettyprint.config
|
||||
QUALIFIED: random.private
|
||||
QUALIFIED: source-files
|
||||
QUALIFIED: threads
|
||||
QUALIFIED: vocabs
|
||||
IN: tools.deploy.shaker
|
||||
|
||||
: strip-init-hooks ( -- )
|
||||
|
@ -43,9 +61,6 @@ IN: tools.deploy.shaker
|
|||
run-file
|
||||
] when ;
|
||||
|
||||
: strip-assoc ( retained-keys assoc -- newassoc )
|
||||
swap [ nip member? ] curry assoc-subset ;
|
||||
|
||||
: strip-word-names ( words -- )
|
||||
"Stripping word names" show
|
||||
[ f over set-word-name f swap set-word-vocabulary ] each ;
|
||||
|
@ -57,8 +72,11 @@ IN: tools.deploy.shaker
|
|||
: strip-word-props ( retain-props words -- )
|
||||
"Stripping word properties" show
|
||||
[
|
||||
[ word-props strip-assoc f assoc-like ] keep
|
||||
set-word-props
|
||||
[
|
||||
word-props swap
|
||||
'[ , nip member? ] assoc-subset
|
||||
f assoc-like
|
||||
] keep set-word-props
|
||||
] with each ;
|
||||
|
||||
: retained-props ( -- seq )
|
||||
|
@ -81,10 +99,101 @@ IN: tools.deploy.shaker
|
|||
strip-word-names? [ dup strip-word-names ] when
|
||||
2drop ;
|
||||
|
||||
: strip-environment ( retain-globals -- )
|
||||
: strip-recompile-hook ( -- )
|
||||
[ [ f ] { } map>assoc ]
|
||||
compiler.units:recompile-hook
|
||||
set-global ;
|
||||
|
||||
: strip-vocab-globals ( except names -- words )
|
||||
[ child-vocabs [ words ] map concat ] map concat seq-diff ;
|
||||
|
||||
: stripped-globals ( -- seq )
|
||||
[
|
||||
random.private:mt ,
|
||||
|
||||
{
|
||||
bootstrap.stage2:bootstrap-time
|
||||
continuations:error
|
||||
continuations:error-continuation
|
||||
continuations:error-thread
|
||||
continuations:restarts
|
||||
error-hook
|
||||
init:init-hooks
|
||||
inspector:inspector-hook
|
||||
io.thread:io-thread
|
||||
libc.private:mallocs
|
||||
source-files:source-files
|
||||
stderr
|
||||
stdio
|
||||
} %
|
||||
|
||||
deploy-threads? [
|
||||
threads:initial-thread ,
|
||||
] unless
|
||||
|
||||
strip-io? [ io.backend:io-backend , ] when
|
||||
|
||||
{ io.backend:io-backend io.nonblocking:default-buffer-size }
|
||||
{ "alarms" "io" "tools" } strip-vocab-globals %
|
||||
|
||||
strip-dictionary? [
|
||||
{ } { "cpu" } strip-vocab-globals %
|
||||
|
||||
{
|
||||
vocabs:dictionary
|
||||
lexer-factory
|
||||
vocabs:load-vocab-hook
|
||||
layouts:num-tags
|
||||
layouts:num-types
|
||||
layouts:tag-mask
|
||||
layouts:tag-numbers
|
||||
layouts:type-numbers
|
||||
classes:typemap
|
||||
vocab-roots
|
||||
definitions:crossref
|
||||
compiled-crossref
|
||||
interactive-vocabs
|
||||
word
|
||||
compiler.units:recompile-hook
|
||||
listener:listener-hook
|
||||
lexer-factory
|
||||
classes:update-map
|
||||
classes:class<map
|
||||
} %
|
||||
] when
|
||||
|
||||
strip-prettyprint? [
|
||||
{
|
||||
prettyprint.config:margin
|
||||
prettyprint.config:string-limit
|
||||
prettyprint.config:tab-size
|
||||
} %
|
||||
] when
|
||||
|
||||
strip-debugger? [
|
||||
{
|
||||
compiler.errors.private:compiler-errors
|
||||
continuations:thread-error-hook
|
||||
} %
|
||||
] when
|
||||
|
||||
deploy-c-types? get [
|
||||
"c-types" "alien.c-types" lookup ,
|
||||
] unless
|
||||
|
||||
deploy-ui? get [
|
||||
"ui-error-hook" "ui.gadgets.worlds" lookup ,
|
||||
] when
|
||||
] { } make ;
|
||||
|
||||
: strip-globals ( stripped-globals -- )
|
||||
strip-globals? [
|
||||
"Stripping environment" show
|
||||
global strip-assoc 21 setenv
|
||||
"Stripping globals" show
|
||||
global swap
|
||||
'[ drop , member? not ] assoc-subset
|
||||
[ drop string? not ] assoc-subset ! strip CLI args
|
||||
dup keys .
|
||||
21 setenv
|
||||
] [ drop ] if ;
|
||||
|
||||
: finish-deploy ( final-image -- )
|
||||
|
@ -108,55 +217,6 @@ SYMBOL: deploy-vocab
|
|||
] [ ] make "Boot quotation: " write dup . flush
|
||||
set-boot-quot ;
|
||||
|
||||
: retained-globals ( -- seq )
|
||||
[
|
||||
builtins ,
|
||||
strip-io? [ io-backend , ] unless
|
||||
|
||||
strip-dictionary? [
|
||||
{
|
||||
dictionary
|
||||
inspector-hook
|
||||
lexer-factory
|
||||
load-vocab-hook
|
||||
num-tags
|
||||
num-types
|
||||
tag-bits
|
||||
tag-mask
|
||||
tag-numbers
|
||||
typemap
|
||||
vocab-roots
|
||||
} %
|
||||
] unless
|
||||
|
||||
strip-prettyprint? [
|
||||
{
|
||||
tab-size
|
||||
margin
|
||||
} %
|
||||
] unless
|
||||
|
||||
deploy-c-types? get [
|
||||
"c-types" "alien.c-types" lookup ,
|
||||
] when
|
||||
|
||||
native-io? [
|
||||
"default-buffer-size" "io.nonblocking" lookup ,
|
||||
] when
|
||||
|
||||
deploy-ui? get [
|
||||
"ui" child-vocabs
|
||||
"cocoa" child-vocabs
|
||||
deploy-vocab get child-vocabs 3append
|
||||
global keys [ word? ] subset
|
||||
swap [ >r word-vocabulary r> member? ] curry
|
||||
subset %
|
||||
] when
|
||||
] { } make dup . ;
|
||||
|
||||
: strip-recompile-hook ( -- )
|
||||
[ [ f ] { } map>assoc ] recompile-hook set-global ;
|
||||
|
||||
: strip ( -- )
|
||||
strip-libc
|
||||
strip-cocoa
|
||||
|
@ -165,7 +225,7 @@ SYMBOL: deploy-vocab
|
|||
strip-init-hooks
|
||||
deploy-vocab get vocab-main set-boot-quot*
|
||||
retained-props >r
|
||||
retained-globals strip-environment
|
||||
stripped-globals strip-globals
|
||||
r> strip-words ;
|
||||
|
||||
: (deploy) ( final-image vocab config -- )
|
||||
|
|
|
@ -0,0 +1,6 @@
|
|||
IN: tools.deploy.test.1
|
||||
USING: threads ;
|
||||
|
||||
: deploy-test-1 1000 sleep ;
|
||||
|
||||
MAIN: deploy-test-1
|
|
@ -0,0 +1,14 @@
|
|||
USING: tools.deploy.config ;
|
||||
H{
|
||||
{ deploy-c-types? f }
|
||||
{ deploy-io 2 }
|
||||
{ deploy-reflection 1 }
|
||||
{ deploy-threads? t }
|
||||
{ deploy-word-props? f }
|
||||
{ deploy-word-defs? f }
|
||||
{ deploy-name "tools.deploy.test.1" }
|
||||
{ deploy-math? t }
|
||||
{ deploy-compiler? t }
|
||||
{ "stop-after-last-window?" t }
|
||||
{ deploy-ui? f }
|
||||
}
|
|
@ -0,0 +1,6 @@
|
|||
IN: tools.deploy.test.2
|
||||
USING: calendar calendar.format ;
|
||||
|
||||
: deploy-test-2 now (timestamp>string) ;
|
||||
|
||||
MAIN: deploy-test-2
|
|
@ -0,0 +1,14 @@
|
|||
USING: tools.deploy.config ;
|
||||
H{
|
||||
{ deploy-c-types? f }
|
||||
{ deploy-io 2 }
|
||||
{ deploy-reflection 1 }
|
||||
{ deploy-threads? t }
|
||||
{ deploy-word-props? f }
|
||||
{ deploy-word-defs? f }
|
||||
{ deploy-name "tools.deploy.test.2" }
|
||||
{ deploy-math? t }
|
||||
{ deploy-compiler? t }
|
||||
{ "stop-after-last-window?" t }
|
||||
{ deploy-ui? f }
|
||||
}
|
|
@ -0,0 +1,8 @@
|
|||
IN: tools.deploy.test.3
|
||||
USING: io.encodings.ascii io.files kernel ;
|
||||
|
||||
: deploy-test-3
|
||||
"resource:extra/tools/deploy/test/3/3.factor"
|
||||
?resource-path ascii file-contents drop ;
|
||||
|
||||
MAIN: deploy-test-3
|
|
@ -0,0 +1,14 @@
|
|||
USING: tools.deploy.config ;
|
||||
H{
|
||||
{ deploy-math? t }
|
||||
{ deploy-reflection 1 }
|
||||
{ deploy-name "tools.deploy.test.3" }
|
||||
{ deploy-threads? t }
|
||||
{ deploy-word-props? f }
|
||||
{ "stop-after-last-window?" t }
|
||||
{ deploy-ui? f }
|
||||
{ deploy-io 3 }
|
||||
{ deploy-compiler? t }
|
||||
{ deploy-word-defs? f }
|
||||
{ deploy-c-types? f }
|
||||
}
|
|
@ -0,0 +1,6 @@
|
|||
IN: tools.disassembler.tests
|
||||
USING: math tuples prettyprint.backend tools.disassembler
|
||||
tools.test strings ;
|
||||
|
||||
[ ] [ \ + disassemble ] unit-test
|
||||
[ ] [ { string pprint* } disassemble ] unit-test
|
|
@ -2,7 +2,8 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io.files io words alien kernel math.parser alien.syntax
|
||||
io.launcher system assocs arrays sequences namespaces qualified
|
||||
system math generator.fixup io.encodings.ascii accessors ;
|
||||
system math generator.fixup io.encodings.ascii accessors
|
||||
generic ;
|
||||
IN: tools.disassembler
|
||||
|
||||
: in-file "gdb-in.txt" temp-file ;
|
||||
|
@ -22,6 +23,9 @@ M: pair make-disassemble-cmd
|
|||
[ number>string write bl ] each
|
||||
] with-file-writer ;
|
||||
|
||||
M: method-spec make-disassemble-cmd
|
||||
first2 method make-disassemble-cmd ;
|
||||
|
||||
: run-gdb ( -- lines )
|
||||
<process>
|
||||
+closed+ >>stdin
|
||||
|
|
|
@ -4,7 +4,7 @@ USING: namespaces arrays prettyprint sequences kernel
|
|||
vectors quotations words parser assocs combinators
|
||||
continuations debugger io io.files vocabs tools.time
|
||||
vocabs.loader source-files compiler.units inspector
|
||||
inference effects ;
|
||||
inference effects tools.vocabs ;
|
||||
IN: tools.test
|
||||
|
||||
SYMBOL: failures
|
||||
|
|
|
@ -0,0 +1,7 @@
|
|||
USING: help.markup help.syntax io strings ;
|
||||
IN: tools.vocabs.browser
|
||||
|
||||
ARTICLE: "vocab-index" "Vocabulary index"
|
||||
{ $tags }
|
||||
{ $authors }
|
||||
{ $describe-vocab "" } ;
|
|
@ -0,0 +1,4 @@
|
|||
IN: tools.vocabs.browser.tests
|
||||
USING: tools.vocabs.browser tools.test help.markup ;
|
||||
|
||||
[ ] [ { $describe-vocab "scratchpad" } print-content ] unit-test
|
|
@ -0,0 +1,207 @@
|
|||
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel combinators vocabs vocabs.loader tools.vocabs io
|
||||
io.files io.styles help.markup help.stylesheet sequences assocs
|
||||
help.topics namespaces prettyprint words sorting definitions
|
||||
arrays inspector ;
|
||||
IN: tools.vocabs.browser
|
||||
|
||||
: vocab-status-string ( vocab -- string )
|
||||
{
|
||||
{ [ dup not ] [ drop "" ] }
|
||||
{ [ dup vocab-main ] [ drop "[Runnable]" ] }
|
||||
{ [ t ] [ drop "[Loaded]" ] }
|
||||
} cond ;
|
||||
|
||||
: write-status ( vocab -- )
|
||||
vocab vocab-status-string write ;
|
||||
|
||||
: vocab. ( vocab -- )
|
||||
[
|
||||
dup [ write-status ] with-cell
|
||||
dup [ ($link) ] with-cell
|
||||
[ vocab-summary write ] with-cell
|
||||
] with-row ;
|
||||
|
||||
: vocab-headings. ( -- )
|
||||
[
|
||||
[ "State" write ] with-cell
|
||||
[ "Vocabulary" write ] with-cell
|
||||
[ "Summary" write ] with-cell
|
||||
] with-row ;
|
||||
|
||||
: root-heading. ( root -- )
|
||||
[ "Children from " swap append ] [ "Children" ] if*
|
||||
$heading ;
|
||||
|
||||
: vocabs. ( assoc -- )
|
||||
[
|
||||
dup empty? [
|
||||
2drop
|
||||
] [
|
||||
swap root-heading.
|
||||
standard-table-style [
|
||||
vocab-headings. [ vocab. ] each
|
||||
] ($grid)
|
||||
] if
|
||||
] assoc-each ;
|
||||
|
||||
: describe-summary ( vocab -- )
|
||||
vocab-summary [
|
||||
"Summary" $heading print-element
|
||||
] when* ;
|
||||
|
||||
TUPLE: vocab-tag name ;
|
||||
|
||||
INSTANCE: vocab-tag topic
|
||||
|
||||
C: <vocab-tag> vocab-tag
|
||||
|
||||
: tags. ( seq -- ) [ <vocab-tag> ] map $links ;
|
||||
|
||||
: describe-tags ( vocab -- )
|
||||
vocab-tags f like [
|
||||
"Tags" $heading tags.
|
||||
] when* ;
|
||||
|
||||
TUPLE: vocab-author name ;
|
||||
|
||||
INSTANCE: vocab-author topic
|
||||
|
||||
C: <vocab-author> vocab-author
|
||||
|
||||
: authors. ( seq -- ) [ <vocab-author> ] map $links ;
|
||||
|
||||
: describe-authors ( vocab -- )
|
||||
vocab-authors f like [
|
||||
"Authors" $heading authors.
|
||||
] when* ;
|
||||
|
||||
: describe-help ( vocab -- )
|
||||
vocab-help [
|
||||
"Documentation" $heading nl ($link)
|
||||
] when* ;
|
||||
|
||||
: describe-children ( vocab -- )
|
||||
vocab-name all-child-vocabs vocabs. ;
|
||||
|
||||
: describe-files ( vocab -- )
|
||||
vocab-files [ <pathname> ] map [
|
||||
"Files" $heading
|
||||
[
|
||||
snippet-style get [
|
||||
code-style get [
|
||||
stack.
|
||||
] with-nesting
|
||||
] with-style
|
||||
] ($block)
|
||||
] when* ;
|
||||
|
||||
: describe-words ( vocab -- )
|
||||
words dup empty? [
|
||||
"Words" $heading
|
||||
dup natural-sort $links
|
||||
] unless drop ;
|
||||
|
||||
: vocab-xref ( vocab quot -- vocabs )
|
||||
>r dup vocab-name swap words r> map
|
||||
[ [ word? ] subset [ word-vocabulary ] map ] map>set
|
||||
remove [ ] subset [ vocab ] map ; inline
|
||||
|
||||
: vocab-uses ( vocab -- vocabs ) [ uses ] vocab-xref ;
|
||||
|
||||
: vocab-usage ( vocab -- vocabs ) [ usage ] vocab-xref ;
|
||||
|
||||
: describe-uses ( vocab -- )
|
||||
vocab-uses dup empty? [
|
||||
"Uses" $heading
|
||||
dup $links
|
||||
] unless drop ;
|
||||
|
||||
: describe-usage ( vocab -- )
|
||||
vocab-usage dup empty? [
|
||||
"Used by" $heading
|
||||
dup $links
|
||||
] unless drop ;
|
||||
|
||||
: $describe-vocab ( element -- )
|
||||
first
|
||||
dup describe-children
|
||||
dup vocab-root over vocab-dir? [
|
||||
dup describe-summary
|
||||
dup describe-tags
|
||||
dup describe-authors
|
||||
dup describe-files
|
||||
] when
|
||||
dup vocab [
|
||||
dup describe-help
|
||||
dup describe-words
|
||||
dup describe-uses
|
||||
dup describe-usage
|
||||
] when drop ;
|
||||
|
||||
: keyed-vocabs ( str quot -- seq )
|
||||
all-vocabs [
|
||||
swap >r
|
||||
[ >r 2dup r> swap call member? ] subset
|
||||
r> swap
|
||||
] assoc-map 2nip ; inline
|
||||
|
||||
: tagged ( tag -- assoc )
|
||||
[ vocab-tags ] keyed-vocabs ;
|
||||
|
||||
: authored ( author -- assoc )
|
||||
[ vocab-authors ] keyed-vocabs ;
|
||||
|
||||
: $tagged-vocabs ( element -- )
|
||||
first tagged vocabs. ;
|
||||
|
||||
: $authored-vocabs ( element -- )
|
||||
first authored vocabs. ;
|
||||
|
||||
: $tags ( element -- )
|
||||
drop "Tags" $heading all-tags tags. ;
|
||||
|
||||
: $authors ( element -- )
|
||||
drop "Authors" $heading all-authors authors. ;
|
||||
|
||||
INSTANCE: vocab topic
|
||||
|
||||
INSTANCE: vocab-link topic
|
||||
|
||||
M: vocab-spec article-title vocab-name " vocabulary" append ;
|
||||
|
||||
M: vocab-spec article-name vocab-name ;
|
||||
|
||||
M: vocab-spec article-content
|
||||
vocab-name \ $describe-vocab swap 2array ;
|
||||
|
||||
M: vocab-spec article-parent drop "vocab-index" ;
|
||||
|
||||
M: vocab-tag >link ;
|
||||
|
||||
M: vocab-tag article-title
|
||||
vocab-tag-name "Vocabularies tagged ``" swap "''" 3append ;
|
||||
|
||||
M: vocab-tag article-name vocab-tag-name ;
|
||||
|
||||
M: vocab-tag article-content
|
||||
\ $tagged-vocabs swap vocab-tag-name 2array ;
|
||||
|
||||
M: vocab-tag article-parent drop "vocab-index" ;
|
||||
|
||||
M: vocab-tag summary article-title ;
|
||||
|
||||
M: vocab-author >link ;
|
||||
|
||||
M: vocab-author article-title
|
||||
vocab-author-name "Vocabularies by " swap append ;
|
||||
|
||||
M: vocab-author article-name vocab-author-name ;
|
||||
|
||||
M: vocab-author article-content
|
||||
\ $authored-vocabs swap vocab-author-name 2array ;
|
||||
|
||||
M: vocab-author article-parent drop "vocab-index" ;
|
||||
|
||||
M: vocab-author summary article-title ;
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: threads io.files io.monitors init kernel
|
||||
tools.browser namespaces continuations vocabs.loader ;
|
||||
IN: vocabs.monitor
|
||||
vocabs.loader tools.vocabs namespaces continuations ;
|
||||
IN: tools.vocabs.monitor
|
||||
|
||||
! Use file system change monitoring to flush the tags/authors
|
||||
! cache
|
||||
|
@ -21,4 +21,4 @@ SYMBOL: vocab-monitor
|
|||
[ monitor-thread t ] "Vocabulary monitor" spawn-server drop
|
||||
] ignore-errors ;
|
||||
|
||||
[ start-monitor-thread ] "vocabs.monitor" add-init-hook
|
||||
[ start-monitor-thread ] "tools.vocabs.monitor" add-init-hook
|
|
@ -1,52 +1,75 @@
|
|||
USING: help.markup help.syntax io strings ;
|
||||
IN: tools.browser
|
||||
|
||||
ARTICLE: "vocab-index" "Vocabulary index"
|
||||
{ $tags }
|
||||
{ $authors }
|
||||
{ $describe-vocab "" } ;
|
||||
|
||||
ARTICLE: "tools.browser" "Vocabulary browser"
|
||||
"Getting and setting vocabulary meta-data:"
|
||||
{ $subsection vocab-file-contents }
|
||||
{ $subsection set-vocab-file-contents }
|
||||
{ $subsection vocab-summary }
|
||||
{ $subsection set-vocab-summary }
|
||||
{ $subsection vocab-tags }
|
||||
{ $subsection set-vocab-tags }
|
||||
{ $subsection add-vocab-tags }
|
||||
"Global meta-data:"
|
||||
{ $subsection all-vocabs }
|
||||
{ $subsection all-vocabs-seq }
|
||||
{ $subsection all-tags }
|
||||
{ $subsection all-authors }
|
||||
"Because loading the above data is expensive, it is cached. The cache is flushed by the " { $vocab-link "vocabs.monitor" } " vocabulary. It can also be flushed manually when file system change monitors are not available:"
|
||||
{ $subsection reset-cache } ;
|
||||
|
||||
HELP: vocab-file-contents
|
||||
{ $values { "vocab" "a vocabulary specifier" } { "name" string } { "seq" "a sequence of lines, or " { $link f } } }
|
||||
{ $description "Outputs the contents of the file named " { $snippet "name" } " from the vocabulary's directory, or " { $link f } " if the file does not exist." } ;
|
||||
|
||||
HELP: set-vocab-file-contents
|
||||
{ $values { "seq" "a sequence of lines" } { "vocab" "a vocabulary specifier" } { "name" string } }
|
||||
{ $description "Stores a sequence of lines to the file named " { $snippet "name" } " from the vocabulary's directory." } ;
|
||||
|
||||
HELP: vocab-summary
|
||||
{ $values { "vocab" "a vocabulary specifier" } { "summary" "a string or " { $link f } } }
|
||||
{ $description "Outputs a one-line string description of the vocabulary's intended purpose from the " { $snippet "summary.txt" } " file in the vocabulary's directory. Outputs " { $link f } " if the file does not exist." } ;
|
||||
|
||||
HELP: set-vocab-summary
|
||||
{ $values { "string" "a string or " { $link f } } { "vocab" "a vocabulary specifier" } }
|
||||
{ $description "Stores a one-line string description of the vocabulary to the " { $snippet "summary.txt" } " file in the vocabulary's directory." } ;
|
||||
|
||||
HELP: vocab-tags
|
||||
{ $values { "vocab" "a vocabulary specifier" } { "tags" "a sequence of strings" } }
|
||||
{ $description "Outputs a list of short tags classifying the vocabulary from the " { $snippet "tags.txt" } " file in the vocabulary's directory. Outputs " { $link f } " if the file does not exist." } ;
|
||||
|
||||
HELP: set-vocab-tags
|
||||
{ $values { "tags" "a sequence of strings" } { "vocab" "a vocabulary specifier" } }
|
||||
{ $description "Stores a list of short tags classifying the vocabulary to the " { $snippet "tags.txt" } " file in the vocabulary's directory." } ;
|
||||
|
||||
HELP: all-vocabs
|
||||
{ $values { "assoc" "an association list mapping vocabulary roots to sequences of vocabulary specifiers" } }
|
||||
{ $description "Outputs an association list of all vocabularies which have been loaded or are available for loading." } ;
|
||||
USING: help.markup help.syntax strings ;
|
||||
IN: tools.vocabs
|
||||
|
||||
ARTICLE: "tools.vocabs" "Vocabulary tools"
|
||||
"Reloading source files changed on disk:"
|
||||
{ $subsection refresh }
|
||||
{ $subsection refresh-all }
|
||||
"Vocabulary summaries:"
|
||||
{ $subsection vocab-summary }
|
||||
{ $subsection set-vocab-summary }
|
||||
"Vocabulary tags:"
|
||||
{ $subsection vocab-tags }
|
||||
{ $subsection set-vocab-tags }
|
||||
{ $subsection add-vocab-tags }
|
||||
"Getting and setting vocabulary meta-data:"
|
||||
{ $subsection vocab-file-contents }
|
||||
{ $subsection set-vocab-file-contents }
|
||||
"Global meta-data:"
|
||||
{ $subsection all-vocabs }
|
||||
{ $subsection all-vocabs-seq }
|
||||
{ $subsection all-tags }
|
||||
{ $subsection all-authors }
|
||||
"Because loading the above data is expensive, it is cached. The cache is flushed by the " { $vocab-link "tools.vocabs.monitor" } " vocabulary. It can also be flushed manually when file system change monitors are not available:"
|
||||
{ $subsection reset-cache } ;
|
||||
|
||||
ABOUT: "tools.vocabs"
|
||||
|
||||
HELP: vocab-files
|
||||
{ $values { "vocab" "a vocabulary specifier" } { "seq" "a sequence of pathname strings" } }
|
||||
{ $description "Outputs a sequence of files comprising this vocabulary, or " { $link f } " if the vocabulary does not have a directory on disk." } ;
|
||||
|
||||
HELP: vocab-tests
|
||||
{ $values { "vocab" "a vocabulary specifier" } { "tests" "a sequence of pathname strings" } }
|
||||
{ $description "Outputs a sequence of pathnames where the unit tests for " { $snippet "vocab" } " are located." } ;
|
||||
|
||||
HELP: source-modified?
|
||||
{ $values { "path" "a pathname string" } { "?" "a boolean" } }
|
||||
{ $description "Tests if the source file has been modified since it was last loaded. This compares the file's CRC32 checksum of the file's contents against the previously-recorded value." } ;
|
||||
|
||||
HELP: refresh
|
||||
{ $values { "prefix" string } }
|
||||
{ $description "Reloads source files and documentation belonging to loaded vocabularies whose names are prefixed by " { $snippet "prefix" } " which have been modified on disk." } ;
|
||||
|
||||
HELP: refresh-all
|
||||
{ $description "Reloads source files and documentation for all loaded vocabularies which have been modified on disk." } ;
|
||||
|
||||
{ refresh refresh-all } related-words
|
||||
|
||||
HELP: vocab-file-contents
|
||||
{ $values { "vocab" "a vocabulary specifier" } { "name" string } { "seq" "a sequence of lines, or " { $link f } } }
|
||||
{ $description "Outputs the contents of the file named " { $snippet "name" } " from the vocabulary's directory, or " { $link f } " if the file does not exist." } ;
|
||||
|
||||
HELP: set-vocab-file-contents
|
||||
{ $values { "seq" "a sequence of lines" } { "vocab" "a vocabulary specifier" } { "name" string } }
|
||||
{ $description "Stores a sequence of lines to the file named " { $snippet "name" } " from the vocabulary's directory." } ;
|
||||
|
||||
HELP: vocab-summary
|
||||
{ $values { "vocab" "a vocabulary specifier" } { "summary" "a string or " { $link f } } }
|
||||
{ $description "Outputs a one-line string description of the vocabulary's intended purpose from the " { $snippet "summary.txt" } " file in the vocabulary's directory. Outputs " { $link f } " if the file does not exist." } ;
|
||||
|
||||
HELP: set-vocab-summary
|
||||
{ $values { "string" "a string or " { $link f } } { "vocab" "a vocabulary specifier" } }
|
||||
{ $description "Stores a one-line string description of the vocabulary to the " { $snippet "summary.txt" } " file in the vocabulary's directory." } ;
|
||||
|
||||
HELP: vocab-tags
|
||||
{ $values { "vocab" "a vocabulary specifier" } { "tags" "a sequence of strings" } }
|
||||
{ $description "Outputs a list of short tags classifying the vocabulary from the " { $snippet "tags.txt" } " file in the vocabulary's directory. Outputs " { $link f } " if the file does not exist." } ;
|
||||
|
||||
HELP: set-vocab-tags
|
||||
{ $values { "tags" "a sequence of strings" } { "vocab" "a vocabulary specifier" } }
|
||||
{ $description "Stores a list of short tags classifying the vocabulary to the " { $snippet "tags.txt" } " file in the vocabulary's directory." } ;
|
||||
|
||||
HELP: all-vocabs
|
||||
{ $values { "assoc" "an association list mapping vocabulary roots to sequences of vocabulary specifiers" } }
|
||||
{ $description "Outputs an association list of all vocabularies which have been loaded or are available for loading." } ;
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue