alien.structs alien.syntax cpu.architecture alien inspector
quotations assocs kernel.private threads continuations.private
libc combinators compiler.errors continuations layouts accessors
-;
+init ;
IN: alien.compiler
TUPLE: #alien-node < node return parameters abi ;
! this hashtable, they will all be blown away by code GC, beware
SYMBOL: callbacks
-callbacks global [ H{ } assoc-like ] change-at
+[ H{ } clone callbacks set-global ] "alien.compiler" add-init-hook
: register-callback ( word -- ) dup callbacks get set-at ;
drop "Words calling ``alien-callback'' must be compiled with the optimizing compiler." ;
: callback-bottom ( node -- )
- xt>> [ word-xt drop <alien> ] curry
+ xt>> [ [ register-callback ] [ word-xt drop <alien> ] bi ] curry
recursive-state get infer-quot ;
\ alien-callback [
pop-literal nip >>abi
pop-parameters >>parameters
pop-literal nip >>return
- gensym dup register-callback >>xt
+ gensym >>xt
callback-bottom
] "infer" set-word-prop
ARTICLE: "c-unions" "C unions"
"A " { $snippet "union" } " in C defines a type large enough to hold its largest member. This is usually used to allocate a block of memory which can hold one of several types of values."
{ $subsection POSTPONE: C-UNION: }
-"C structure objects can be allocated by calling " { $link <c-object> } " or " { $link malloc-object } "."
+"C union objects can be allocated by calling " { $link <c-object> } " or " { $link malloc-object } "."
$nl
"Arrays of C unions can be created by calling " { $link <c-array> } " or " { $link malloc-array } ". Elements can be read and written using words named " { $snippet { $emphasis "type" } "-nth" } " and " { $snippet "set-" { $emphasis "type" } "-nth" } "; these words are automatically generated by " { $link POSTPONE: C-UNION: } "." ;
2drop
] { } make
] unit-test
+
+[
+ H{
+ { "bangers" "mash" }
+ { "fries" "onion rings" }
+ }
+] [
+ { "bangers" "fries" } H{
+ { "fish" "chips" }
+ { "bangers" "mash" }
+ { "fries" "onion rings" }
+ { "nachos" "cheese" }
+ } extract-keys
+] unit-test
: map>assoc ( seq quot exemplar -- assoc )
>r [ 2array ] compose { } map-as r> assoc-like ; inline
+: extract-keys ( seq assoc -- subassoc )
+ [ [ dupd at ] curry ] keep map>assoc ;
+
M: assoc >alist [ 2array ] { } assoc>map ;
: value-at ( value assoc -- key/f )
[ t ] [ 3 number instance? ] unit-test
[ f ] [ 3 null instance? ] unit-test
[ t ] [ "hi" \ hi-tag instance? ] unit-test
+
+! Regression
+GENERIC: method-forget-test
+TUPLE: method-forget-class ;
+M: method-forget-class method-forget-test ;
+
+[ f ] [ \ method-forget-test "methods" word-prop assoc-empty? ] unit-test
+[ ] [ [ \ method-forget-class forget ] with-compilation-unit ] unit-test
+[ t ] [ \ method-forget-test "methods" word-prop assoc-empty? ] unit-test
generic.standard effects classes.tuple classes.tuple.private
arrays vectors strings compiler.units accessors classes.algebra
calendar prettyprint io.streams.string splitting inspector
-columns math.order ;
+columns math.order classes.private ;
IN: classes.tuple.tests
TUPLE: rect x y w h ;
! Missing error check
[ "IN: classes.tuple.tests USE: words TUPLE: wrong-superclass < word ;" eval ] must-fail
+! Class forget messyness
TUPLE: subclass-forget-test ;
TUPLE: subclass-forget-test-1 < subclass-forget-test ;
[ ] [ "IN: classes.tuple.tests FORGET: subclass-forget-test" eval ] unit-test
+[ H{ { subclass-forget-test-2 subclass-forget-test-2 } } ]
+[ subclass-forget-test-2 class-usages ]
+unit-test
+
+[ H{ { subclass-forget-test-3 subclass-forget-test-3 } } ]
+[ subclass-forget-test-3 class-usages ]
+unit-test
+
[ f ] [ subclass-forget-test-1 tuple-class? ] unit-test
[ f ] [ subclass-forget-test-2 tuple-class? ] unit-test
[ subclass-forget-test-3 new ] must-fail
} reset-props
] bi ;
-: reset-tuple-class ( class -- )
- [ [ reset-class ] [ update-map- ] bi ] each-subclass ;
-
-M: tuple-class forget*
- [ reset-tuple-class ] [ call-next-method ] bi ;
-
M: tuple-class rank-class drop 0 ;
M: tuple clone
{ $subsection alist>quot } ;
ARTICLE: "combinators" "Additional combinators"
-"The " { $vocab-link "combinators" } " vocabulary provides generalizations of certain combinators from the " { $vocab-link "kernel" } " vocabulary."
+"The " { $vocab-link "combinators" } " vocabulary provides a few useful combinators."
$nl
+"A looping combinator:"
+{ $subsection while }
"Generalization of " { $link bi } " and " { $link tri } ":"
{ $subsection cleave }
"Generalization of " { $link bi* } " and " { $link tri* } ":"
: (distribute-buckets) ( buckets pair keys -- )
dup t eq? [
- drop [ swap push-new ] curry each
+ drop [ swap adjoin ] curry each
] [
[
- >r 2dup r> hashcode pick length rem rot nth push-new
+ >r 2dup r> hashcode pick length rem rot nth adjoin
] each 2drop
] if ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel continuations assocs namespaces sequences words
-vocabs definitions hashtables init ;
+vocabs definitions hashtables init sets ;
IN: compiler.units
SYMBOL: old-definitions
{ { "Continue" t } } throw-restarts drop ;
: add-once ( key assoc -- )
- 2dup key? [ over redefine-error ] when dupd set-at ;
+ 2dup key? [ over redefine-error ] when conjoin ;
: (remember-definition) ( definition loc assoc -- )
>r over set-where r> add-once ;
call-recompile-hook
call-update-tuples-hook
dup [ drop compiled-crossref? ] assoc-contains? modify-code-heap
- updated-definitions notify-definition-observers ;
+ ;
+
+: with-nested-compilation-unit ( quot -- )
+ [
+ H{ } clone changed-definitions set
+ H{ } clone outdated-tuples set
+ [ finish-compilation-unit ] [ ] cleanup
+ ] with-scope ; inline
: with-compilation-unit ( quot -- )
[
H{ } clone outdated-tuples set
<definitions> new-definitions set
<definitions> old-definitions set
- [ finish-compilation-unit ]
- [ ] cleanup
+ [
+ finish-compilation-unit
+ updated-definitions
+ notify-definition-observers
+ ] [ ] cleanup
] with-scope ; inline
: compile-call ( quot -- )
-USING: help.syntax help.markup generator.fixup math kernel
+USING: help.syntax help.markup math kernel
words strings alien ;
+IN: generator.fixup
HELP: frame-required
{ $values { "n" "a non-negative integer" } }
{ $description "Notify the code generator that the currently compiling code block needs a stack frame with room for at least " { $snippet "n" } " parameters." } ;
-HELP: (rel-fixup)
-{ $values { "arg" integer } { "class" "a relocation class" } { "type" "a relocation type" } { "offset" integer } { "pair" "a pair of integers" } }
-{ $description "Creates a relocation instruction for the VM's runtime compiled code linker." } ;
-
HELP: add-literal
{ $values { "obj" object } { "n" integer } }
{ $description "Adds a literal to the " { $link literal-table } ", if it is not already there, and outputs the index of the literal in the table. This literal can then be used as an argument for a " { $link rt-literal } " relocation with " { $link rel-fixup } "." } ;
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays generic assocs hashtables
+USING: arrays byte-arrays generic assocs hashtables io.binary
kernel kernel.private math namespaces sequences words
-quotations strings alien.strings layouts system combinators
-math.bitfields words.private cpu.architecture math.order ;
+quotations strings alien.accessors alien.strings layouts system
+combinators math.bitfields words.private cpu.architecture
+math.order accessors growable ;
IN: generator.fixup
: no-stack-frame -1 ; inline
: label-fixup ( label class -- ) \ label-fixup boa , ;
M: label-fixup fixup*
- dup label-fixup-class rc-absolute?
+ dup class>> rc-absolute?
[ "Absolute labels not supported" throw ] when
- dup label-fixup-label swap label-fixup-class
- compiled-offset 4 - rot 3array label-table get push ;
+ dup label>> swap class>> compiled-offset 4 - rot
+ 3array label-table get push ;
TUPLE: rel-fixup arg class type ;
: rel-fixup ( arg class type -- ) \ rel-fixup boa , ;
-: (rel-fixup) ( arg class type offset -- pair )
- pick rc-absolute-cell = cell 4 ? -
- >r { 0 8 16 } bitfield r>
- 2array ;
+: push-4 ( value vector -- )
+ [ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying ] tri
+ swap set-alien-unsigned-4 ;
M: rel-fixup fixup*
- dup rel-fixup-arg
- over rel-fixup-class
- rot rel-fixup-type
- compiled-offset (rel-fixup)
- relocation-table get push-all ;
+ [ [ arg>> ] [ class>> ] [ type>> ] tri { 0 8 16 } bitfield ]
+ [ class>> rc-absolute-cell = cell 4 ? compiled-offset swap - ] bi
+ [ relocation-table get push-4 ] bi@ ;
M: frame-required fixup* drop ;
M: integer fixup* , ;
-: push-new* ( obj table -- n )
+: adjoin* ( obj table -- n )
2dup swap [ eq? ] curry find drop
[ 2nip ] [ dup length >r push r> ] if* ;
SYMBOL: literal-table
-: add-literal ( obj -- n ) literal-table get push-new* ;
+: add-literal ( obj -- n ) literal-table get adjoin* ;
: add-dlsym-literals ( symbol dll -- )
>r string>symbol r> 2array literal-table get push-all ;
0 swap rt-here rel-fixup ;
: init-fixup ( -- )
- V{ } clone relocation-table set
+ BV{ } clone relocation-table set
V{ } clone label-table set ;
: resolve-labels ( labels -- labels' )
dup stack-frame-size swap [ fixup* ] each drop
literal-table get >array
- relocation-table get >array
+ relocation-table get >byte-array
label-table get resolve-labels
] { } make ;
[ implementors ] [ [ swap 2array ] curry ] bi map forget-all ;
M: class forget* ( class -- )
- {
- [ forget-methods ]
- [ update-map- ]
- [ reset-class ]
- [ call-next-method ]
- } cleave ;
+ [
+ class-usages [
+ drop
+ [ forget-methods ]
+ [ update-map- ]
+ [ reset-class ]
+ tri
+ ] assoc-each
+ ]
+ [ call-next-method ] bi ;
M: assoc update-methods ( assoc -- )
implementors* [ make-generic ] each ;
} cond ;
: sort-methods ( assoc -- assoc' )
- [ keys sort-classes ]
- [ [ dupd at ] curry ] bi { } map>assoc ;
+ >alist [ keys sort-classes ] keep extract-keys ;
M: predicate-dispatch-engine engine>quot
methods>> clone
M: pair constraint-satisfied?
first constraint-satisfied? ;
-: extract-keys ( seq assoc -- newassoc )
- [ dupd at ] curry H{ } map>assoc [ nip ] assoc-filter f assoc-like ;
+: valid-keys ( seq assoc -- newassoc )
+ extract-keys [ nip ] assoc-filter f assoc-like ;
: annotate-node ( node -- )
#! Annotate the node with the currently-inferred set of
#! value classes.
dup node-values {
- [ value-intervals get extract-keys >>intervals ]
- [ value-classes get extract-keys >>classes ]
- [ value-literals get extract-keys >>literals ]
+ [ value-intervals get valid-keys >>intervals ]
+ [ value-classes get valid-keys >>classes ]
+ [ value-literals get valid-keys >>literals ]
[ 2drop ]
} cleave ;
[ ] [ node-input-classes ] [ in-d>> [ value-class* ] map ] tri
classes= not [
fixed-point? off
- [ in-d>> value-classes get extract-keys ] keep
+ [ in-d>> value-classes get valid-keys ] keep
set-node-classes
] [ drop ] if
] [ call-next-method ] if
-USING: help.markup help.syntax io math ;
+USING: help.markup help.syntax io math byte-arrays ;
IN: io.binary
ARTICLE: "stream-binary" "Working with binary data"
-"The core stream words read and write strings. Packed binary integers can be read and written by converting to and from sequences of bytes. Floating point numbers can be read and written by converting them into a their bitwise integer representation (" { $link "floats" } ")."
+"Stream words on binary streams only read and write byte arrays. Packed binary integers can be read and written by converting to and from sequences of bytes. Floating point numbers can be read and written by converting them into a their bitwise integer representation (" { $link "floats" } ")."
$nl
"There are two ways to order the bytes making up an integer; " { $emphasis "little endian" } " byte order outputs the least significant byte first, and the most significant byte last, whereas " { $emphasis "big endian" } " is the other way around."
$nl
{ $description "Outputs the " { $snippet "n" } "th least significant byte of the sign-extended 2's complement representation of " { $snippet "x" } "." } ;
HELP: >le
-{ $values { "x" integer } { "n" "a non-negative integer" } { "str" "a string" } }
+{ $values { "x" integer } { "n" "a non-negative integer" } { "byte-array" byte-array } }
{ $description "Converts an integer " { $snippet "x" } " into a string of " { $snippet "n" } " bytes in little endian order. Truncation will occur if the integer is not in the range " { $snippet "[-2^(8n),2^(8n))" } "." } ;
HELP: >be
-{ $values { "x" integer } { "n" "a non-negative integer" } { "str" "a string" } }
+{ $values { "x" integer } { "n" "a non-negative integer" } { "byte-array" byte-array } }
{ $description "Converts an integer " { $snippet "x" } " into a string of " { $snippet "n" } " bytes in big endian order. Truncation will occur if the integer is not in the range " { $snippet "[-2^(8n),2^(8n))" } "." } ;
HELP: mask-byte
: nth-byte ( x n -- b ) -8 * shift mask-byte ; inline
-: >le ( x n -- str ) [ nth-byte ] with B{ } map-as ;
-: >be ( x n -- str ) >le dup reverse-here ;
+: >le ( x n -- byte-array ) [ nth-byte ] with B{ } map-as ;
+: >be ( x n -- byte-array ) >le dup reverse-here ;
: d>w/w ( d -- w1 w2 )
dup HEX: ffffffff bitand
": keep ( x quot -- x )"
" over >r call r> ; inline"
}
-"Word inlining is documented in " { $link "declarations" } "."
-$nl
-"A looping combinator:"
-{ $subsection while } ;
+"Word inlining is documented in " { $link "declarations" } "." ;
ARTICLE: "booleans" "Booleans"
"In Factor, any object that is not " { $link f } " has a true value, and " { $link f } " has a false value. The " { $link t } " object is the canonical true value."
"change-combination" "parser.tests" lookup
"methods" word-prop assoc-size
] unit-test
+
+[ ] [
+ 2 [
+ "IN: parser.tests DEFER: twice-fails FORGET: twice-fails MIXIN: twice-fails"
+ <string-reader> "twice-fails-test" parse-stream drop
+ ] times
+] unit-test
+
+[ [ ] ] [
+ "IN: parser.tests : staging-problem-test-1 1 ; : staging-problem-test-2 staging-problem-test-1 ;"
+ <string-reader> "staging-problem-test" parse-stream
+] unit-test
+
+[ t ] [ "staging-problem-test-1" "parser.tests" lookup >boolean ] unit-test
+
+[ t ] [ "staging-problem-test-2" "parser.tests" lookup >boolean ] unit-test
+
+[ [ ] ] [
+ "IN: parser.tests << : staging-problem-test-1 1 ; >> : staging-problem-test-2 staging-problem-test-1 ;"
+ <string-reader> "staging-problem-test" parse-stream
+] unit-test
+
+[ t ] [ "staging-problem-test-1" "parser.tests" lookup >boolean ] unit-test
+
+[ t ] [ "staging-problem-test-2" "parser.tests" lookup >boolean ] unit-test
+
+[ "DEFER: blah" eval ] [ error>> no-current-vocab? ] must-fail-with
ERROR: no-current-vocab ;
M: no-current-vocab summary ( obj -- )
- drop "Current vocabulary is f, use IN:" ;
+ drop "Not in a vocabulary; IN: form required" ;
: current-vocab ( -- str )
in get [ no-current-vocab ] unless* ;
"A parsing word cannot be used in the same file it is defined in." ;
: execute-parsing ( word -- )
- new-definitions get [
- dupd first key? [ staging-violation ] when
- ] when*
- execute ;
+ [ changed-definitions get key? [ staging-violation ] when ]
+ [ execute ]
+ bi ;
: parse-step ( accum end -- accum ? )
scan-word {
[ ] [ \ compose see ] unit-test
[ ] [ \ curry see ] unit-test
+
+[ "POSTPONE: [" ] [ \ [ unparse ] unit-test
"Other destructive words:"
{ $subsection move }
{ $subsection exchange }
-{ $subsection push-new }
{ $subsection copy }
{ $subsection replace-slice }
{ $see-also set-nth push pop "sequences-stacks" } ;
{ $errors "Throws an error if " { $snippet "new" } " contains elements whose types are not permissible in " { $snippet "seq" } "." }
{ $side-effects "seq" } ;
-HELP: push-new
-{ $values { "elt" object } { "seq" "a resizable mutable sequence" } }
-{ $description "Removes all elements equal to " { $snippet "elt" } ", and adds " { $snippet "elt" } " at the end of the sequence." }
-{ $examples
- { $example
- "USING: namespaces prettyprint sequences ;"
- "V{ \"beans\" \"salsa\" \"cheese\" } \"v\" set"
- "\"nachos\" \"v\" get push-new"
- "\"salsa\" \"v\" get push-new"
- "\"v\" get ."
- "V{ \"beans\" \"cheese\" \"nachos\" \"salsa\" }"
- }
-}
-{ $side-effects "seq" } ;
-
-{ push push-new prefix suffix } related-words
+{ push prefix suffix } related-words
HELP: suffix
{ $values { "seq" sequence } { "elt" object } { "newseq" sequence } }
3 V{ 1 2 3 4 5 6 } clone [ delete-nth ] keep
] unit-test
-[ V{ 1 2 3 } ]
-[ 3 V{ 1 2 } clone [ push-new ] keep ] unit-test
-
-[ V{ 1 2 3 } ]
-[ 3 V{ 1 3 2 } clone [ push-new ] keep ] unit-test
-
! erg's random tester found this one
[ SBUF" 12341234" ] [
9 <sbuf> dup "1234" swap push-all dup dup swap push-all
: delete ( elt seq -- ) 0 0 rot (delete) nip set-length drop ;
-: push-new ( elt seq -- ) [ delete ] 2keep push ;
-
: prefix ( seq elt -- newseq )
over >r over length 1+ r> [
[ 0 swap set-nth-unsafe ] keep
: unclip ( seq -- rest first )
[ rest ] [ first ] bi ;
-: unclip-last ( seq -- butfirst last )
+: unclip-last ( seq -- butlast last )
[ but-last ] [ peek ] bi ;
: unclip-slice ( seq -- rest first )
{ $subsection set= }
"A word used to implement the above:"
{ $subsection unique }
+"Adding elements to sets:"
+{ $subsection adjoin }
+{ $subsection conjoin }
{ $see-also member? memq? contains? all? "assocs-sets" } ;
ABOUT: "sets"
+HELP: adjoin
+{ $values { "elt" object } { "seq" "a resizable mutable sequence" } }
+{ $description "Removes all elements equal to " { $snippet "elt" } ", and adds " { $snippet "elt" } " at the end of the sequence." }
+{ $examples
+ { $example
+ "USING: namespaces prettyprint sets ;"
+ "V{ \"beans\" \"salsa\" \"cheese\" } \"v\" set"
+ "\"nachos\" \"v\" get adjoin"
+ "\"salsa\" \"v\" get adjoin"
+ "\"v\" get ."
+ "V{ \"beans\" \"cheese\" \"nachos\" \"salsa\" }"
+ }
+}
+{ $side-effects "seq" } ;
+
HELP: unique
{ $values { "seq" "a sequence" } { "assoc" "an assoc" } }
{ $description "Outputs a new assoc where the keys and values are equal." }
[ V{ } ] [ { } { } union ] unit-test
[ V{ 1 2 3 4 } ] [ { 1 2 3 } { 2 3 4 } union ] unit-test
+
+[ V{ 1 2 3 } ]
+[ 3 V{ 1 2 } clone [ adjoin ] keep ] unit-test
+
+[ V{ 1 2 3 } ]
+[ 3 V{ 1 3 2 } clone [ adjoin ] keep ] unit-test
USING: assocs hashtables kernel sequences vectors ;
IN: sets
+: adjoin ( elt seq -- ) [ delete ] [ push ] 2bi ;
+
+: conjoin ( elt assoc -- ) dupd set-at ;
+
: (prune) ( elt hash vec -- )
- 3dup drop key?
- [ [ drop dupd set-at ] [ nip push ] [ ] 3tri ] unless
- 3drop ; inline
+ 3dup drop key? [ 3drop ] [
+ [ drop conjoin ] [ nip push ] 3bi
+ ] if ; inline
: prune ( seq -- newseq )
[ ] [ length <hashtable> ] [ length <vector> ] tri
[ dup ] H{ } map>assoc ;
: (all-unique?) ( elt hash -- ? )
- 2dup key? [ 2drop f ] [ dupd set-at t ] if ;
+ 2dup key? [ 2drop f ] [ conjoin t ] if ;
: all-unique? ( seq -- ? )
dup length <hashtable> [ (all-unique?) ] curry all? ;
USING: help.markup help.syntax sequences strings ;
IN: splitting
+ARTICLE: "groups-clumps" "Groups and clumps"
+"A virtual sequence for splitting a sequence into disjoint, fixed-length subsequences:"
+{ $subsection groups }
+{ $subsection <groups> }
+{ $subsection <sliced-groups> }
+"A virtual sequence for splitting a sequence into overlapping, fixed-length subsequences:"
+{ $subsection clumps }
+{ $subsection <clumps> }
+{ $subsection <sliced-clumps> }
+"The difference can be summarized as the following:"
+{ $list
+ { "With groups, the subsequences form the original sequence when concatenated:"
+ { $unchecked-example "dup n groups concat sequence= ." "t" }
+ }
+ { "With clumps, collecting the first element of each subsequence but the last one, together with the last subseqence, yields the original sequence:"
+ { $unchecked-example "dup n clumps unclip-last >r [ first ] map r> append sequence= ." "t" }
+ }
+} ;
+
ARTICLE: "sequences-split" "Splitting sequences"
"Splitting sequences at occurrences of subsequences:"
{ $subsection ?head }
{ $subsection ?tail-slice }
{ $subsection split1 }
{ $subsection split }
-"Grouping elements:"
-{ $subsection group }
-"A virtual sequence for grouping elements:"
-{ $subsection groups }
-{ $subsection <groups> }
-{ $subsection <sliced-groups> }
"Splitting a string into lines:"
-{ $subsection string-lines } ;
+{ $subsection string-lines }
+{ $subsection "groups-clumps" } ;
ABOUT: "sequences-split"
{ $examples { $example "USING: prettyprint splitting ;" "\"hello world-how are you?\" \" -\" split ." "{ \"hello\" \"world\" \"how\" \"are\" \"you?\" }" } } ;
HELP: groups
-{ $class-description "Instances are virtual sequences whose elements are fixed-length subsequences or slices of an underlying sequence. Groups are mutable and resizable if the underlying sequence is mutable and resizable, respectively."
+{ $class-description "Instances are virtual sequences whose elements are disjoint fixed-length subsequences of an underlying sequence. Groups are mutable and resizable if the underlying sequence is mutable and resizable, respectively."
$nl
"New groups are created by calling " { $link <groups> } " and " { $link <sliced-groups> } "." }
{ $see-also group } ;
HELP: group
{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "array" "a sequence of sequences" } }
-{ $description "Splits the sequence into groups of " { $snippet "n" } " elements and collects the groups into a new array." }
-{ $notes "If the sequence length is not a multiple of " { $snippet "n" } ", the final subsequence in the list will be shorter than " { $snippet "n" } " elements." } ;
+{ $description "Splits the sequence into disjoint groups of " { $snippet "n" } " elements and collects the groups into a new array." }
+{ $notes "If the sequence length is not a multiple of " { $snippet "n" } ", the final subsequence in the list will be shorter than " { $snippet "n" } " elements." }
+{ $examples
+ { $example "USING: splitting prettyprint ;" "{ 3 1 3 3 7 } 2 group ." "{ { 3 1 } { 3 3 } { 7 } }" }
+} ;
HELP: <groups>
{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "groups" groups } }
-{ $description "Outputs a virtual sequence whose elements are subsequences consisting of groups of " { $snippet "n" } " elements from the underlying sequence." }
+{ $description "Outputs a virtual sequence whose elements are disjoint subsequences of " { $snippet "n" } " elements from the underlying sequence." }
{ $examples
{ $example
"USING: arrays kernel prettyprint sequences splitting ;"
HELP: <sliced-groups>
{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "groups" groups } }
-{ $description "Outputs a virtual sequence whose elements are slices consisting of groups of " { $snippet "n" } " elements from the underlying sequence." }
+{ $description "Outputs a virtual sequence whose elements are overlapping subsequences of " { $snippet "n" } " elements from the underlying sequence." }
{ $examples
{ $example
"USING: arrays kernel prettyprint sequences splitting ;"
}
} ;
-{ group <groups> <sliced-groups> } related-words
+HELP: clumps
+{ $class-description "Instances are virtual sequences whose elements are overlapping fixed-length subsequences o an underlying sequence. Clumps are mutable and resizable if the underlying sequence is mutable and resizable, respectively."
+$nl
+"New clumps are created by calling " { $link <clumps> } " and " { $link <sliced-clumps> } "." } ;
+
+HELP: clump
+{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "array" "a sequence of sequences" } }
+{ $description "Splits the sequence into overlapping clumps of " { $snippet "n" } " elements and collects the clumps into a new array." }
+{ $errors "Throws an error if " { $snippet "n" } " is smaller than the length of the sequence." }
+{ $examples
+ { $example "USING: splitting prettyprint ;" "{ 3 1 3 3 7 } 2 clump ." "{ { 3 1 } { 1 3 } { 3 3 } { 3 7 } }" }
+} ;
+
+HELP: <clumps>
+{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "clumps" clumps } }
+{ $description "Outputs a virtual sequence whose elements are overlapping subsequences of " { $snippet "n" } " elements from the underlying sequence." }
+{ $examples
+ "Running averages:"
+ { $example
+ "USING: splitting sequences math prettyprint kernel ;"
+ "IN: scratchpad"
+ ": share-price"
+ " { 13/50 51/100 13/50 1/10 4/5 17/20 33/50 3/25 19/100 3/100 } ;"
+ ""
+ "share-price 4 <clumps> [ [ sum ] [ length ] bi / ] map ."
+ "{ 113/400 167/400 201/400 241/400 243/400 91/200 1/4 }"
+ }
+} ;
+
+HELP: <sliced-clumps>
+{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "clumps" clumps } }
+{ $description "Outputs a virtual sequence whose elements are overlapping slices of " { $snippet "n" } " elements from the underlying sequence." } ;
+
+{ clumps groups } related-words
+
+{ clump group } related-words
+
+{ <clumps> <groups> } related-words
+
+{ <sliced-clumps> <sliced-groups> } related-words
HELP: ?head
{ $values { "seq" "a sequence" } { "begin" "a sequence" } { "newseq" "a new sequence" } { "?" "a boolean" } }
TUPLE: clumps < abstract-groups ;
-: <clumps> ( seq n -- groups )
+: <clumps> ( seq n -- clumps )
clumps construct-groups ; inline
M: clumps length
TUPLE: sliced-clumps < groups ;
-: <sliced-clumps> ( seq n -- groups )
+: <sliced-clumps> ( seq n -- clumps )
sliced-clumps construct-groups ; inline
M: sliced-clumps nth group@ <slice> ;
] define-syntax
"DEFER:" [
- scan in get create
- dup old-definitions get first delete-at
+ scan current-vocab create
+ dup old-definitions get [ delete-at ] with each
set-word
] define-syntax
"MAIN:" [ scan-word in get vocab set-vocab-main ] define-syntax
"<<" [
- [ \ >> parse-until >quotation ] with-compilation-unit
- call
+ [
+ \ >> parse-until >quotation
+ ] with-nested-compilation-unit call
] define-syntax
"call-next-method" [
: define-symbol ( word -- )
dup [ ] curry define-inline ;
-: reset-word ( word -- )
+GENERIC: reset-word ( word -- )
+
+M: word reset-word
{
"unannotated-def"
"parsing" "inline" "foldable" "flushable"
USING: arrays assocs kernel vectors sequences namespaces
-random math.parser ;
+random math.parser math fry ;
IN: assocs.lib
: ref-at ( table key -- value ) swap at ;
: set-at-unique ( value assoc -- key )
dup generate-key [ swap set-at ] keep ;
+
+: histogram ( assoc quot -- assoc' )
+ H{ } clone [
+ swap [ change-at ] 2curry assoc-each
+ ] keep ;
[ normalize ] map ;
: read-model ( stream -- model )
- "Reading model" print flush [
- ascii [ parse-model ] with-file-reader
- [ normals ] 2keep 3array
- ] time ;
+ ascii [ parse-model ] with-file-reader
+ [ normals ] 2keep 3array ;
: model-path "bun_zipper.ply" temp-file ;
! Copyright (C) 2008 Matthew Willis.
! See http://factorcode.org/license.txt for BSD license.
-USING: cairo cairo.ffi ui.render kernel opengl.gl opengl
-math byte-arrays ui.gadgets accessors arrays
-namespaces io.backend ;
+USING: sequences math opengl.gadgets kernel
+byte-arrays cairo.ffi cairo io.backend
+opengl.gl arrays ;
IN: cairo.gadgets
-! We need two kinds of gadgets:
-! one performs the cairo ops once and caches the bytes, the other
-! performs cairo ops every refresh
-
-TUPLE: cairo-gadget width height quot cache? bytes ;
-PREDICATE: cached-cairo < cairo-gadget cache?>> ;
-: <cairo-gadget> ( width height quot -- cairo-gadget )
- cairo-gadget construct-gadget
- swap >>quot
- swap >>height
- swap >>width ;
-
-: <cached-cairo> ( width height quot -- cairo-gadget )
- <cairo-gadget> t >>cache? ;
-
: width>stride ( width -- stride ) 4 * ;
-: copy-cairo ( width height quot -- byte-array )
- >r over width>stride
+: copy-cairo ( dim quot -- byte-array )
+ >r first2 over width>stride
[ * nip <byte-array> dup CAIRO_FORMAT_ARGB32 ]
[ cairo_image_surface_create_for_data ] 3bi
r> with-cairo-from-surface ;
-: (cairo>bytes) ( gadget -- byte-array )
- [ width>> ] [ height>> ] [ quot>> ] tri copy-cairo ;
-
-GENERIC: cairo>bytes
-M: cairo-gadget cairo>bytes ( gadget -- byte-array )
- (cairo>bytes) ;
-
-M: cached-cairo cairo>bytes ( gadget -- byte-array )
- dup bytes>> [ ] [
- dup (cairo>bytes) [ >>bytes drop ] keep
- ] ?if ;
+: <cairo-gadget> ( dim quot -- )
+ over 2^-bounds swap copy-cairo
+ GL_BGRA rot <texture-gadget> ;
-: cairo>png ( gadget path -- )
- >r [ cairo>bytes CAIRO_FORMAT_ARGB32 ] [ width>> ]
- [ height>> ] tri over width>stride
- cairo_image_surface_create_for_data
- r> [ cairo_surface_write_to_png check-cairo ] curry with-surface ;
-
-M: cairo-gadget draw-gadget* ( gadget -- )
- origin get [
- 0 0 glRasterPos2i
- 1.0 -1.0 glPixelZoom
- [ width>> ] [ height>> GL_BGRA GL_UNSIGNED_BYTE ]
- [ cairo>bytes ] tri glDrawPixels
- ] with-translation ;
-
-M: cairo-gadget pref-dim* ( gadget -- rect )
- [ width>> ] [ height>> ] bi 2array ;
+! maybe also texture>png
+! : cairo>png ( gadget path -- )
+! >r [ cairo>bytes CAIRO_FORMAT_ARGB32 ] [ width>> ]
+! [ height>> ] tri over width>stride
+! cairo_image_surface_create_for_data
+! r> [ cairo_surface_write_to_png check-cairo ] curry with-surface ;
: copy-surface ( surface -- )
cr swap 0 0 cairo_set_source_surface
cr cairo_paint ;
-: <bytes-gadget> ( width height bytes -- cairo-gadget )
- >r [ ] <cached-cairo> r> >>bytes ;
-
: <png-gadget> ( path -- gadget )
normalize-path cairo_image_surface_create_from_png
[ cairo_image_surface_get_width ]
- [ cairo_image_surface_get_height 2dup ]
+ [ cairo_image_surface_get_height 2array dup 2^-bounds ]
[ [ copy-surface ] curry copy-cairo ] tri
- <bytes-gadget> ;
\ No newline at end of file
+ GL_BGRA rot <texture-gadget> ;
+
+
cr cairo_fill ;
: utf8 ( -- )
- cr "Serif" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_NORMAL
+ cr "Sans" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_NORMAL
cairo_select_font_face
cr 50 cairo_set_font_size
"cairo_text_extents_t" malloc-object
- cr B{ 230 151 165 230 156 172 232 170 158 } pick cairo_text_extents
+ cr "日本語" pick cairo_text_extents
cr over
[ cairo_text_extents_t-width 2 / ]
[ cairo_text_extents_t-x_bearing ] bi +
[ cairo_text_extents_t-y_bearing ] bi +
128 swap - cairo_move_to
free
- cr B{ 230 151 165 230 156 172 232 170 158 } cairo_show_text
+ cr "日本語" cairo_show_text
cr 1 0.2 0.2 0.6 cairo_set_source_rgba
cr 6 cairo_set_line_width
USING: quotations cairo.gadgets ui.gadgets.panes sequences ;
: samples ( -- )
{ arc clip clip-image dash gradient text utf8 }
- [ 256 256 rot 1quotation <cached-cairo> gadget. ] each ;
+ [ { 256 256 } swap 1quotation <cairo-gadget> gadget. ] each ;
- MAIN: samples
\ No newline at end of file
+ MAIN: samples
"Sun May 04 07:00:00 2008 GMT" cookie-string>timestamp\r
timestamp>string\r
] unit-test\r
+\r
+[\r
+ T{ timestamp f\r
+ 2008\r
+ 5\r
+ 26\r
+ 0\r
+ 37\r
+ 42.12345\r
+ T{ duration f 0 0 0 -5 0 0 }\r
+ }\r
+] [ "2008-05-26T00:37:42.12345-05:00" rfc3339>timestamp ] unit-test\r
-USING: math math.order math.parser kernel sequences io\r
+USING: math math.order math.parser math.functions kernel sequences io\r
accessors arrays io.streams.string splitting\r
combinators accessors debugger\r
calendar calendar.format.macros ;\r
: read-hms ( -- h m s )\r
read-00 ":" expect read-00 ":" expect read-00 ;\r
\r
+: read-rfc3339-seconds ( s -- s' ch )\r
+ "+-Z" read-until >r\r
+ [ string>number ] [ length 10 swap ^ ] bi / + r> ;\r
+\r
: (rfc3339>timestamp) ( -- timestamp )\r
read-ymd\r
"Tt" expect\r
read-hms\r
- read1 { { CHAR: . [ read-000 1000 / + read1 ] } [ ] } case\r
+ read1 { { CHAR: . [ read-rfc3339-seconds ] } [ ] } case\r
read-rfc3339-gmt-offset\r
<timestamp> ;\r
\r
[ [ 2dup ] prepend [ not ] append [ f ] ] t short-circuit
[ 2nip ] append ;
+! or
+
MACRO: || ( quots -- ? ) [ [ t ] ] f short-circuit ;
+MACRO: 0|| ( quots -- ? ) [ [ t ] ] f short-circuit ;
+
+MACRO: 1|| ( quots -- ? )
+ [ [ dup ] prepend [ t ] ] f short-circuit [ nip ] append ;
+
+MACRO: 2|| ( quots -- ? )
+ [ [ 2dup ] prepend [ t ] ] f short-circuit [ 2nip ] append ;
+
+MACRO: 3|| ( quots -- ? )
+ [ [ 3dup ] prepend [ t ] ] f short-circuit [ 3nip ] append ;
+
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! ifte
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TUPLE: simple-statement < statement ;
TUPLE: prepared-statement < statement ;
-SINGLETON: throwable
-SINGLETON: nonthrowable
-
-: make-throwable ( obj -- obj' )
- dup sequence? [
- [ make-throwable ] map
- ] [
- throwable >>type
- ] if ;
-
-: make-nonthrowable ( obj -- obj' )
- dup sequence? [
- [ make-nonthrowable ] map
- ] [
- nonthrowable >>type
- ] if ;
-
TUPLE: result-set sql in-params out-params handle n max ;
: construct-statement ( sql in out class -- statement )
new
swap >>out-params
swap >>in-params
- swap >>sql
- throwable >>type ;
+ swap >>sql ;
HOOK: <simple-statement> db ( str in out -- statement )
HOOK: <prepared-statement> db ( str in out -- statement )
GENERIC: execute-statement* ( statement type -- )
-M: throwable execute-statement* ( statement type -- )
+M: object execute-statement* ( statement type -- )
drop query-results dispose ;
-M: nonthrowable execute-statement* ( statement type -- )
- drop [ query-results dispose ] [ 2drop ] recover ;
-
: execute-statement ( statement -- )
dup sequence? [
[ execute-statement ] each
: query-map ( statement quot -- seq )
accumulator >r query-each r> { } like ; inline
-: with-db ( db seq quot -- )
+: with-db ( seq class quot -- )
>r make-db db-open db r>
[ db get swap [ drop ] prepose with-disposal ] curry with-variable ;
inline
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel ;
+IN: db.errors
+
+ERROR: db-error ;
+ERROR: sql-error ;
+
+
+ERROR: table-exists ;
+ERROR: bad-schema ;
TUPLE: db-pool < pool db params ;
-: <db-pool> ( db params -- pool )
+: <db-pool> ( params db -- pool )
db-pool <pool>
- swap >>params
- swap >>db ;
+ swap >>db
+ swap >>params ;
: with-db-pool ( db params quot -- )
>r <db-pool> r> with-pool ; inline
M: db-pool make-connection ( pool -- )
- [ db>> ] [ params>> ] bi make-db db-open ;
+ [ params>> ] [ db>> ] bi make-db db-open ;
: with-pooled-db ( pool quot -- )
[ db swap with-variable ] curry with-pooled-connection ; inline
: drop-table-sql ( table -- statement )
[
- "drop table " 0% 0% ";" 0% drop
+ "drop table " 0% 0% drop
] query-make ;
M: postgresql-db drop-sql-statement ( class -- seq )
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math namespaces sequences random
-strings
-math.bitfields.lib namespaces.lib db db.tuples db.types
-math.intervals ;
+strings math.parser math.intervals combinators
+math.bitfields.lib namespaces.lib db db.tuples db.types ;
IN: db.queries
GENERIC: where ( specs obj -- )
: maybe-make-retryable ( statement -- statement )
- dup in-params>> [ generator-bind? ] contains? [
- make-retryable
- ] when ;
+ dup in-params>> [ generator-bind? ] contains?
+ [ make-retryable ] when ;
: query-make ( class quot -- )
>r sql-props r>
- [ 0 sql-counter rot with-variable ";" 0% ] { "" { } { } } nmake
+ [ 0 sql-counter rot with-variable ] { "" { } { } } nmake
<simple-statement> maybe-make-retryable ; inline
M: db begin-transaction ( -- ) "BEGIN" sql-command ;
" from " 0% 0%
where-clause
] query-make ;
+
+: do-group ( tuple groups -- )
+ [
+ ", " join " group by " prepend append
+ ] curry change-sql drop ;
+
+: do-order ( tuple order -- )
+ [
+ ", " join " order by " prepend append
+ ] curry change-sql drop ;
+
+: do-offset ( tuple n -- )
+ [
+ number>string " offset " prepend append
+ ] curry change-sql drop ;
+
+: do-limit ( tuple n -- )
+ [
+ number>string " limit " prepend append
+ ] curry change-sql drop ;
+
+: make-advanced-statement ( tuple advanced -- tuple' )
+ dupd
+ {
+ [ group>> [ do-group ] [ drop ] if* ]
+ [ order>> [ do-order ] [ drop ] if* ]
+ [ limit>> [ do-limit ] [ drop ] if* ]
+ [ offset>> [ do-offset ] [ drop ] if* ]
+ } 2cleave ;
+
+M: db <advanced-select-statement> ( tuple class group order limit offset -- tuple )
+ advanced-statement boa
+ [ <select-by-slots-statement> ] dip make-advanced-statement ;
! TUPLE: person name age ;
: insert-1
{ insert
- { table "person" }
- { columns "name" "age" }
- { values "erg" 26 }
+ {
+ { table "person" }
+ { columns "name" "age" }
+ { values "erg" 26 }
+ }
} ;
: update-1
namespaces sequences db.sqlite.ffi db combinators
continuations db.types calendar.format serialize
io.streams.byte-array byte-arrays io.encodings.binary
-io.backend ;
+io.backend db.errors ;
IN: db.sqlite.lib
-: sqlite-error ( n -- * )
- sqlite-error-messages nth throw ;
+ERROR: sqlite-error < db-error n string ;
+ERROR: sqlite-sql-error < sql-error n string ;
-: sqlite-statement-error-string ( -- str )
- db get db-handle sqlite3_errmsg ;
+: throw-sqlite-error ( n -- * )
+ dup sqlite-error-messages nth sqlite-error ;
: sqlite-statement-error ( -- * )
- sqlite-statement-error-string throw ;
+ SQLITE_ERROR
+ db get db-handle sqlite3_errmsg sqlite-sql-error ;
: sqlite-check-result ( n -- )
{
- { [ dup SQLITE_OK = ] [ drop ] }
- { [ dup SQLITE_ERROR = ] [ sqlite-statement-error ] }
- [ sqlite-error ]
- } cond ;
+ { SQLITE_OK [ ] }
+ { SQLITE_ERROR [ sqlite-statement-error ] }
+ [ throw-sqlite-error ]
+ } case ;
: sqlite-open ( path -- db )
normalize-path
dup sqlite-#columns [ sqlite-column ] with map ;
: sqlite-step-has-more-rows? ( prepared -- bool )
- dup SQLITE_ROW = [
- drop t
- ] [
- dup SQLITE_DONE =
- [ drop ] [ sqlite-check-result ] if f
- ] if ;
+ {
+ { SQLITE_ROW [ t ] }
+ { SQLITE_DONE [ f ] }
+ [ sqlite-check-result f ]
+ } case ;
: sqlite-next ( prepared -- ? )
sqlite3_step sqlite-step-has-more-rows? ;
swap >>path ;
M: sqlite-db db-open ( db -- db )
- [ path>> sqlite-open ] [ swap >>handle ] bi ;
+ dup path>> sqlite-open >>handle ;
M: sqlite-db db-close ( handle -- ) sqlite-close ;
M: sqlite-db dispose ( db -- ) dispose-db ;
{ "default" [ first number>string join-space ] }
[ 2drop ]
} case ;
-
USING: io.files kernel tools.test db db.tuples classes
db.types continuations namespaces math math.ranges
prettyprint calendar sequences db.sqlite math.intervals
-db.postgresql accessors random math.bitfields.lib ;
+db.postgresql accessors random math.bitfields.lib
+math.ranges strings sequences.lib ;
IN: db.tuples.tests
TUPLE: person the-id the-name the-number the-real
: test-sqlite ( quot -- )
>r "tuples-test.db" temp-file sqlite-db r> with-db ;
-: test-postgresql ( -- )
->r { "localhost" "postgres" "foob" "factor-test" } postgresql-db r> with-db ;
+: test-postgresql ( quot -- )
+ >r { "localhost" "postgres" "foob" "factor-test" } postgresql-db r> with-db ;
: test-repeated-insert
[ ] [ person ensure-table ] unit-test
TUPLE: exam id name score ;
+: random-exam ( -- exam )
+ f
+ 6 [ CHAR: a CHAR: b [a,b] random ] replicate >string
+ 100 random
+ exam boa ;
+
: test-intervals ( -- )
exam "EXAM"
{
[ class \ not-persistent = ] must-fail-with
] test-postgresql
+
+TUPLE: suparclass id a ;
+
+suparclass f {
+ { "id" "ID" +db-assigned-id+ }
+ { "a" "A" INTEGER }
+} define-persistent
+
+TUPLE: subbclass < suparclass b ;
+
+subbclass "SUBCLASS" {
+ { "b" "B" TEXT }
+} define-persistent
+
+TUPLE: fubbclass < subbclass ;
+
+fubbclass "FUBCLASS" { } define-persistent
+
+: test-db-inheritance ( -- )
+ [ ] [ subbclass ensure-table ] unit-test
+ [ ] [ fubbclass ensure-table ] unit-test
+
+ [ ] [
+ subbclass new 5 >>a "hi" >>b dup insert-tuple id>> "id" set
+ ] unit-test
+
+ [ t "hi" 5 ] [
+ subbclass new "id" get >>id select-tuple
+ [ subbclass? ] [ b>> ] [ a>> ] tri
+ ] unit-test
+
+ [ ] [ fubbclass new 0 >>a "hi" >>b insert-tuple ] unit-test
+
+ [ t ] [ fubbclass new select-tuples [ fubbclass? ] all? ] unit-test ;
+
+[ test-db-inheritance ] test-sqlite
+
! Don't comment these out. These words must infer
\ bind-tuple must-infer
\ insert-tuple must-infer
"db-columns" set-word-prop
"db-relations" set-word-prop ;
-ERROR: not-persistent ;
+ERROR: not-persistent class ;
: db-table ( class -- obj )
- "db-table" word-prop [ not-persistent ] unless* ;
+ dup "db-table" word-prop [ ] [ not-persistent ] ?if ;
: db-columns ( class -- obj )
- "db-columns" word-prop ;
+ superclasses [ "db-columns" word-prop ] map concat ;
: db-relations ( class -- obj )
"db-relations" word-prop ;
HOOK: <update-tuple-statement> db ( class -- obj )
HOOK: <delete-tuples-statement> db ( tuple class -- obj )
HOOK: <select-by-slots-statement> db ( tuple class -- tuple )
+TUPLE: advanced-statement group order offset limit ;
+HOOK: <advanced-select-statement> db ( tuple class group order offset limit -- tuple )
HOOK: insert-tuple* db ( tuple statement -- )
[ regenerate-params bind-statement* f ] cleanup
] curry 10 retry drop ;
-: resulting-tuple ( row out-params -- tuple )
- dup first class>> new [
+: resulting-tuple ( class row out-params -- tuple )
+ rot class new [
[
>r slot-name>> r> set-slot-named
] curry 2each
] keep ;
-: query-tuples ( statement -- seq )
+: query-tuples ( exemplar-tuple statement -- seq )
[ out-params>> ] keep query-results [
- [ sql-row-typed swap resulting-tuple ] with query-map
+ [ sql-row-typed swap resulting-tuple ] with with query-map
] with-disposal ;
: query-modify-tuple ( tuple statement -- )
: recreate-table ( class -- )
[
- drop-sql-statement make-nonthrowable
- [ execute-statement ] with-disposals
+ [ drop-sql-statement [ execute-statement ] with-disposals
+ ] curry ignore-errors
] [ create-table ] bi ;
: ensure-table ( class -- )
[ bind-tuple ] keep execute-statement
] with-disposal ;
+: do-select ( exemplar-tuple statement -- tuples )
+ [ [ bind-tuple ] [ query-tuples ] 2bi ] with-disposal ;
+
: select-tuples ( tuple -- tuples )
- dup dup class <select-by-slots-statement> [
- [ bind-tuple ] keep query-tuples
- ] with-disposal ;
+ dup dup class <select-by-slots-statement> do-select ;
-: select-tuple ( tuple -- tuple/f ) select-tuples ?first ;
+: select-tuple ( tuple -- tuple/f )
+ dup dup class f f f 1 <advanced-select-statement>
+ do-select ?first ;
HOOK: bind# db ( spec obj -- )
: offset-of-slot ( str obj -- n )
- class "slots" word-prop slot-named slot-spec-offset ;
+ class superclasses [ "slots" word-prop ] map concat
+ slot-named slot-spec-offset ;
: get-slot-named ( name obj -- value )
tuck offset-of-slot slot ;
: expired? ( entry -- ? ) time>> time->ttl 0 <= ;
-: cache-get ( query -- result )
+: cache-get* ( query -- rrs/NX/f )
dup table-get ! query result
{
{ [ dup f = ] [ 2drop f ] } ! not in the cache
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: cache-get ( query -- rrs/f )
+ dup cache-get* dup NX = [ drop name>> name-error ] [ nip ] if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
: rr->entry ( rr -- entry )
[ ttl>> ttl->time ] [ rdata>> {1} >vector ] bi entry boa ;
: cache-add-rr ( rr -- ) [ rr->query ] [ ] bi cache-add ;
: cache-add-rrs ( rrs -- ) [ cache-add-rr ] each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! cache-name-error
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: message-soa ( message -- rr/soa )
+ authority-section>> [ type>> SOA = ] filter 1st ;
+
+: cache-name-error ( message -- message )
+ dup
+ [ message-query ] [ message-soa ttl>> ] bi
+ cache-nx ;
+
+: cache-message-records ( message -- message )
+ dup
+ {
+ [ answer-section>> cache-add-rrs ]
+ [ authority-section>> cache-add-rrs ]
+ [ additional-section>> cache-add-rrs ]
+ }
+ cleave ;
+
+: cache-message ( message -- message )
+ dup rcode>> NAME-ERROR = [ cache-name-error ] when
+ cache-message-records ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
! TYPE
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-SYMBOLS: A NS MD MF CNAME SOA MB MG MR NULL WKS PTR HINFO MINFO MX TXT ;
+SYMBOLS: A NS MD MF CNAME SOA MB MG MR NULL WKS PTR HINFO MINFO MX TXT AAAA ;
: type-table ( -- table )
{
{ MINFO 14 }
{ MX 15 }
{ TXT 16 }
+ { AAAA 28 }
} ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: ip->ba ( ip -- ba ) "." split [ string>number ] map >byte-array ;
+: ipv6->ba ( ip -- ba ) ":" split [ 16 base> ] map [ 2 >be ] map concat ;
+
: label->ba ( label -- ba ) [ >byte-array ] [ length ] bi prefix ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: get-ip ( ba i -- ip ) dup 4 + subseq >array [ number>string ] map "." join ;
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: get-ipv6 ( ba i -- ip )
+ dup 16 + subseq 2 group [ be> 16 >base ] map ":" join ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
: get-rdata ( ba i type -- rdata )
{
{ CNAME [ get-name ] }
{ MX [ get-mx ] }
{ SOA [ get-soa ] }
{ A [ get-ip ] }
+ { AAAA [ get-ipv6 ] }
}
case ;
: ask ( message -- message ) dns-server ask-server ;
-: <query-message> ( query -- message ) <message> swap {1} >>question-section ;
\ No newline at end of file
+: query->message ( query -- message ) <message> swap {1} >>question-section ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: message-query ( message -- query ) question-section>> 1st ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ERROR: name-error name ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: fully-qualified ( name -- name )
+ {
+ { [ dup empty? ] [ "." append ] }
+ { [ dup peek CHAR: . = ] [ ] }
+ { [ t ] [ "." append ] }
+ }
+ cond ;
--- /dev/null
+
+USING: kernel
+ combinators
+ vectors
+ sequences
+ io.sockets
+ accessors
+ combinators.lib
+ newfx
+ dns dns.cache dns.misc ;
+
+IN: dns.forwarding
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! DNS server - caching, forwarding
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: (socket) ( -- vec ) V{ f } ;
+
+: socket ( -- socket ) (socket) 1st ;
+
+: init-socket-on-port ( port -- )
+ f swap <inet4> <datagram> 0 (socket) as-mutate ;
+
+: init-socket ( -- ) 53 init-socket-on-port ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: (upstream-server) ( -- vec ) V{ f } ;
+
+: upstream-server ( -- ip ) (upstream-server) 1st ;
+
+: set-upstream-server ( ip -- ) 0 (upstream-server) as-mutate ;
+
+: init-upstream-server ( -- )
+ upstream-server not
+ [ resolv-conf-server set-upstream-server ]
+ when ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: 1&& <-&& ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: rrs? ( obj -- ? ) { [ NX = not ] [ f = not ] } 1&& ;
+
+: query->answer/cache ( query -- rrs/NX/f )
+ dup cache-get* dup { [ rrs? ] [ NX = ] } 1||
+ [ nip ]
+ [
+ drop
+ dup clone CNAME >>type cache-get* dup { [ NX = ] [ f = ] } 1||
+ [ nip ]
+ [ ! query rrs
+ tuck ! rrs query rrs
+ 1st ! rrs query rr/cname
+ rdata>> ! rrs query name
+ >r clone r> >>name ! rrs query
+ query->answer/cache ! rrs rrs/NX/f
+ dup rrs? [ append ] [ nip ] if
+ ]
+ if
+ ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: answer-from-cache ( message -- message/f )
+ dup message-query ! message query
+ dup query->answer/cache ! message query rrs/NX/f
+ {
+ { [ dup f = ] [ 3drop f ] }
+ { [ dup NX = ] [ 2drop NAME-ERROR >>rcode ] }
+ { [ t ] [ nip >>answer-section ] }
+ }
+ cond ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: answer-from-server ( message -- message )
+ upstream-server ask-server
+ cache-message ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: find-answer ( message -- message )
+ dup answer-from-cache dup
+ [ nip ]
+ [ drop answer-from-server ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: loop ( -- )
+ socket receive ! byte-array addr-spec
+ swap ! addr-spec byte-array
+ parse-message ! addr-spec message
+ find-answer ! addr-spec message
+ message->ba ! addr-spec byte-array
+ swap ! byte-array addr-spec
+ socket send
+ loop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: start ( -- ) init-socket init-upstream-server loop ;
+
+MAIN: start
\ No newline at end of file
--- /dev/null
+
+USING: kernel sequences splitting io.files io.encodings.utf8 random newfx ;
+
+IN: dns.misc
+
+: resolv-conf-servers ( -- seq )
+ "/etc/resolv.conf" utf8 file-lines
+ [ " " split ] map
+ [ 1st "nameserver" = ] filter
+ [ 2nd ] map ;
+
+: resolv-conf-server ( -- ip ) resolv-conf-servers random ;
\ No newline at end of file
--- /dev/null
+
+USING: kernel continuations
+ combinators
+ sequences
+ math
+ random
+ unicode.case
+ accessors symbols
+ combinators.lib combinators.cleave
+ newfx
+ dns dns.cache ;
+
+IN: dns.recursive
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: root-dns-servers ( -- servers )
+ {
+ "192.5.5.241"
+ "192.112.36.4"
+ "128.63.2.53"
+ "192.36.148.17"
+ "192.58.128.30"
+ "193.0.14.129"
+ "199.7.83.42"
+ "202.12.27.33"
+ "198.41.0.4"
+ } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: {name-type-class} ( obj -- seq )
+ [ name>> >lower ] [ type>> ] [ class>> ] tri {3} ;
+
+: rr=query? ( rr query -- ? ) [ {name-type-class} ] bi@ = ;
+
+: rr-filter ( rrs query -- rrs ) [ rr=query? ] curry filter ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: answer-hits ( message -- rrs )
+ [ answer-section>> ] [ message-query ] bi rr-filter ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: name-hits ( message -- rrs )
+ [ answer-section>> ] [ message-query clone A >>type ] bi rr-filter ;
+
+: cname-hits ( message -- rrs )
+ [ answer-section>> ] [ message-query clone CNAME >>type ] bi rr-filter ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: authority-hits ( message -- rrs )
+ authority-section>> [ type>> NS = ] filter ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOLS: ANSWERED NO-NAME-SERVERS UNCLASSIFIED ;
+
+: classify-message ( message -- symbol )
+ {
+ { [ dup rcode>> NAME-ERROR = ] [ drop NAME-ERROR ] }
+ { [ dup rcode>> SERVER-FAILURE = ] [ drop SERVER-FAILURE ] }
+ { [ dup answer-hits empty? not ] [ drop ANSWERED ] }
+ { [ dup cname-hits empty? not ] [ drop CNAME ] }
+ { [ dup authority-hits empty? ] [ drop NO-NAME-SERVERS ] }
+ { [ t ] [ drop UNCLASSIFIED ] }
+ }
+ cond ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+DEFER: name->ip
+
+! : name->ip/f ( name -- ip/f ) [ name->ip ] [ drop f ] recover ;
+
+! : extract-ns-ips ( message -- ips )
+! authority-hits [ rdata>> name->ip/f ] map [ ] filter ;
+
+: extract-ns-ips ( message -- ips )
+ authority-hits [ rdata>> name->ip ] map [ ] filter ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: (recursive-query) ( query servers -- message )
+ dup random ! query servers server
+ pick query->message 0 >>rd ! query servers server message
+ over ask-server ! query servers server message
+ cache-message ! query servers server message
+ dup classify-message ! query servers server message sym
+ {
+ { NAME-ERROR [ -roll 3drop ] }
+ { ANSWERED [ -roll 3drop ] }
+ { CNAME [ -roll 3drop ] }
+ { NO-NAME-SERVERS [ -roll 3drop ] }
+ {
+ SERVER-FAILURE
+ [
+ -roll ! message query servers server
+ remove ! message query servers
+ dup empty?
+ [ 2drop ]
+ [ rot drop (recursive-query) ]
+ if
+ ]
+ }
+ [ ! query servers server message sym
+ drop nip nip ! query message
+ extract-ns-ips ! query ips
+ (recursive-query)
+ ]
+ }
+ case ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: cdr-name ( name -- name ) dup CHAR: . index 1+ tail ;
+
+: cache-get-ns ( name -- seq/f ) NS IN query boa cache-get ;
+
+: name->servers ( name -- servers )
+ {
+ { [ dup "" = ] [ drop root-dns-servers ] }
+ { [ dup cache-get-ns ] [ cache-get-ns [ rdata>> name->ip ] map ] }
+ { [ t ] [ cdr-name name->servers ] }
+ }
+ cond ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: recursive-query ( query -- message )
+ dup name>> name->servers (recursive-query) ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: canonical/cache ( name -- name )
+ dup CNAME IN query boa cache-get dup [ nip 1st rdata>> ] [ drop ] if ;
+
+: name->ip/cache ( name -- ip/f )
+ canonical/cache
+ A IN query boa cache-get dup [ random rdata>> ] [ ] if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: name-hits? ( message -- message ? ) dup name-hits empty? not ;
+: cname-hits? ( message -- message ? ) dup cname-hits empty? not ;
+
+! : name->ip/server ( name -- ip-or-f )
+! A IN query boa root-dns-servers recursive-query ! message
+! {
+! { [ name-hits? ] [ name-hits random rdata>> ] }
+! { [ cname-hits? ] [ cname-hits random rdata>> name->ip ] }
+! { [ t ] [ drop f ] }
+! }
+! cond ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: name->ip/server ( name -- ip-or-f )
+ A IN query boa recursive-query ! message
+ {
+ { [ name-hits? ] [ name-hits random rdata>> ] }
+ { [ cname-hits? ] [ cname-hits random rdata>> name->ip ] }
+ { [ t ] [ drop f ] }
+ }
+ cond ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! : name->ip ( name -- ip )
+! { [ name->ip/cache ] [ name->ip/server ] [ name-error ] } 1|| ;
+
+: name->ip ( name -- ip )
+ dup name->ip/cache dup
+ [ nip ]
+ [
+ drop dup name->ip/server dup
+ [ nip ]
+ [ drop name-error ]
+ if
+ ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Need to cache records even in the case of name error
-
-: cache-message ( message -- message )
- dup dup rcode>> NAME-ERROR =
- [
- [ question-section>> 1st ]
- [ authority-section>> [ type>> SOA = ] filter random ttl>> ]
- bi
- cache-nx
- ]
- [
- {
- [ answer-section>> cache-add-rrs ]
- [ authority-section>> cache-add-rrs ]
- [ additional-section>> cache-add-rrs ]
- }
- cleave
- ]
- if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! Ask and cache the records
-
-: ask* ( message -- message ) ask cache-message ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
: canonical/cache ( name -- name )
dup CNAME IN query boa cache-get dup vector? ! name result ?
[ nip 1st rdata>> ]
: name->ip/cache ( name -- ip )
canonical/cache
dup A IN query boa cache-get ! name result
- {
- {
- [ dup NX = ]
- [ 2drop f ]
- }
- {
- [ dup f = ]
- [ 2drop f ]
- }
{
- [ t ]
- [ nip random rdata>> ]
+ { [ dup NX = ] [ 2drop f ] }
+ { [ dup f = ] [ 2drop f ] }
+ { [ t ] [ nip random rdata>> ] }
}
- }
- cond ;
+ cond ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: canonical/server ( name -- name )
- dup CNAME IN query boa <query-message> ask* answer-section>>
+ dup CNAME IN query boa query->message ask cache-message answer-section>>
[ type>> CNAME = ] filter dup empty? not
[ nip 1st rdata>> ]
[ drop ]
: name->ip/server ( name -- ip )
canonical/server
- dup A IN query boa <query-message> ask* answer-section>>
+ dup A IN query boa query->message ask cache-message answer-section>>
[ type>> A = ] filter dup empty? not
[ nip random rdata>> ]
[ 2drop f ]
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: fully-qualified ( name -- name )
- {
- { [ dup empty? ] [ "." append ] }
- { [ dup peek CHAR: . = ] [ ] }
- { [ t ] [ "." append ] }
- }
- cond ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
: name->ip ( name -- ip )
fully-qualified
dup name->ip/cache dup
--- /dev/null
+
+USING: kernel sequences random accessors dns ;
+
+IN: dns.stub
+
+! Stub resolver
+!
+! Generally useful, but particularly when running a forwarding,
+! caching, nameserver on localhost with multiple Factor instances
+! querying it.
+
+: name->ip ( name -- ip )
+ A IN query boa
+ query->message
+ ask
+ dup rcode>> NAME-ERROR =
+ [ message-query name>> name-error ]
+ [ answer-section>> [ type>> A = ] filter random rdata>> ]
+ if ;
+
[ "<p>=</p><h2>foo</h2>" ] [ "===foo==" convert-farkup ] unit-test
[ "<h1>foo</h1><p>=</p>" ] [ "=foo==" convert-farkup ] unit-test
-[ "<div style='white-space: pre; font-family: monospace; '><span class='KEYWORD3'>int</span> <span class='FUNCTION'>main</span><span class='OPERATOR'>(</span><span class='OPERATOR'>)</span><br/></div>" ]
+[ "<pre><span class='KEYWORD3'>int</span> <span class='FUNCTION'>main</span><span class='OPERATOR'>(</span><span class='OPERATOR'>)</span>\n</pre>" ]
[ "[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\">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
[ ] [ "[{}]" convert-farkup drop ] unit-test
+
+[
+ "<p>Feature comparison:\n<table><tr><td>a</td><td>Factor</td><td>Java</td><td>Lisp</td></tr><tr><td>Coolness</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Badass</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Enterprise</td><td>Yes</td><td>Yes</td><td>No</td></tr><tr><td>Kosher</td><td>Yes</td><td>No</td><td>Yes</td></tr></table></p>"
+] [ "Feature comparison:\n|a|Factor|Java|Lisp|\n|Coolness|Yes|No|No|\n|Badass|Yes|No|No|\n|Enterprise|Yes|Yes|No|\n|Kosher|Yes|No|Yes|\n" convert-farkup ] unit-test
+
+[
+ "<p>Feature comparison:\n\n<table><tr><td>a</td><td>Factor</td><td>Java</td><td>Lisp</td></tr><tr><td>Coolness</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Badass</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Enterprise</td><td>Yes</td><td>Yes</td><td>No</td></tr><tr><td>Kosher</td><td>Yes</td><td>No</td><td>Yes</td></tr></table></p>"
+] [ "Feature comparison:\n\n|a|Factor|Java|Lisp|\n|Coolness|Yes|No|No|\n|Badass|Yes|No|No|\n|Enterprise|Yes|Yes|No|\n|Kosher|Yes|No|Yes|\n" convert-farkup ] unit-test
+
+[ "<p>a-b</p>" ] [ "a-b" convert-farkup ] unit-test
+[ "<ul><li>a-b</li></ul>" ] [ "-a-b" convert-farkup ] unit-test
! See http://factorcode.org/license.txt for BSD license.
USING: arrays io io.styles kernel memoize namespaces peg
sequences strings html.elements xml.entities xmode.code2html
-splitting io.streams.string html peg.parsers html.elements
+splitting io.streams.string peg.parsers
sequences.deep unicode.categories ;
IN: farkup
+SYMBOL: relative-link-prefix
+SYMBOL: link-no-follow?
+
<PRIVATE
: delimiters ( -- string )
: render-code ( string mode -- string' )
>r string-lines r>
[
- [
- H{ { wrap-margin f } } [
- htmlize-lines
- ] with-nesting
- ] with-html-stream
+ <pre>
+ htmlize-lines
+ </pre>
] with-string-writer ;
: check-url ( href -- href' )
CHAR: : over member? [
dup { "http://" "https://" "ftp://" } [ head? ] with contains?
[ drop "/" ] unless
- ] when ;
+ ] [
+ relative-link-prefix get prepend
+ ] if ;
: escape-link ( href text -- href-esc text-esc )
>r check-url escape-quoted-string r> escape-string ;
: make-link ( href text -- seq )
escape-link
- [ "<a href=\"" , >r , r> "\">" , [ , ] when* "</a>" , ] { } make ;
+ [
+ "<a" ,
+ " href=\"" , >r , r>
+ link-no-follow? get [ " nofollow=\"true\"" , ] when
+ "\">" , , "</a>" ,
+ ] { } make ;
: make-image-link ( href alt -- seq )
escape-link
"[[" token hide ,
[ "|]" member? not ] satisfy repeat1 ,
"]]" token hide ,
- ] seq* [ first f make-link ] action ;
+ ] seq* [ first dup make-link ] action ;
MEMO: labelled-link ( -- parser )
[
"]]" token hide ,
] seq* [ first2 make-link ] action ;
-MEMO: link ( -- parser ) [ image-link , simple-link , labelled-link , ] choice* ;
+MEMO: link ( -- parser )
+ [ image-link , simple-link , labelled-link , ] choice* ;
DEFER: line
MEMO: list-item ( -- parser )
[
- "-" token hide , line ,
+ "-" token hide , ! text ,
+ [ "\r\n" member? not ] satisfy repeat1 [ >string escape-string ] action ,
] seq* [ "li" surround-with-foo ] action ;
MEMO: list ( -- parser )
MEMO: line ( -- parser )
[
+ nl table 2seq ,
+ nl list 2seq ,
text , strong , emphasis , link ,
superscript , subscript , inline-code ,
escaped-char , delimiter , eq ,
[ { 1 { 2 { 3 } } } ] [
1 2 3 '[ , [ , [ , 1array ] call 2array ] call 2array ] call
] unit-test
+
+{ 1 1 } [ '[ [ [ , ] ] ] ] must-infer-as
+
+[ { { { 3 } } } ] [
+ 3 '[ [ [ , 1array ] call 1array ] call 1array ] call
+] unit-test
+
+[ { { { 3 } } } ] [
+ 3 '[ [ [ , 1array ] call 1array ] call 1array ] call
+] unit-test
shallow-fry
] if* ;
+: fry-specifier? ( obj -- ? ) { , namespaces:, @ } member? ;
+
+: count-inputs ( quot -- n )
+ [
+ {
+ { [ dup callable? ] [ count-inputs ] }
+ { [ dup fry-specifier? ] [ drop 1 ] }
+ [ drop 0 ]
+ } cond
+ ] map sum ;
+
: fry ( quot -- quot' )
[
[
dup callable? [
- [
- [ { , namespaces:, @ } member? ] filter length
- \ , <repetition> %
- ]
- [ fry % ] bi
+ [ count-inputs \ , <repetition> % ] [ fry % ] bi
] [ namespaces:, ] if
] each
] [ ] make deep-fry ;
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: parser-combinators regexp lazy-lists sequences kernel
+USING: parser-combinators regexp lists lists.lazy sequences kernel
promises strings unicode.case ;
IN: globs
+++ /dev/null
-Slava Pestov
-Matthew Willis
-Chris Double
--- /dev/null
+IN: html.components.tests
+USING: tools.test kernel io.streams.string
+io.streams.null accessors inspector html.streams
+html.components namespaces ;
+
+[ ] [ blank-values ] unit-test
+
+[ ] [ 3 "hi" set-value ] unit-test
+
+[ 3 ] [ "hi" value ] unit-test
+
+TUPLE: color red green blue ;
+
+[ ] [ 1 2 3 color boa from-tuple ] unit-test
+
+[ 1 ] [ "red" value ] unit-test
+
+[ ] [ "jimmy" "red" set-value ] unit-test
+
+[ "123.5" ] [ 123.5 object>string ] unit-test
+
+[ "jimmy" ] [
+ [
+ "red" label render
+ ] with-string-writer
+] unit-test
+
+[ ] [ "<jimmy>" "red" set-value ] unit-test
+
+[ "<jimmy>" ] [
+ [
+ "red" label render
+ ] with-string-writer
+] unit-test
+
+[ "<input type='hidden' name='red' value='<jimmy>'/>" ] [
+ [
+ "red" hidden render
+ ] with-string-writer
+] unit-test
+
+[ ] [ "'jimmy'" "red" set-value ] unit-test
+
+[ "<input type='text' size='5' name='red' value=''jimmy''/>" ] [
+ [
+ "red" <field> 5 >>size render
+ ] with-string-writer
+] unit-test
+
+[ "<input type='password' size='5' name='red' value=''/>" ] [
+ [
+ "red" <password> 5 >>size render
+ ] with-string-writer
+] unit-test
+
+[ ] [
+ [
+ "green" <textarea> render
+ ] with-null-writer
+] unit-test
+
+[ ] [
+ [
+ "green" <textarea> 25 >>rows 30 >>cols render
+ ] with-null-writer
+] unit-test
+
+[ ] [ blank-values ] unit-test
+
+[ ] [ "new york" "city1" set-value ] unit-test
+
+[ ] [ { "new york" "los angeles" "chicago" } "cities" set-value ] unit-test
+
+[ ] [
+ [
+ "city1"
+ <choice>
+ "cities" >>choices
+ render
+ ] with-null-writer
+] unit-test
+
+[ ] [ { "los angeles" "new york" } "city2" set-value ] unit-test
+
+[ ] [
+ [
+ "city2"
+ <choice>
+ "cities" >>choices
+ t >>multiple
+ render
+ ] with-null-writer
+] unit-test
+
+[ ] [
+ [
+ "city2"
+ <choice>
+ "cities" >>choices
+ t >>multiple
+ 5 >>size
+ render
+ ] with-null-writer
+] unit-test
+
+[ ] [ blank-values ] unit-test
+
+[ ] [ t "delivery" set-value ] unit-test
+
+[ "<input type='checkbox' name='delivery' selected='true'>Delivery</input>" ] [
+ [
+ "delivery"
+ <checkbox>
+ "Delivery" >>label
+ render
+ ] with-string-writer
+] unit-test
+
+[ ] [ f "delivery" set-value ] unit-test
+
+[ "<input type='checkbox' name='delivery'>Delivery</input>" ] [
+ [
+ "delivery"
+ <checkbox>
+ "Delivery" >>label
+ render
+ ] with-string-writer
+] unit-test
+
+SINGLETON: link-test
+
+M: link-test link-title drop "<Link Title>" ;
+
+M: link-test link-href drop "http://www.apple.com/foo&bar" ;
+
+[ ] [ link-test "link" set-value ] unit-test
+
+[ "<a href='http://www.apple.com/foo&bar'><Link Title></a>" ] [
+ [ "link" link render ] with-string-writer
+] unit-test
+
+[ ] [
+ "<html>arbitrary <b>markup</b> for the win!</html>" "html" set-value
+] unit-test
+
+[ "<html>arbitrary <b>markup</b> for the win!</html>" ] [
+ [ "html" html render ] with-string-writer
+] unit-test
+
+[ ] [ "int x = 4;" "code" set-value ] unit-test
+
+[ ] [ "java" "mode" set-value ] unit-test
+
+[ "<span class='KEYWORD3'>int</span> x <span class='OPERATOR'>=</span> <span class='DIGIT'>4</span>;\n" ] [
+ [ "code" <code> "mode" >>mode render ] with-string-writer
+] unit-test
+
+[ ] [ "-foo\n-bar" "farkup" set-value ] unit-test
+
+[ "<ul><li>foo</li><li>bar</li></ul>" ] [
+ [ "farkup" farkup render ] with-string-writer
+] unit-test
+
+[ ] [ { 1 2 3 } "object" set-value ] unit-test
+
+[ t ] [
+ [ "object" inspector render ] with-string-writer
+ [ "object" value [ describe ] with-html-stream ] with-string-writer
+ =
+] unit-test
+
+[ ] [ blank-values ] unit-test
+
+[ ] [
+ "factor" [
+ "concatenative" "model" set-value
+ ] nest-values
+] unit-test
+
+[ H{ { "factor" H{ { "model" "concatenative" } } } } ] [ values get ] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel namespaces io math.parser assocs classes
+classes.tuple words arrays sequences sequences.lib splitting
+mirrors hashtables combinators continuations math strings
+fry locals calendar calendar.format xml.entities validators
+html.elements html.streams xmode.code2html farkup inspector
+lcs.diff2html ;
+IN: html.components
+
+SYMBOL: values
+
+: value values get at ;
+
+: set-value values get set-at ;
+
+: blank-values H{ } clone values set ;
+
+: prepare-value ( name object -- value name object )
+ [ [ value ] keep ] dip ; inline
+
+: from-assoc ( assoc -- ) values get swap update ;
+
+: from-tuple ( tuple -- ) <mirror> from-assoc ;
+
+: deposit-values ( destination names -- )
+ [ dup value ] H{ } map>assoc update ;
+
+: deposit-slots ( destination names -- )
+ [ <mirror> ] dip deposit-values ;
+
+: with-each-index ( seq quot -- )
+ '[
+ [
+ blank-values 1+ "index" set-value @
+ ] with-scope
+ ] each-index ; inline
+
+: with-each-value ( seq quot -- )
+ '[ "value" set-value @ ] with-each-index ; inline
+
+: with-each-assoc ( seq quot -- )
+ '[ from-assoc @ ] with-each-index ; inline
+
+: with-each-tuple ( seq quot -- )
+ '[ from-tuple @ ] with-each-index ; inline
+
+: with-assoc-values ( assoc quot -- )
+ '[ blank-values , from-assoc @ ] with-scope ; inline
+
+: with-tuple-values ( assoc quot -- )
+ '[ blank-values , from-tuple @ ] with-scope ; inline
+
+: nest-values ( name quot -- )
+ swap [
+ [
+ H{ } clone [ values set call ] keep
+ ] with-scope
+ ] dip set-value ; inline
+
+: nest-tuple ( name quot -- )
+ swap [
+ [
+ H{ } clone [ <mirror> values set call ] keep
+ ] with-scope
+ ] dip set-value ; inline
+
+: object>string ( object -- string )
+ {
+ { [ dup real? ] [ number>string ] }
+ { [ dup timestamp? ] [ timestamp>string ] }
+ { [ dup string? ] [ ] }
+ { [ dup word? ] [ word-name ] }
+ { [ dup not ] [ drop "" ] }
+ } cond ;
+
+GENERIC: render* ( value name render -- )
+
+: render ( name renderer -- )
+ over named-validation-messages get at [
+ [ value>> ] [ message>> ] bi
+ [ -rot render* ] dip
+ render-error
+ ] [
+ prepare-value render*
+ ] if* ;
+
+<PRIVATE
+
+: render-input ( value name type -- )
+ <input =type =name object>string =value input/> ;
+
+PRIVATE>
+
+SINGLETON: label
+
+M: label render* 2drop object>string escape-string write ;
+
+SINGLETON: hidden
+
+M: hidden render* drop "hidden" render-input ;
+
+: render-field ( value name size type -- )
+ <input
+ =type
+ [ object>string =size ] when*
+ =name
+ object>string =value
+ input/> ;
+
+TUPLE: field size ;
+
+: <field> ( -- field )
+ field new ;
+
+M: field render* size>> "text" render-field ;
+
+TUPLE: password size ;
+
+: <password> ( -- password )
+ password new ;
+
+M: password render*
+ #! Don't send passwords back to the user
+ [ drop "" ] 2dip size>> "password" render-field ;
+
+! Text areas
+TUPLE: textarea rows cols ;
+
+: <textarea> ( -- renderer )
+ textarea new ;
+
+M: textarea render*
+ <textarea
+ [ rows>> [ object>string =rows ] when* ]
+ [ cols>> [ object>string =cols ] when* ] bi
+ =name
+ textarea>
+ object>string escape-string write
+ </textarea> ;
+
+! Choice
+TUPLE: choice size multiple choices ;
+
+: <choice> ( -- choice )
+ choice new ;
+
+: render-option ( text selected? -- )
+ <option [ "true" =selected ] when option>
+ object>string escape-string write
+ </option> ;
+
+: render-options ( options selected -- )
+ '[ dup , member? render-option ] each ;
+
+M: choice render*
+ <select
+ swap =name
+ dup size>> [ object>string =size ] when*
+ dup multiple>> [ "true" =multiple ] when
+ select>
+ [ choices>> value ] [ multiple>> ] bi
+ [ swap ] [ swap 1array ] if
+ render-options
+ </select> ;
+
+! Checkboxes
+TUPLE: checkbox label ;
+
+: <checkbox> ( -- checkbox )
+ checkbox new ;
+
+M: checkbox render*
+ <input
+ "checkbox" =type
+ swap =name
+ swap [ "true" =selected ] when
+ input>
+ label>> escape-string write
+ </input> ;
+
+! Link components
+GENERIC: link-title ( obj -- string )
+GENERIC: link-href ( obj -- url )
+
+SINGLETON: link
+
+M: link render*
+ 2drop
+ <a dup link-href =href a>
+ link-title object>string escape-string write
+ </a> ;
+
+! XMode code component
+TUPLE: code mode ;
+
+: <code> ( -- code )
+ code new ;
+
+M: code render*
+ [ string-lines ] [ drop ] [ mode>> value ] tri* htmlize-lines ;
+
+! Farkup component
+SINGLETON: farkup
+
+M: farkup render*
+ 2drop string-lines "\n" join convert-farkup write ;
+
+! Inspector component
+SINGLETON: inspector
+
+M: inspector render*
+ 2drop [ describe ] with-html-stream ;
+
+! Diff component
+SINGLETON: comparison
+
+M: comparison render*
+ 2drop htmlize-diff ;
+
+! HTML component
+SINGLETON: html
+
+M: html render* 2drop write ;
IN: html.elements.tests
-USING: tools.test html html.elements io.streams.string ;
-
-: make-html-string
- [ with-html-stream ] with-string-writer ;
+USING: tools.test html.elements io.streams.string ;
[ "<a href='h&o'>" ]
-[ [ <a "h&o" =href a> ] make-html-string ] unit-test
+[ [ <a "h&o" =href a> ] with-string-writer ] unit-test
: print-html ( str -- )
write-html "\n" write-html ;
+<<
+
: html-word ( name def effect -- )
#! Define 'word creating' word to allow
#! dynamically creating words.
dup "=" prepend swap
[ write-attr ] curry attribute-effect html-word ;
+! Define some closed HTML tags
+[
+ "h1" "h2" "h3" "h4" "h5" "h6" "h7" "h8" "h9"
+ "ol" "li" "form" "a" "p" "html" "head" "body" "title"
+ "b" "i" "ul" "table" "tbody" "tr" "td" "th" "pre" "textarea"
+ "script" "div" "span" "select" "option" "style" "input"
+] [ define-closed-html-word ] each
+
+! Define some open HTML tags
+[
+ "input"
+ "br"
+ "link"
+ "img"
+] [ define-open-html-word ] each
+
+! Define some attributes
[
- ! Define some closed HTML tags
- [
- "h1" "h2" "h3" "h4" "h5" "h6" "h7" "h8" "h9"
- "ol" "li" "form" "a" "p" "html" "head" "body" "title"
- "b" "i" "ul" "table" "tbody" "tr" "td" "th" "pre" "textarea"
- "script" "div" "span" "select" "option" "style" "input"
- ] [ define-closed-html-word ] each
-
- ! Define some open HTML tags
- [
- "input"
- "br"
- "link"
- "img"
- ] [ define-open-html-word ] each
-
- ! Define some attributes
- [
- "method" "action" "type" "value" "name"
- "size" "href" "class" "border" "rows" "cols"
- "id" "onclick" "style" "valign" "accesskey"
- "src" "language" "colspan" "onchange" "rel"
- "width" "selected" "onsubmit" "xmlns" "lang" "xml:lang"
- "media" "title" "multiple"
- ] [ define-attribute-word ] each
-] with-compilation-unit
+ "method" "action" "type" "value" "name"
+ "size" "href" "class" "border" "rows" "cols"
+ "id" "onclick" "style" "valign" "accesskey"
+ "src" "language" "colspan" "onchange" "rel"
+ "width" "selected" "onsubmit" "xmlns" "lang" "xml:lang"
+ "media" "title" "multiple"
+] [ define-attribute-word ] each
+
+>>
+
+: xhtml-preamble ( -- )
+ "<?xml version=\"1.0\"?>" write-html
+ "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">" write-html ;
+
+: simple-page ( title quot -- )
+ #! Call the quotation, with all output going to the
+ #! body of an html page with the given title.
+ xhtml-preamble
+ <html "http://www.w3.org/1999/xhtml" =xmlns "en" =xml:lang "en" =lang html>
+ <head> <title> swap write </title> </head>
+ <body> call </body>
+ </html> ;
+
+: render-error ( message -- )
+ <span "error" =class span> escape-string write </span> ;
+++ /dev/null
-USING: html http io io.streams.string io.styles kernel
-namespaces tools.test xml.writer sbufs sequences html.private ;
-IN: html.tests
-
-: make-html-string
- [ with-html-stream ] with-string-writer ; inline
-
-[ [ ] make-html-string ] must-infer
-
-[ ] [
- 512 <sbuf> <html-stream> drop
-] unit-test
-
-[ "" ] [
- [ "" write ] make-html-string
-] unit-test
-
-[ "a" ] [
- [ CHAR: a write1 ] make-html-string
-] unit-test
-
-[ "<" ] [
- [ "<" write ] make-html-string
-] unit-test
-
-[ "<" ] [
- [ "<" H{ } output-stream get format-html-span ] make-html-string
-] unit-test
-
-TUPLE: funky town ;
-
-M: funky browser-link-href
- "http://www.funky-town.com/" swap funky-town append ;
-
-[ "<a href='http://www.funky-town.com/austin'><</a>" ] [
- [
- "<" "austin" funky boa write-object
- ] make-html-string
-] unit-test
-
-[ "<span style='font-family: monospace; '>car</span>" ]
-[
- [
- "car"
- H{ { font "monospace" } }
- format
- ] make-html-string
-] unit-test
-
-[ "<span style='color: #ff00ff; '>car</span>" ]
-[
- [
- "car"
- H{ { foreground { 1 0 1 1 } } }
- format
- ] make-html-string
-] unit-test
-
-[ "<div style='background-color: #ff00ff; white-space: pre; font-family: monospace; '>cdr</div>" ]
-[
- [
- H{ { page-color { 1 0 1 1 } } }
- [ "cdr" write ] with-nesting
- ] make-html-string
-] unit-test
-
-[
- "<div style='white-space: pre; font-family: monospace; '></div>"
-] [
- [ H{ } [ ] with-nesting nl ] make-html-string
-] unit-test
+++ /dev/null
-! Copyright (C) 2004, 2006 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: generic assocs help http io io.styles io.files continuations
-io.streams.string kernel math math.order math.parser namespaces
-quotations assocs sequences strings words html.elements
-xml.entities sbufs continuations destructors ;
-IN: html
-
-GENERIC: browser-link-href ( presented -- href )
-
-M: object browser-link-href drop f ;
-
-TUPLE: html-stream last-div? ;
-
-! A hack: stream-nl after with-nesting or tabular-output is
-! ignored, so that HTML stream output looks like UI pane output
-: test-last-div? ( stream -- ? )
- dup html-stream-last-div?
- f rot set-html-stream-last-div? ;
-
-: not-a-div ( stream -- stream )
- dup test-last-div? drop ; inline
-
-: a-div ( stream -- straem )
- t over set-html-stream-last-div? ; inline
-
-: <html-stream> ( stream -- stream )
- html-stream construct-delegate ;
-
-<PRIVATE
-
-TUPLE: html-sub-stream style stream ;
-
-: (html-sub-stream) ( style stream -- stream )
- html-sub-stream boa
- 512 <sbuf> <html-stream> over set-delegate ;
-
-: <html-sub-stream> ( style stream class -- stream )
- >r (html-sub-stream) r> construct-delegate ; inline
-
-: end-sub-stream ( substream -- string style stream )
- dup delegate >string
- over html-sub-stream-style
- rot html-sub-stream-stream ;
-
-: delegate-write ( string -- )
- output-stream get delegate stream-write ;
-
-: object-link-tag ( style quot -- )
- presented pick at [
- browser-link-href [
- <a =href a> call </a>
- ] [ call ] if*
- ] [ call ] if* ; inline
-
-: hex-color, ( triplet -- )
- 3 head-slice
- [ 255 * >fixnum >hex 2 CHAR: 0 pad-left % ] each ;
-
-: fg-css, ( color -- )
- "color: #" % hex-color, "; " % ;
-
-: bg-css, ( color -- )
- "background-color: #" % hex-color, "; " % ;
-
-: style-css, ( flag -- )
- dup
- { italic bold-italic } member?
- "font-style: " % "italic" "normal" ? % "; " %
- { bold bold-italic } member?
- "font-weight: " % "bold" "normal" ? % "; " % ;
-
-: size-css, ( size -- )
- "font-size: " % # "pt; " % ;
-
-: font-css, ( font -- )
- "font-family: " % % "; " % ;
-
-: apply-style ( style key quot -- style gadget )
- >r over at r> when* ; inline
-
-: make-css ( style quot -- str )
- "" make nip ; inline
-
-: span-css-style ( style -- str )
- [
- foreground [ fg-css, ] apply-style
- background [ bg-css, ] apply-style
- font [ font-css, ] apply-style
- font-style [ style-css, ] apply-style
- font-size [ size-css, ] apply-style
- ] make-css ;
-
-: span-tag ( style quot -- )
- over span-css-style dup empty? [
- drop call
- ] [
- <span =style span> call </span>
- ] if ; inline
-
-: format-html-span ( string style stream -- )
- [
- [ [ drop delegate-write ] span-tag ] object-link-tag
- ] with-output-stream* ;
-
-TUPLE: html-span-stream ;
-
-M: html-span-stream dispose
- end-sub-stream not-a-div format-html-span ;
-
-: border-css, ( border -- )
- "border: 1px solid #" % hex-color, "; " % ;
-
-: padding-css, ( padding -- ) "padding: " % # "px; " % ;
-
-: pre-css, ( margin -- )
- [ "white-space: pre; font-family: monospace; " % ] unless ;
-
-: div-css-style ( style -- str )
- [
- page-color [ bg-css, ] apply-style
- border-color [ border-css, ] apply-style
- border-width [ padding-css, ] apply-style
- wrap-margin over at pre-css,
- ] make-css ;
-
-: div-tag ( style quot -- )
- swap div-css-style dup empty? [
- drop call
- ] [
- <div =style div> call </div>
- ] if ; inline
-
-: format-html-div ( string style stream -- )
- [
- [ [ delegate-write ] div-tag ] object-link-tag
- ] with-output-stream* ;
-
-TUPLE: html-block-stream ;
-
-M: html-block-stream dispose ( quot style stream -- )
- end-sub-stream a-div format-html-div ;
-
-: border-spacing-css,
- "padding: " % first2 max 2 /i # "px; " % ;
-
-: table-style ( style -- str )
- [
- table-border [ border-css, ] apply-style
- table-gap [ border-spacing-css, ] apply-style
- ] make-css ;
-
-: table-attrs ( style -- )
- table-style " border-collapse: collapse;" append =style ;
-
-: do-escaping ( string style -- string )
- html swap at [ escape-string ] unless ;
-
-PRIVATE>
-
-! Stream protocol
-M: html-stream stream-write1 ( char stream -- )
- >r 1string r> stream-write ;
-
-M: html-stream stream-write ( str stream -- )
- not-a-div >r escape-string r> delegate stream-write ;
-
-M: html-stream make-span-stream ( style stream -- stream' )
- html-span-stream <html-sub-stream> ;
-
-M: html-stream stream-format ( str style stream -- )
- >r html over at [ >r escape-string r> ] unless r>
- format-html-span ;
-
-M: html-stream make-block-stream ( style stream -- stream' )
- html-block-stream <html-sub-stream> ;
-
-M: html-stream stream-write-table ( grid style stream -- )
- a-div [
- <table dup table-attrs table> swap [
- <tr> [
- <td "top" =valign swap table-style =style td>
- >string write-html
- </td>
- ] with each </tr>
- ] with each </table>
- ] with-output-stream* ;
-
-M: html-stream make-cell-stream ( style stream -- stream' )
- (html-sub-stream) ;
-
-M: html-stream stream-nl ( stream -- )
- dup test-last-div? [ drop ] [ [ <br/> ] with-output-stream* ] if ;
-
-! Utilities
-: with-html-stream ( quot -- )
- output-stream get <html-stream> swap with-output-stream* ; inline
-
-: xhtml-preamble
- "<?xml version=\"1.0\"?>" write-html
- "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">" write-html ;
-
-: html-document ( body-quot head-quot -- )
- #! head-quot is called to produce output to go
- #! in the html head portion of the document.
- #! body-quot is called to produce output to go
- #! in the html body portion of the document.
- xhtml-preamble
- <html "http://www.w3.org/1999/xhtml" =xmlns "en" =xml:lang "en" =lang html>
- <head> call </head>
- <body> call </body>
- </html> ;
-
-: default-css ( -- )
- <link
- "stylesheet" =rel "text/css" =type
- "/responder/resources/extra/html/stylesheet.css" =href
- link/> ;
-
-: simple-html-document ( title quot -- )
- swap [
- <title> write </title>
- default-css
- ] html-document ;
-
-: vertical-layout ( list -- )
- #! Given a list of HTML components, arrange them vertically.
- <table>
- [ <tr> <td> call </td> </tr> ] each
- </table> ;
-
-: horizontal-layout ( list -- )
- #! Given a list of HTML components, arrange them horizontally.
- <table>
- <tr "top" =valign tr> [ <td> call </td> ] each </tr>
- </table> ;
-
-: button ( label -- )
- #! Output an HTML submit button with the given label.
- <input "submit" =type =value input/> ;
-
-: paragraph ( str -- )
- #! Output the string as an html paragraph
- <p> write </p> ;
-
-: simple-page ( title quot -- )
- #! Call the quotation, with all output going to the
- #! body of an html page with the given title.
- <html>
- <head> <title> swap write </title> </head>
- <body> call </body>
- </html> ;
-
-: styled-page ( title stylesheet-quot quot -- )
- #! Call the quotation, with all output going to the
- #! body of an html page with the given title. stylesheet-quot
- #! is called to generate the required stylesheet.
- <html>
- <head>
- <title> rot write </title>
- swap call
- </head>
- <body> call </body>
- </html> ;
-
-: render-error ( message -- )
- <span "error" =class span> escape-string write </span> ;
--- /dev/null
+Slava Pestov
+Matthew Willis
+Chris Double
--- /dev/null
+USING: html.streams html.streams.private
+io io.streams.string io.styles kernel
+namespaces tools.test xml.writer sbufs sequences inspector ;
+IN: html.streams.tests
+
+: make-html-string
+ [ with-html-stream ] with-string-writer ; inline
+
+[ [ ] make-html-string ] must-infer
+
+[ ] [
+ 512 <sbuf> <html-stream> drop
+] unit-test
+
+[ "" ] [
+ [ "" write ] make-html-string
+] unit-test
+
+[ "a" ] [
+ [ CHAR: a write1 ] make-html-string
+] unit-test
+
+[ "<" ] [
+ [ "<" write ] make-html-string
+] unit-test
+
+[ "<" ] [
+ [ "<" H{ } output-stream get format-html-span ] make-html-string
+] unit-test
+
+TUPLE: funky town ;
+
+M: funky browser-link-href
+ "http://www.funky-town.com/" swap funky-town append ;
+
+[ "<a href='http://www.funky-town.com/austin'><</a>" ] [
+ [
+ "<" "austin" funky boa write-object
+ ] make-html-string
+] unit-test
+
+[ "<span style='font-family: monospace; '>car</span>" ]
+[
+ [
+ "car"
+ H{ { font "monospace" } }
+ format
+ ] make-html-string
+] unit-test
+
+[ "<span style='color: #ff00ff; '>car</span>" ]
+[
+ [
+ "car"
+ H{ { foreground { 1 0 1 1 } } }
+ format
+ ] make-html-string
+] unit-test
+
+[ "<div style='background-color: #ff00ff; white-space: pre; font-family: monospace; '>cdr</div>" ]
+[
+ [
+ H{ { page-color { 1 0 1 1 } } }
+ [ "cdr" write ] with-nesting
+ ] make-html-string
+] unit-test
+
+[
+ "<div style='white-space: pre; font-family: monospace; '></div>"
+] [
+ [ H{ } [ ] with-nesting nl ] make-html-string
+] unit-test
+
+[ ] [ [ { 1 2 3 } describe ] with-html-stream ] unit-test
--- /dev/null
+! Copyright (C) 2004, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: generic assocs help http io io.styles io.files continuations
+io.streams.string kernel math math.order math.parser namespaces
+quotations assocs sequences strings words html.elements
+xml.entities sbufs continuations destructors accessors ;
+IN: html.streams
+
+GENERIC: browser-link-href ( presented -- href )
+
+M: object browser-link-href drop f ;
+
+TUPLE: html-stream stream last-div ;
+
+! stream-nl after with-nesting or tabular-output is
+! ignored, so that HTML stream output looks like
+! UI pane output
+: last-div? ( stream -- ? )
+ [ f ] change-last-div drop ;
+
+: not-a-div ( stream -- stream )
+ f >>last-div ; inline
+
+: a-div ( stream -- straem )
+ t >>last-div ; inline
+
+: <html-stream> ( stream -- stream )
+ f html-stream boa ;
+
+<PRIVATE
+
+TUPLE: html-sub-stream < html-stream style parent ;
+
+: new-html-sub-stream ( style stream class -- stream )
+ new
+ 512 <sbuf> >>stream
+ swap >>parent
+ swap >>style ; inline
+
+: end-sub-stream ( substream -- string style stream )
+ [ stream>> >string ] [ style>> ] [ parent>> ] tri ;
+
+: object-link-tag ( style quot -- )
+ presented pick at [
+ browser-link-href [
+ <a =href a> call </a>
+ ] [ call ] if*
+ ] [ call ] if* ; inline
+
+: hex-color, ( triplet -- )
+ 3 head-slice
+ [ 255 * >fixnum >hex 2 CHAR: 0 pad-left % ] each ;
+
+: fg-css, ( color -- )
+ "color: #" % hex-color, "; " % ;
+
+: bg-css, ( color -- )
+ "background-color: #" % hex-color, "; " % ;
+
+: style-css, ( flag -- )
+ dup
+ { italic bold-italic } member?
+ "font-style: " % "italic" "normal" ? % "; " %
+ { bold bold-italic } member?
+ "font-weight: " % "bold" "normal" ? % "; " % ;
+
+: size-css, ( size -- )
+ "font-size: " % # "pt; " % ;
+
+: font-css, ( font -- )
+ "font-family: " % % "; " % ;
+
+: apply-style ( style key quot -- style gadget )
+ >r over at r> when* ; inline
+
+: make-css ( style quot -- str )
+ "" make nip ; inline
+
+: span-css-style ( style -- str )
+ [
+ foreground [ fg-css, ] apply-style
+ background [ bg-css, ] apply-style
+ font [ font-css, ] apply-style
+ font-style [ style-css, ] apply-style
+ font-size [ size-css, ] apply-style
+ ] make-css ;
+
+: span-tag ( style quot -- )
+ over span-css-style dup empty? [
+ drop call
+ ] [
+ <span =style span> call </span>
+ ] if ; inline
+
+: format-html-span ( string style stream -- )
+ stream>> [
+ [ [ drop write ] span-tag ] object-link-tag
+ ] with-output-stream* ;
+
+TUPLE: html-span-stream < html-sub-stream ;
+
+M: html-span-stream dispose
+ end-sub-stream not-a-div format-html-span ;
+
+: border-css, ( border -- )
+ "border: 1px solid #" % hex-color, "; " % ;
+
+: padding-css, ( padding -- ) "padding: " % # "px; " % ;
+
+: pre-css, ( margin -- )
+ [ "white-space: pre; font-family: monospace; " % ] unless ;
+
+: div-css-style ( style -- str )
+ [
+ page-color [ bg-css, ] apply-style
+ border-color [ border-css, ] apply-style
+ border-width [ padding-css, ] apply-style
+ wrap-margin over at pre-css,
+ ] make-css ;
+
+: div-tag ( style quot -- )
+ swap div-css-style dup empty? [
+ drop call
+ ] [
+ <div =style div> call </div>
+ ] if ; inline
+
+: format-html-div ( string style stream -- )
+ stream>> [
+ [ [ write ] div-tag ] object-link-tag
+ ] with-output-stream* ;
+
+TUPLE: html-block-stream < html-sub-stream ;
+
+M: html-block-stream dispose ( quot style stream -- )
+ end-sub-stream a-div format-html-div ;
+
+: border-spacing-css,
+ "padding: " % first2 max 2 /i # "px; " % ;
+
+: table-style ( style -- str )
+ [
+ table-border [ border-css, ] apply-style
+ table-gap [ border-spacing-css, ] apply-style
+ ] make-css ;
+
+: table-attrs ( style -- )
+ table-style " border-collapse: collapse;" append =style ;
+
+: do-escaping ( string style -- string )
+ html swap at [ escape-string ] unless ;
+
+PRIVATE>
+
+! Stream protocol
+M: html-stream stream-flush
+ stream>> stream-flush ;
+
+M: html-stream stream-write1
+ >r 1string r> stream-write ;
+
+M: html-stream stream-write
+ not-a-div >r escape-string r> stream>> stream-write ;
+
+M: html-stream stream-format
+ >r html over at [ >r escape-string r> ] unless r>
+ format-html-span ;
+
+M: html-stream stream-nl
+ dup last-div? [ drop ] [ [ <br/> ] with-output-stream* ] if ;
+
+M: html-stream make-span-stream
+ html-span-stream new-html-sub-stream ;
+
+M: html-stream make-block-stream
+ html-block-stream new-html-sub-stream ;
+
+M: html-stream make-cell-stream
+ html-sub-stream new-html-sub-stream ;
+
+M: html-stream stream-write-table
+ a-div stream>> [
+ <table dup table-attrs table> swap [
+ <tr> [
+ <td "top" =valign swap table-style =style td>
+ stream>> >string write
+ </td>
+ ] with each </tr>
+ ] with each </table>
+ ] with-output-stream* ;
+
+M: html-stream dispose stream>> dispose ;
+
+: with-html-stream ( quot -- )
+ output-stream get <html-stream> swap with-output-stream* ; inline
--- /dev/null
+HTML reader, writer and utilities
+++ /dev/null
-a:link { text-decoration: none; color: black; }
-a:visited { text-decoration: none; color: black; }
-a:active { text-decoration: none; color: black; }
-a:hover { text-decoration: underline; color: black; }
+++ /dev/null
-HTML reader, writer and utilities
--- /dev/null
+USING: html.templates html.templates.chloe
+tools.test io.streams.string kernel sequences ascii boxes
+namespaces xml html.components
+splitting unicode.categories ;
+IN: html.templates.chloe.tests
+
+[ f ] [ f parse-query-attr ] unit-test
+
+[ f ] [ "" parse-query-attr ] unit-test
+
+[ H{ { "a" "b" } } ] [
+ blank-values
+ "b" "a" set-value
+ "a" parse-query-attr
+] unit-test
+
+[ H{ { "a" "b" } { "c" "d" } } ] [
+ blank-values
+ "b" "a" set-value
+ "d" "c" set-value
+ "a,c" parse-query-attr
+] unit-test
+
+: run-template
+ with-string-writer [ "\r\n\t" member? not ] filter
+ "?>" split1 nip ; inline
+
+: test-template ( name -- template )
+ "resource:extra/html/templates/chloe/test/"
+ swap
+ ".xml" 3append <chloe> ;
+
+[ "Hello world" ] [
+ [
+ "test1" test-template call-template
+ ] run-template
+] unit-test
+
+[ "Blah blah" "Hello world" ] [
+ [
+ <box> title set
+ [
+ "test2" test-template call-template
+ ] run-template
+ title get box>
+ ] with-scope
+] unit-test
+
+[ "<html><head><title>Hello world</title></head><body>Blah blah</body></html>" ] [
+ [
+ [
+ "test2" test-template call-template
+ ] "test3" test-template with-boilerplate
+ ] run-template
+] unit-test
+
+: test4-aux? t ;
+
+[ "True" ] [
+ [
+ "test4" test-template call-template
+ ] run-template
+] unit-test
+
+: test5-aux? f ;
+
+[ "" ] [
+ [
+ "test5" test-template call-template
+ ] run-template
+] unit-test
+
+SYMBOL: test6-aux?
+
+[ "True" ] [
+ [
+ test6-aux? on
+ "test6" test-template call-template
+ ] run-template
+] unit-test
+
+SYMBOL: test7-aux?
+
+[ "" ] [
+ [
+ test7-aux? off
+ "test7" test-template call-template
+ ] run-template
+] unit-test
+
+[ ] [ blank-values ] unit-test
+
+[ ] [ "A label" "label" set-value ] unit-test
+
+SINGLETON: link-test
+
+M: link-test link-title drop "<Link Title>" ;
+
+M: link-test link-href drop "http://www.apple.com/foo&bar" ;
+
+[ ] [ link-test "link" set-value ] unit-test
+
+[ ] [ "int x = 5;" "code" set-value ] unit-test
+
+[ ] [ "c" "mode" set-value ] unit-test
+
+[ ] [ { 1 2 3 } "inspector" set-value ] unit-test
+
+[ ] [ "<p>a paragraph</p>" "html" set-value ] unit-test
+
+[ ] [ "sheeple" "field" set-value ] unit-test
+
+[ ] [ "a password" "password" set-value ] unit-test
+
+[ ] [ "a\nb\nc" "textarea" set-value ] unit-test
+
+[ ] [ "new york" "choice" set-value ] unit-test
+
+[ ] [ { "new york" "detroit" "minneapolis" } "choices" set-value ] unit-test
+
+[ ] [
+ [
+ "test8" test-template call-template
+ ] run-template drop
+] unit-test
+
+[ ] [ { 1 2 3 } "numbers" set-value ] unit-test
+
+[ "<ul><li>1</li><li>2</li><li>3</li></ul>" ] [
+ [
+ "test9" test-template call-template
+ ] run-template [ blank? not ] filter
+] unit-test
+
+TUPLE: person first-name last-name ;
+
+[ ] [
+ {
+ T{ person f "RBaxter" "Unknown" }
+ T{ person f "Doug" "Coleman" }
+ } "people" set-value
+] unit-test
+
+[ "<table><tr><td>RBaxter</td><td>Unknown</td></tr><tr><td>Doug</td><td>Coleman</td></tr></table>" ] [
+ [
+ "test10" test-template call-template
+ ] run-template [ blank? not ] filter
+] unit-test
+
+[ ] [
+ {
+ H{ { "first-name" "RBaxter" } { "last-name" "Unknown" } }
+ H{ { "first-name" "Doug" } { "last-name" "Coleman" } }
+ } "people" set-value
+] unit-test
+
+[ "<table><tr><td>RBaxter</td><td>Unknown</td></tr><tr><td>Doug</td><td>Coleman</td></tr></table>" ] [
+ [
+ "test11" test-template call-template
+ ] run-template [ blank? not ] filter
+] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel sequences combinators kernel namespaces
+classes.tuple assocs splitting words arrays memoize
+io io.files io.encodings.utf8 io.streams.string
+unicode.case tuple-syntax mirrors fry math
+multiline xml xml.data xml.writer xml.utilities
+html.elements
+html.components
+html.templates
+http.server
+http.server.auth
+http.server.flows
+http.server.actions
+http.server.sessions ;
+IN: html.templates.chloe
+
+! Chloe is Ed's favorite web designer
+
+TUPLE: chloe path ;
+
+C: <chloe> chloe
+
+DEFER: process-template
+
+: chloe-ns "http://factorcode.org/chloe/1.0" ; inline
+
+: chloe-attrs-only ( assoc -- assoc' )
+ [ drop name-url chloe-ns = ] assoc-filter ;
+
+: non-chloe-attrs-only ( assoc -- assoc' )
+ [ drop name-url chloe-ns = not ] assoc-filter ;
+
+: chloe-tag? ( tag -- ? )
+ {
+ { [ dup tag? not ] [ f ] }
+ { [ dup url>> chloe-ns = not ] [ f ] }
+ [ t ]
+ } cond nip ;
+
+SYMBOL: tags
+
+MEMO: chloe-name ( string -- name )
+ name new
+ swap >>tag
+ chloe-ns >>url ;
+
+: required-attr ( tag name -- value )
+ dup chloe-name rot at*
+ [ nip ] [ drop " attribute is required" append throw ] if ;
+
+: optional-attr ( tag name -- value )
+ chloe-name swap at ;
+
+: process-tag-children ( tag -- )
+ [ process-template ] each ;
+
+: children>string ( tag -- string )
+ [ process-tag-children ] with-string-writer ;
+
+: title-tag ( tag -- )
+ children>string set-title ;
+
+: write-title-tag ( tag -- )
+ drop
+ "head" tags get member? "title" tags get member? not and
+ [ <title> write-title </title> ] [ write-title ] if ;
+
+: style-tag ( tag -- )
+ dup "include" optional-attr dup [
+ swap children>string empty? [
+ "style tag cannot have both an include attribute and a body" throw
+ ] unless
+ utf8 file-contents
+ ] [
+ drop children>string
+ ] if add-style ;
+
+: write-style-tag ( tag -- )
+ drop <style> write-style </style> ;
+
+: atom-tag ( tag -- )
+ [ "title" required-attr ]
+ [ "href" required-attr ]
+ bi set-atom-feed ;
+
+: write-atom-tag ( tag -- )
+ drop
+ "head" tags get member? [
+ write-atom-feed
+ ] [
+ atom-feed get value>> second write
+ ] if ;
+
+: parse-query-attr ( string -- assoc )
+ dup empty?
+ [ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ;
+
+: flow-attr ( tag -- )
+ "flow" optional-attr {
+ { "none" [ flow-id off ] }
+ { "begin" [ begin-flow ] }
+ { "current" [ ] }
+ { f [ ] }
+ } case ;
+
+: session-attr ( tag -- )
+ "session" optional-attr {
+ { "none" [ session off flow-id off ] }
+ { "current" [ ] }
+ { f [ ] }
+ } case ;
+
+: a-start-tag ( tag -- )
+ [
+ <a
+ dup flow-attr
+ dup session-attr
+ dup "value" optional-attr [ value f ] [
+ [ "href" required-attr ]
+ [ "query" optional-attr parse-query-attr ]
+ bi
+ ] ?if link>string =href
+ a>
+ ] with-scope ;
+
+: a-tag ( tag -- )
+ [ a-start-tag ]
+ [ process-tag-children ]
+ [ drop </a> ]
+ tri ;
+
+: form-start-tag ( tag -- )
+ [
+ [
+ <form
+ "POST" =method
+ {
+ [ flow-attr ]
+ [ session-attr ]
+ [ "action" required-attr resolve-base-path =action ]
+ [ tag-attrs non-chloe-attrs-only print-attrs ]
+ } cleave
+ form>
+ ] [
+ hidden-form-field
+ "for" optional-attr [ hidden render ] when*
+ ] bi
+ ] with-scope ;
+
+: form-tag ( tag -- )
+ [ form-start-tag ]
+ [ process-tag-children ]
+ [ drop </form> ]
+ tri ;
+
+DEFER: process-chloe-tag
+
+STRING: button-tag-markup
+<t:form class="inline" xmlns:t="http://factorcode.org/chloe/1.0">
+ <button type="submit"></button>
+</t:form>
+;
+
+: add-tag-attrs ( attrs tag -- )
+ tag-attrs swap update ;
+
+: button-tag ( tag -- )
+ button-tag-markup string>xml delegate
+ {
+ [ [ tag-attrs chloe-attrs-only ] dip add-tag-attrs ]
+ [ [ tag-attrs non-chloe-attrs-only ] dip "button" tag-named add-tag-attrs ]
+ [ [ children>string 1array ] dip "button" tag-named set-tag-children ]
+ [ nip ]
+ } 2cleave process-chloe-tag ;
+
+: attr>word ( value -- word/f )
+ dup ":" split1 swap lookup
+ [ ] [ "No such word: " swap append throw ] ?if ;
+
+: attr>var ( value -- word/f )
+ attr>word dup symbol? [
+ "Must be a symbol: " swap append throw
+ ] unless ;
+
+: if-satisfied? ( tag -- ? )
+ t swap
+ {
+ [ "code" optional-attr [ attr>word execute and ] when* ]
+ [ "var" optional-attr [ attr>var get and ] when* ]
+ [ "svar" optional-attr [ attr>var sget and ] when* ]
+ [ "uvar" optional-attr [ attr>var uget and ] when* ]
+ [ "value" optional-attr [ value and ] when* ]
+ } cleave ;
+
+: if-tag ( tag -- )
+ dup if-satisfied? [ process-tag-children ] [ drop ] if ;
+
+: even-tag ( tag -- )
+ "index" value even? [ process-tag-children ] [ drop ] if ;
+
+: odd-tag ( tag -- )
+ "index" value odd? [ process-tag-children ] [ drop ] if ;
+
+: (each-tag) ( tag quot -- )
+ [
+ [ "values" required-attr value ] keep
+ '[ , process-tag-children ]
+ ] dip call ; inline
+
+: each-tag ( tag -- )
+ [ with-each-value ] (each-tag) ;
+
+: each-tuple-tag ( tag -- )
+ [ with-each-tuple ] (each-tag) ;
+
+: each-assoc-tag ( tag -- )
+ [ with-each-assoc ] (each-tag) ;
+
+: (bind-tag) ( tag quot -- )
+ [
+ [ "name" required-attr value ] keep
+ '[ , process-tag-children ]
+ ] dip call ; inline
+
+: bind-tuple-tag ( tag -- )
+ [ with-tuple-values ] (bind-tag) ;
+
+: bind-assoc-tag ( tag -- )
+ [ with-assoc-values ] (bind-tag) ;
+
+: error-message-tag ( tag -- )
+ children>string render-error ;
+
+: validation-messages-tag ( tag -- )
+ drop render-validation-messages ;
+
+: singleton-component-tag ( tag class -- )
+ [ "name" required-attr ] dip render ;
+
+: attrs>slots ( tag tuple -- )
+ [ attrs>> ] [ <mirror> ] bi*
+ '[
+ swap tag>> dup "name" =
+ [ 2drop ] [ , set-at ] if
+ ] assoc-each ;
+
+: tuple-component-tag ( tag class -- )
+ [ drop "name" required-attr ]
+ [ new [ attrs>slots ] keep ]
+ 2bi render ;
+
+: process-chloe-tag ( tag -- )
+ dup name-tag {
+ { "chloe" [ process-tag-children ] }
+
+ ! HTML head
+ { "title" [ title-tag ] }
+ { "write-title" [ write-title-tag ] }
+ { "style" [ style-tag ] }
+ { "write-style" [ write-style-tag ] }
+ { "atom" [ atom-tag ] }
+ { "write-atom" [ write-atom-tag ] }
+
+ ! HTML elements
+ { "a" [ a-tag ] }
+ { "button" [ button-tag ] }
+
+ ! Components
+ { "label" [ label singleton-component-tag ] }
+ { "link" [ link singleton-component-tag ] }
+ { "code" [ code tuple-component-tag ] }
+ { "farkup" [ farkup singleton-component-tag ] }
+ { "inspector" [ inspector singleton-component-tag ] }
+ { "comparison" [ comparison singleton-component-tag ] }
+ { "html" [ html singleton-component-tag ] }
+
+ ! Forms
+ { "form" [ form-tag ] }
+ { "error-message" [ error-message-tag ] }
+ { "validation-messages" [ validation-messages-tag ] }
+ { "hidden" [ hidden singleton-component-tag ] }
+ { "field" [ field tuple-component-tag ] }
+ { "password" [ password tuple-component-tag ] }
+ { "textarea" [ textarea tuple-component-tag ] }
+ { "choice" [ choice tuple-component-tag ] }
+ { "checkbox" [ checkbox tuple-component-tag ] }
+
+ ! Control flow
+ { "if" [ if-tag ] }
+ { "even" [ even-tag ] }
+ { "odd" [ odd-tag ] }
+ { "each" [ each-tag ] }
+ { "each-assoc" [ each-assoc-tag ] }
+ { "each-tuple" [ each-tuple-tag ] }
+ { "bind-assoc" [ bind-assoc-tag ] }
+ { "bind-tuple" [ bind-tuple-tag ] }
+ { "comment" [ drop ] }
+ { "call-next-template" [ drop call-next-template ] }
+
+ [ "Unknown chloe tag: " prepend throw ]
+ } case ;
+
+: process-tag ( tag -- )
+ {
+ [ name-tag >lower tags get push ]
+ [ write-start-tag ]
+ [ process-tag-children ]
+ [ write-end-tag ]
+ [ drop tags get pop* ]
+ } cleave ;
+
+: process-template ( xml -- )
+ {
+ { [ dup [ chloe-tag? ] is? ] [ process-chloe-tag ] }
+ { [ dup [ tag? ] is? ] [ process-tag ] }
+ { [ t ] [ write-item ] }
+ } cond ;
+
+: process-chloe ( xml -- )
+ [
+ V{ } clone tags set
+
+ nested-template? get [
+ process-template
+ ] [
+ {
+ [ xml-prolog write-prolog ]
+ [ xml-before write-chunk ]
+ [ process-template ]
+ [ xml-after write-chunk ]
+ } cleave
+ ] if
+ ] with-scope ;
+
+M: chloe call-template*
+ path>> utf8 <file-reader> read-xml process-chloe ;
+
+INSTANCE: chloe template
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+ Hello world
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <table>
+ <t:each-tuple t:values="people">
+ <tr>
+ <td><t:label t:name="first-name"/></td>
+ <td><t:label t:name="last-name"/></td>
+ </tr>
+ </t:each-tuple>
+ </table>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <table>
+ <t:each-assoc t:values="people">
+ <tr>
+ <td><t:label t:name="first-name"/></td>
+ <td><t:label t:name="last-name"/></td>
+ </tr>
+ </t:each-assoc>
+ </table>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+ <t:title>Hello world</t:title>
+ Blah blah
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+ <t:title>Hello world</t:title>
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+ <html>
+ <head>
+ <t:write-title />
+ </head>
+ <body>
+ <t:call-next-template />
+ </body>
+ </html>
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:if t:code="html.templates.chloe.tests:test4-aux?">
+ True
+ </t:if>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:if t:code="html.templates.chloe.tests:test5-aux?">
+ True
+ </t:if>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:if t:var="html.templates.chloe.tests:test6-aux?">
+ True
+ </t:if>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:if t:var="html.templates.chloe.tests:test7-aux?">
+ True
+ </t:if>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:label t:name="label" />
+
+ <t:link t:name="link" />
+
+ <t:code t:name="code" mode="mode" />
+
+ <t:farkup t:name="farkup" />
+
+ <t:inspector t:name="inspector" />
+
+ <t:html t:name="html" />
+
+ <t:field t:name="field" t:size="13" />
+
+ <t:password t:name="password" t:size="10" />
+
+ <t:textarea t:name="textarea" t:rows="5" t:cols="10" />
+
+ <t:choice t:name="choice" t:choices="choices" />
+
+ <t:checkbox t:name="checkbox">Checkbox</t:checkbox>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <ul>
+ <t:each t:values="numbers">
+ <li><t:label t:name="value"/></li>
+ </t:each>
+ </ul>
+
+</t:chloe>
--- /dev/null
+Slava Pestov
+Matthew Willis
--- /dev/null
+USING: io io.files io.streams.string io.encodings.utf8
+html.templates html.templates.fhtml kernel
+tools.test sequences parser ;
+IN: html.templates.fhtml.tests
+
+: test-template ( path -- ? )
+ "resource:extra/html/templates/fhtml/test/"
+ prepend
+ [
+ ".fhtml" append <fhtml> [ call-template ] with-string-writer
+ ] keep
+ ".html" append utf8 file-contents = ;
+
+[ t ] [ "example" test-template ] unit-test
+[ t ] [ "bug" test-template ] unit-test
+[ t ] [ "stack" test-template ] unit-test
+
+[
+ [ ] [ "<%\n%>" parse-template drop ] unit-test
+] with-file-vocabs
--- /dev/null
+! Copyright (C) 2005 Alex Chapman
+! Copyright (C) 2006, 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: continuations sequences kernel namespaces debugger
+combinators math quotations generic strings splitting
+accessors assocs fry
+parser io io.files io.streams.string io.encodings.utf8
+html.elements
+html.templates ;
+IN: html.templates.fhtml
+
+! We use a custom lexer so that %> ends a token even if not
+! followed by whitespace
+TUPLE: template-lexer < lexer ;
+
+: <template-lexer> ( lines -- lexer )
+ template-lexer new-lexer ;
+
+M: template-lexer skip-word
+ [
+ {
+ { [ 2dup nth CHAR: " = ] [ drop 1+ ] }
+ { [ 2dup swap tail-slice "%>" head? ] [ drop 2 + ] }
+ [ f skip ]
+ } cond
+ ] change-lexer-column ;
+
+DEFER: <% delimiter
+
+: check-<% ( lexer -- col )
+ "<%" over line-text>> rot column>> start* ;
+
+: found-<% ( accum lexer col -- accum )
+ [
+ over line-text>>
+ [ column>> ] 2dip subseq parsed
+ \ write-html parsed
+ ] 2keep 2 + >>column drop ;
+
+: still-looking ( accum lexer -- accum )
+ [
+ [ line-text>> ] [ column>> ] bi tail
+ parsed \ print-html parsed
+ ] keep next-line ;
+
+: parse-%> ( accum lexer -- accum )
+ dup still-parsing? [
+ dup check-<%
+ [ found-<% ] [ [ still-looking ] keep parse-%> ] if*
+ ] [
+ drop
+ ] if ;
+
+: %> lexer get parse-%> ; parsing
+
+: parse-template-lines ( lines -- quot )
+ <template-lexer> [
+ V{ } clone lexer get parse-%> f (parse-until)
+ ] with-parser ;
+
+: parse-template ( string -- quot )
+ [
+ "quiet" on
+ parser-notes off
+ "html.templates.fhtml" use+
+ string-lines parse-template-lines
+ ] with-file-vocabs ;
+
+: eval-template ( string -- )
+ parse-template call ;
+
+TUPLE: fhtml path ;
+
+C: <fhtml> fhtml
+
+M: fhtml call-template* ( filename -- )
+ '[ , path>> utf8 file-contents eval-template ] assert-depth ;
+
+INSTANCE: fhtml template
--- /dev/null
+<%
+ USING: prettyprint ;
+ ! Hello world
+ 5 pprint
+%>
--- /dev/null
+<% USING: math ; %>
+
+<html>
+ <head><title>Simple Embedded Factor Example</title></head>
+ <body>
+ <% 5 [ %><p>I like repetition</p><% ] times %>
+ </body>
+</html>
--- /dev/null
+
+
+<html>
+ <head><title>Simple Embedded Factor Example</title></head>
+ <body>
+ <p>I like repetition</p><p>I like repetition</p><p>I like repetition</p><p>I like repetition</p><p>I like repetition</p>
+ </body>
+</html>
+
--- /dev/null
+The stack: <% USING: prettyprint ; .s %>
--- /dev/null
+The stack:
+
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel fry io io.encodings.utf8 io.files
+debugger prettyprint continuations namespaces boxes sequences
+arrays strings html.elements io.streams.string quotations ;
+IN: html.templates
+
+MIXIN: template
+
+GENERIC: call-template* ( template -- )
+
+M: string call-template* write ;
+
+M: callable call-template* call ;
+
+M: object call-template* output-stream get stream-copy ;
+
+ERROR: template-error template error ;
+
+M: template-error error.
+ "Error while processing template " write
+ [ template>> short. ":" print nl ]
+ [ error>> error. ]
+ bi ;
+
+: call-template ( template -- )
+ [ call-template* ] [ \ template-error boa rethrow ] recover ;
+
+SYMBOL: title
+
+: set-title ( string -- )
+ title get >box ;
+
+: write-title ( -- )
+ title get value>> write ;
+
+SYMBOL: style
+
+: add-style ( string -- )
+ "\n" style get push-all
+ style get push-all ;
+
+: write-style ( -- )
+ style get >string write ;
+
+SYMBOL: atom-feed
+
+: set-atom-feed ( title url -- )
+ 2array atom-feed get >box ;
+
+: write-atom-feed ( -- )
+ atom-feed get value>> [
+ <link "alternate" =rel "application/atom+xml" =type
+ [ first =title ] [ second =href ] bi
+ link/>
+ ] when* ;
+
+SYMBOL: nested-template?
+
+SYMBOL: next-template
+
+: call-next-template ( -- )
+ next-template get write-html ;
+
+M: f call-template* drop call-next-template ;
+
+: with-boilerplate ( body template -- )
+ [
+ title get [ <box> title set ] unless
+ atom-feed get [ <box> atom-feed set ] unless
+ style get [ SBUF" " clone style set ] unless
+
+ [
+ [
+ nested-template? on
+ call-template
+ ] with-string-writer
+ next-template set
+ ]
+ [ call-template ]
+ bi*
+ ] with-scope ; inline
+
+: template-convert ( template output -- )
+ utf8 [ call-template ] with-file-writer ;
: download-to ( url file -- )
#! Downloads the contents of a URL to a file.
- >r http-get r> latin1 [ write ] with-file-writer ;
+ [ http-get ] dip latin1 [ write ] with-file-writer ;
: download ( url -- )
dup download-name download-to ;
[ ] [
[
<dispatcher>
- <action> [ "text/plain" <content> [ "Hi" write ] >>body ] >>display
+ <action> [ [ "Hi" write ] <text-content> ] >>display
<login>
<sessions>
"" add-responder
io io.streams.string io.encodings.utf8 io.encodings.string
io.sockets io.sockets.secure
-unicode.case unicode.categories qualified ;
+unicode.case unicode.categories qualified
+
+html.templates ;
EXCLUDE: fry => , ;
2dup length 2 - >= [
2drop
] [
- >r 1+ dup 2 + r> subseq hex> [ , ] when*
+ [ 1+ dup 2 + ] dip subseq hex> [ , ] when*
] if ;
: url-decode-% ( index str -- index str )
- 2dup url-decode-hex >r 3 + r> ;
+ 2dup url-decode-hex [ 3 + ] dip ;
: url-decode-+-or-other ( index str ch -- index str )
- dup CHAR: + = [ drop CHAR: \s ] when , >r 1+ r> ;
+ dup CHAR: + = [ drop CHAR: \s ] when , [ 1+ ] dip ;
: url-decode-iter ( index str -- )
2dup length >= [
dup [
"&" split H{ } clone [
[
- >r "=" split1 [ dup [ url-decode ] when ] bi@ swap r>
+ [ "=" split1 [ dup [ url-decode ] when ] bi@ swap ] dip
add-query-param
] curry each
] keep
] assoc-map
[
[
- >r url-encode r>
+ [ url-encode ] dip
[ url-encode "=" swap 3append , ] with each
] assoc-each
] { } make "&" join ;
dup "cookie" header [ parse-cookies >>cookies ] when* ;
: parse-content-type-attributes ( string -- attributes )
- " " split harvest [ "=" split1 >r >lower r> ] { } map>assoc ;
+ " " split harvest [ "=" split1 [ >lower ] dip ] { } map>assoc ;
: parse-content-type ( content-type -- type encoding )
";" split1 parse-content-type-attributes "charset" swap at ;
over unparse-content-type "content-type" pick set-at
write-header ;
-GENERIC: write-response-body* ( body -- )
-
-M: f write-response-body* drop ;
-
-M: string write-response-body* write ;
-
-M: callable write-response-body* call ;
-
-M: object write-response-body* output-stream get stream-copy ;
-
: write-response-body ( response -- response )
- dup body>> write-response-body* ;
+ dup body>> call-template ;
M: response write-response ( respose -- )
write-response-version
swap method>> "HEAD" = [ write-response-body ] unless ;
: get-cookie ( request/response name -- cookie/f )
- >r cookies>> r> '[ , _ name>> = ] find nip ;
+ [ cookies>> ] dip '[ , _ name>> = ] find nip ;
: delete-cookie ( request/response name -- )
- over cookies>> >r get-cookie r> delete ;
+ over cookies>> [ get-cookie ] dip delete ;
: put-cookie ( request/response cookie -- request/response )
[ name>> dupd get-cookie [ dupd delete-cookie ] when* ] keep
-USING: http.server.actions http.server.validators
+USING: kernel http.server.actions validators
tools.test math math.parser multiline namespaces http
io.streams.string http.server sequences splitting accessors ;
IN: http.server.actions.tests
-[
- "a" [ v-number ] { { "a" "123" } } validate-param
- [ 123 ] [ "a" get ] unit-test
-] with-scope
-
<action>
- [ "a" get "b" get + ] >>display
- { { "a" [ v-number ] } { "b" [ v-number ] } } >>get-params
+ [ "a" param "b" param [ string>number ] bi@ + ] >>display
"action-1" set
: lf>crlf "\n" split "\r\n" join ;
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors sequences kernel assocs combinators\r
-http.server http.server.validators http hashtables namespaces\r
-fry continuations locals boxes xml.entities html.elements io ;\r
+USING: accessors sequences kernel assocs combinators http.server\r
+validators http hashtables namespaces fry continuations locals\r
+boxes xml.entities html.elements html.components io arrays math ;\r
IN: http.server.actions\r
\r
SYMBOL: params\r
\r
-SYMBOL: validation-message\r
+SYMBOL: rest-param\r
\r
-: render-validation-message ( -- )\r
- validation-message get value>> [\r
- <span "error" =class span>\r
- escape-string write\r
- </span>\r
- ] when* ;\r
+: render-validation-messages ( -- )\r
+ validation-messages get\r
+ dup empty? [ drop ] [\r
+ <ul "errors" =class ul>\r
+ [ <li> message>> escape-string write </li> ] each\r
+ </ul>\r
+ ] if ;\r
\r
-TUPLE: action init display submit get-params post-params ;\r
+TUPLE: action rest-param init display validate submit ;\r
\r
-: <action>\r
- action new\r
+: new-action ( class -- action )\r
+ new\r
[ ] >>init\r
[ <400> ] >>display\r
+ [ ] >>validate\r
[ <400> ] >>submit ;\r
\r
-:: validate-param ( name validator assoc -- )\r
- name assoc at validator with-validator name set ; inline\r
-\r
-: action-params ( validators -- error? )\r
- validation-failed? off\r
- params get '[ , validate-param ] assoc-each\r
- validation-failed? get ;\r
-\r
-: handle-get ( -- response )\r
- action get get-params>> action-params [ <400> ] [\r
- action get [ init>> call ] [ display>> call ] bi\r
- ] if ;\r
+: <action> ( -- action )\r
+ action new-action ;\r
\r
-: handle-post ( -- response )\r
- action get post-params>> action-params\r
- [ <400> ] [ action get submit>> call ] if ;\r
+: handle-get ( action -- response )\r
+ blank-values\r
+ [ init>> call ]\r
+ [ display>> call ]\r
+ bi ;\r
\r
: validation-failed ( -- * )\r
- action get display>> call exit-with ;\r
+ request get method>> "POST" =\r
+ [ action get display>> call ] [ <400> ] if exit-with ;\r
\r
-: validation-failed-with ( string -- * )\r
- validation-message get >box\r
- validation-failed ;\r
+: handle-post ( action -- response )\r
+ init-validation\r
+ blank-values\r
+ [ validate>> call ]\r
+ [ submit>> call ] bi ;\r
+\r
+: handle-rest-param ( arg -- )\r
+ dup length 1 > action get rest-param>> not or\r
+ [ <404> exit-with ] [\r
+ action get rest-param>> associate rest-param set\r
+ ] if ;\r
\r
M: action call-responder* ( path action -- response )\r
+ dup action set\r
'[\r
- , [ CHAR: / = ] right-trim empty? [\r
- , action set\r
- request get\r
- <box> validation-message set\r
- [ request-params params set ]\r
- [\r
- method>> {\r
- { "GET" [ handle-get ] }\r
- { "HEAD" [ handle-get ] }\r
- { "POST" [ handle-post ] }\r
- } case\r
- ] bi\r
- ] [\r
- <404>\r
- ] if\r
+ , dup empty? [ drop ] [ handle-rest-param ] if\r
+\r
+ init-validation\r
+ ,\r
+ request get\r
+ [ request-params rest-param get assoc-union params set ]\r
+ [ method>> ] bi\r
+ {\r
+ { "GET" [ handle-get ] }\r
+ { "HEAD" [ handle-get ] }\r
+ { "POST" [ handle-post ] }\r
+ } case\r
] with-exit-continuation ;\r
+\r
+: param ( name -- value )\r
+ params get at ;\r
+\r
+: check-validation ( -- )\r
+ validation-failed? [ validation-failed ] when ;\r
+\r
+: validate-params ( validators -- )\r
+ params get swap validate-values from-assoc\r
+ check-validation ;\r
+\r
+: validate-integer-id ( -- )\r
+ { { "id" [ v-number ] } } validate-params ;\r
+\r
+TUPLE: page-action < action template ;\r
+\r
+: <page-action> ( -- page )\r
+ page-action new-action\r
+ dup '[ , template>> <html-content> ] >>display ;\r
+\r
+TUPLE: feed-action < action feed ;\r
+\r
+: <feed-action> ( -- feed )\r
+ feed-action new\r
+ dup '[ , feed>> call <feed-content> ] >>display ;\r
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences accessors namespaces combinators words
-assocs locals db.tuples arrays splitting strings qualified
-
-http.server.templating.chloe
-http.server.boilerplate
-http.server.auth.providers
-http.server.auth.providers.db
-http.server.auth.login
-http.server.auth
-http.server.forms
-http.server.components.inspector
-http.server.validators
-http.server.sessions
-http.server.actions
-http.server.crud
-http.server ;
-EXCLUDE: http.server.components => string? number? ;
-IN: http.server.auth.admin
-
-: admin-template ( name -- template )
- "resource:extra/http/server/auth/admin/" swap ".xml" 3append <chloe> ;
-
-: words>strings ( seq -- seq' )
- [ [ word-vocabulary ] [ drop ":" ] [ word-name ] tri 3append ] map ;
-
-: strings>words ( seq -- seq' )
- [ ":" split1 swap lookup ] map ;
-
-: <capabilities> ( id -- component )
- capabilities get words>strings <menu> ;
-
-: <new-user-form> ( -- form )
- "user" <form>
- "new-user" admin-template >>edit-template
- "username" <string> add-field
- "realname" <string> add-field
- "new-password" <password> t >>required add-field
- "verify-password" <password> t >>required add-field
- "email" <email> add-field
- "capabilities" <capabilities> add-field ;
-
-: <edit-user-form> ( -- form )
- "user" <form>
- "edit-user" admin-template >>edit-template
- "user-summary" admin-template >>summary-template
- "username" <string> hidden >>renderer add-field
- "realname" <string> add-field
- "new-password" <password> add-field
- "verify-password" <password> add-field
- "email" <email> add-field
- "profile" <inspector> add-field
- "capabilities" <capabilities> add-field ;
-
-: <user-list-form> ( -- form )
- "user-list" <form>
- "user-list" admin-template >>view-template
- "list" <edit-user-form> +unordered+ <list> add-field ;
-
-:: <new-user-action> ( form ctor next -- action )
- <action>
- [
- blank-values
-
- "username" get ctor call
-
- {
- [ username>> "username" set-value ]
- [ realname>> "realname" set-value ]
- [ email>> "email" set-value ]
- [ profile>> "profile" set-value ]
- } cleave
- ] >>init
-
- [ form edit-form ] >>display
-
- [
- blank-values
-
- form validate-form
-
- same-password-twice
-
- user new "username" value >>username select-tuple
- [ user-exists ] when
-
- "username" value <user>
- "realname" value >>realname
- "email" value >>email
- "new-password" value >>encoded-password
- H{ } clone >>profile
-
- insert-tuple
-
- next f <standard-redirect>
- ] >>submit ;
-
-:: <edit-user-action> ( form ctor next -- action )
- <action>
- { { "username" [ v-required ] } } >>get-params
-
- [
- blank-values
-
- "username" get ctor call select-tuple
-
- {
- [ username>> "username" set-value ]
- [ realname>> "realname" set-value ]
- [ email>> "email" set-value ]
- [ profile>> "profile" set-value ]
- [ capabilities>> words>strings "capabilities" set-value ]
- } cleave
- ] >>init
-
- [ form edit-form ] >>display
-
- [
- blank-values
-
- form validate-form
-
- "username" value <user> select-tuple
- "realname" value >>realname
- "email" value >>email
-
- { "new-password" "verify-password" }
- [ value empty? ] all? [
- same-password-twice
- "new-password" value >>encoded-password
- ] unless
-
- "capabilities" value {
- { [ dup string? ] [ 1array ] }
- { [ dup array? ] [ ] }
- } cond strings>words >>capabilities
-
- update-tuple
-
- next f <standard-redirect>
- ] >>submit ;
-
-:: <delete-user-action> ( ctor next -- action )
- <action>
- { { "username" [ ] } } >>post-params
-
- [
- "username" get
- [ <user> select-tuple 1 >>deleted update-tuple ]
- [ logout-all-sessions ]
- bi
-
- next f <standard-redirect>
- ] >>submit ;
-
-TUPLE: user-admin < dispatcher ;
-
-SYMBOL: can-administer-users?
-
-can-administer-users? define-capability
-
-:: <user-admin> ( -- responder )
- [let | ctor [ [ <user> ] ] |
- user-admin new-dispatcher
- <user-list-form> ctor <list-action> "" add-responder
- <new-user-form> ctor "$user-admin" <new-user-action> "new" add-responder
- <edit-user-form> ctor "$user-admin" <edit-user-action> "edit" add-responder
- ctor "$user-admin" <delete-user-action> "delete" add-responder
- <boilerplate>
- "admin" admin-template >>template
- { can-administer-users? } <protected>
- ] ;
-
-: make-admin ( username -- )
- <user>
- select-tuple
- [ can-administer-users? suffix ] change-capabilities
- update-tuple ;
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <div class="navbar">
- <t:a t:href="$user-admin">List Users</t:a>
- | <t:a t:href="$user-admin/new">Add User</t:a>
-
- <t:if t:code="http.server.auth.login:allow-edit-profile?">
- | <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
- </t:if>
-
- | <t:button t:action="$login/logout" t:flow="begin" class="link-button link">Logout</t:button>
- </div>
-
- <h1><t:write-title /></h1>
-
- <t:call-next-template />
-
-</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <t:title>Edit User</t:title>
-
- <t:form t:action="$user-admin/edit" t:for="username">
-
- <table>
-
- <tr>
- <th class="field-label">User name:</th>
- <td><t:view t:component="username" /></td>
- </tr>
-
- <tr>
- <th class="field-label">Real name:</th>
- <td><t:edit t:component="realname" /></td>
- </tr>
-
- <tr>
- <th class="field-label">New password:</th>
- <td><t:edit t:component="new-password" /></td>
- </tr>
-
- <tr>
- <th class="field-label">Verify:</th>
- <td><t:edit t:component="verify-password" /></td>
- </tr>
-
- <tr>
- <th class="field-label">E-mail:</th>
- <td><t:edit t:component="email" /></td>
- </tr>
-
- <tr>
- <th class="field-label big-field-label">Capabilities:</th>
- <td><t:edit t:component="capabilities" /></td>
- </tr>
-
- <tr>
- <th class="field-label">Profile:</th>
- <td><t:view t:component="profile" /></td>
- </tr>
-
- </table>
-
- <p>
- <button type="submit" class="link-button link">Update</button>
- <t:validation-message />
- </p>
-
- </t:form>
-
- <t:button t:action="$user-admin/delete" t:for="username" class="link-button link">Delete</t:button>
-</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <t:title>New User</t:title>
-
- <t:form t:action="$user-admin/new">
-
- <table>
-
- <tr>
- <th class="field-label">User name:</th>
- <td><t:edit t:component="username" /></td>
- </tr>
-
- <tr>
- <th class="field-label">Real name:</th>
- <td><t:edit t:component="realname" /></td>
- </tr>
-
- <tr>
- <th class="field-label">New password:</th>
- <td><t:edit t:component="new-password" /></td>
- </tr>
-
- <tr>
- <th class="field-label">Verify:</th>
- <td><t:edit t:component="verify-password" /></td>
- </tr>
-
- <tr>
- <th class="field-label">E-mail:</th>
- <td><t:edit t:component="email" /></td>
- </tr>
-
- <tr>
- <th class="field-label big-field-label">Capabilities:</th>
- <td><t:edit t:component="capabilities" /></td>
- </tr>
-
- </table>
-
- <p>
- <button type="submit" class="link-button link">Create</button>
- <t:validation-message />
- </p>
-
- </t:form>
-</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <t:title>Users</t:title>
-
- <t:summary t:component="list" />
-
-</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <t:a t:href="$user-admin/edit" t:query="username">
- <t:view t:component="username" />
- </t:a>
-
-</t:chloe>
! Copyright (c) 2008 Slava Pestov\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors assocs namespaces kernel sequences\r
+USING: accessors assocs namespaces kernel sequences sets\r
http.server\r
http.server.sessions\r
http.server.auth.providers ;\r
\r
V{ } clone capabilities set-global\r
\r
-: define-capability ( word -- ) capabilities get push-new ;\r
+: define-capability ( word -- ) capabilities get adjoin ;\r
<tr>
<th class="field-label">User name:</th>
- <td><t:view t:component="username" /></td>
+ <td><t:label t:name="username" /></td>
</tr>
<tr>
<th class="field-label">Real name:</th>
- <td><t:edit t:component="realname" /></td>
+ <td><t:field t:name="realname" /></td>
</tr>
<tr>
<tr>
<th class="field-label">Current password:</th>
- <td><t:edit t:component="password" /></td>
+ <td><t:password t:name="password" /></td>
</tr>
<tr>
<tr>
<th class="field-label">New password:</th>
- <td><t:edit t:component="new-password" /></td>
+ <td><t:password t:name="new-password" /></td>
</tr>
<tr>
<th class="field-label">Verify:</th>
- <td><t:edit t:component="verify-password" /></td>
+ <td><t:password t:name="verify-password" /></td>
</tr>
<tr>
<tr>
<th class="field-label">E-mail:</th>
- <td><t:edit t:component="email" /></td>
+ <td><t:field t:name="email" /></td>
</tr>
<tr>
<p>
<input type="submit" value="Update" />
- <t:validation-message />
+ <t:validation-messages />
</p>
</t:form>
! See http://factorcode.org/license.txt for BSD license.\r
USING: accessors quotations assocs kernel splitting\r
combinators sequences namespaces hashtables sets\r
-fry arrays threads locals qualified random\r
+fry arrays threads qualified random validators\r
io\r
io.sockets\r
io.encodings.utf8\r
destructors\r
checksums\r
checksums.sha2\r
+validators\r
+html.components\r
html.elements\r
+html.templates\r
+html.templates.chloe\r
http\r
http.server\r
http.server.auth\r
http.server.auth.providers\r
http.server.auth.providers.db\r
http.server.actions\r
-http.server.components\r
http.server.flows\r
-http.server.forms\r
http.server.sessions\r
-http.server.boilerplate\r
-http.server.templating\r
-http.server.templating.chloe\r
-http.server.validators ;\r
-IN: http.server.auth.login\r
+http.server.boilerplate ;\r
QUALIFIED: smtp\r
+IN: http.server.auth.login\r
\r
TUPLE: login < dispatcher users checksum ;\r
\r
3append <chloe> ;\r
\r
! ! ! Login\r
-\r
-: <login-form>\r
- "login" <form>\r
- "login" login-template >>edit-template\r
- "username" <username>\r
- t >>required\r
- add-field\r
- "password" <password>\r
- t >>required\r
- add-field ;\r
-\r
: successful-login ( user -- response )\r
- username>> set-uid\r
- "$login" end-flow ;\r
-\r
-: login-failed "invalid username or password" validation-failed-with ;\r
-\r
-:: <login-action> ( -- action )\r
- [let | form [ <login-form> ] |\r
- <action>\r
- [ blank-values ] >>init\r
+ username>> set-uid "$login" end-flow ;\r
\r
- [ form edit-form ] >>display\r
+: login-failed ( -- * )\r
+ "invalid username or password" validation-error\r
+ validation-failed ;\r
\r
- [\r
- blank-values\r
+: <login-action> ( -- action )\r
+ <action>\r
+ [ "login" login-template <html-content> ] >>display\r
\r
- form validate-form\r
+ [\r
+ {\r
+ { "username" [ v-required ] }\r
+ { "password" [ v-required ] }\r
+ } validate-params\r
\r
- "password" value "username" value check-login\r
- [ successful-login ] [ login-failed ] if*\r
- ] >>submit\r
- ] ;\r
+ "password" value\r
+ "username" value check-login\r
+ [ successful-login ] [ login-failed ] if*\r
+ ] >>submit ;\r
\r
! ! ! New user registration\r
\r
-: <register-form> ( -- form )\r
- "register" <form>\r
- "register" login-template >>edit-template\r
- "username" <username>\r
- t >>required\r
- add-field\r
- "realname" <string> add-field\r
- "new-password" <password>\r
- t >>required\r
- add-field\r
- "verify-password" <password>\r
- t >>required\r
- add-field\r
- "email" <email> add-field\r
- "captcha" <captcha> add-field ;\r
-\r
-: password-mismatch "passwords do not match" validation-failed-with ;\r
-\r
-: user-exists "username taken" validation-failed-with ;\r
+: user-exists ( -- * )\r
+ "username taken" validation-error\r
+ validation-failed ;\r
+\r
+: password-mismatch ( -- * )\r
+ "passwords do not match" validation-error\r
+ validation-failed ;\r
\r
: same-password-twice ( -- )\r
"new-password" value "verify-password" value =\r
[ password-mismatch ] unless ;\r
\r
-:: <register-action> ( -- action )\r
- [let | form [ <register-form> ] |\r
- <action>\r
- [ blank-values ] >>init\r
-\r
- [ form edit-form ] >>display\r
+: <register-action> ( -- action )\r
+ <page-action>\r
+ "register" login-template >>template\r
\r
- [\r
- blank-values\r
-\r
- form validate-form\r
-\r
- same-password-twice\r
+ [\r
+ {\r
+ { "username" [ v-username ] }\r
+ { "realname" [ [ v-one-line ] v-optional ] }\r
+ { "new-password" [ v-password ] }\r
+ { "verify-password" [ v-password ] }\r
+ { "email" [ [ v-email ] v-optional ] }\r
+ { "captcha" [ v-captcha ] }\r
+ } validate-params\r
+\r
+ same-password-twice\r
+ ] >>validate\r
\r
- "username" value <user>\r
- "realname" value >>realname\r
- "new-password" value >>encoded-password\r
- "email" value >>email\r
- H{ } clone >>profile\r
+ [\r
+ "username" value <user>\r
+ "realname" value >>realname\r
+ "new-password" value >>encoded-password\r
+ "email" value >>email\r
+ H{ } clone >>profile\r
\r
- users new-user [ user-exists ] unless*\r
+ users new-user [ user-exists ] unless*\r
\r
- successful-login\r
+ login get init-user-profile\r
\r
- login get init-user-profile\r
- ] >>submit\r
- ] ;\r
+ successful-login\r
+ ] >>submit ;\r
\r
! ! ! Editing user profile\r
\r
-: <edit-profile-form> ( -- form )\r
- "edit-profile" <form>\r
- "edit-profile" login-template >>edit-template\r
- "username" <username> add-field\r
- "realname" <string> add-field\r
- "password" <password> add-field\r
- "new-password" <password> add-field\r
- "verify-password" <password> add-field\r
- "email" <email> add-field ;\r
-\r
-:: <edit-profile-action> ( -- action )\r
- [let | form [ <edit-profile-form> ] |\r
- <action>\r
- [\r
- blank-values\r
-\r
- logged-in-user get\r
- [ username>> "username" set-value ]\r
- [ realname>> "realname" set-value ]\r
- [ email>> "email" set-value ]\r
- tri\r
- ] >>init\r
+: <edit-profile-action> ( -- action )\r
+ <action>\r
+ [\r
+ logged-in-user get\r
+ [ username>> "username" set-value ]\r
+ [ realname>> "realname" set-value ]\r
+ [ email>> "email" set-value ]\r
+ tri\r
+ ] >>init\r
\r
- [ form edit-form ] >>display\r
+ [ "edit-profile" login-template <html-content> ] >>display\r
\r
- [\r
- blank-values\r
- uid "username" set-value\r
+ [\r
+ uid "username" set-value\r
\r
- form validate-form\r
+ {\r
+ { "realname" [ [ v-one-line ] v-optional ] }\r
+ { "password" [ ] }\r
+ { "new-password" [ [ v-password ] v-optional ] }\r
+ { "verify-password" [ [ v-password ] v-optional ] } \r
+ { "email" [ [ v-email ] v-optional ] }\r
+ } validate-params\r
\r
- logged-in-user get\r
+ { "password" "new-password" "verify-password" }\r
+ [ value empty? not ] contains? [\r
+ "password" value uid check-login\r
+ [ "incorrect password" validation-error ] unless\r
\r
- { "password" "new-password" "verify-password" }\r
- [ value empty? ] all? [\r
- same-password-twice\r
+ same-password-twice\r
+ ] when\r
+ ] >>validate\r
\r
- "password" value uid check-login\r
- [ login-failed ] unless\r
+ [\r
+ logged-in-user get\r
\r
- "new-password" value >>encoded-password\r
- ] unless\r
+ "new-password" value dup empty?\r
+ [ drop ] [ >>encoded-password ] if\r
\r
- "realname" value >>realname\r
- "email" value >>email\r
+ "realname" value >>realname\r
+ "email" value >>email\r
\r
- t >>changed?\r
+ t >>changed?\r
\r
- drop\r
+ drop\r
\r
- "$login" end-flow\r
- ] >>submit\r
- ] ;\r
+ "$login" end-flow\r
+ ] >>submit ;\r
\r
! ! ! Password recovery\r
\r
'[ , password-email smtp:send-email ]\r
"E-mail send thread" spawn drop ;\r
\r
-: <recover-form-1> ( -- form )\r
- "register" <form>\r
- "recover-1" login-template >>edit-template\r
- "username" <username>\r
- t >>required\r
- add-field\r
- "email" <email>\r
- t >>required\r
- add-field\r
- "captcha" <captcha> add-field ;\r
-\r
-:: <recover-action-1> ( -- action )\r
- [let | form [ <recover-form-1> ] |\r
- <action>\r
- [ blank-values ] >>init\r
-\r
- [ form edit-form ] >>display\r
-\r
- [\r
- blank-values\r
-\r
- form validate-form\r
-\r
- "email" value "username" value\r
- users issue-ticket [\r
- send-password-email\r
- ] when*\r
-\r
- "recover-2" login-template serve-template\r
- ] >>submit\r
- ] ;\r
-\r
-: <recover-form-3>\r
- "new-password" <form>\r
- "recover-3" login-template >>edit-template\r
- "username" <username>\r
- hidden >>renderer\r
- t >>required\r
- add-field\r
- "new-password" <password>\r
- t >>required\r
- add-field\r
- "verify-password" <password>\r
- t >>required\r
- add-field\r
- "ticket" <string>\r
- hidden >>renderer\r
- t >>required\r
- add-field ;\r
-\r
-:: <recover-action-3> ( -- action )\r
- [let | form [ <recover-form-3> ] |\r
- <action>\r
- [\r
- { "username" [ v-required ] }\r
- { "ticket" [ v-required ] }\r
- ] >>get-params\r
+: <recover-action-1> ( -- action )\r
+ <action>\r
+ [ "recover-1" login-template <html-content> ] >>display\r
\r
- [\r
- [\r
- "username" [ get ] keep set\r
- "ticket" [ get ] keep set\r
- ] H{ } make-assoc values set\r
- ] >>init\r
+ [\r
+ {\r
+ { "username" [ v-username ] }\r
+ { "email" [ v-email ] }\r
+ { "captcha" [ v-captcha ] }\r
+ } validate-params\r
+ ] >>validate\r
\r
- [ <recover-form-3> edit-form ] >>display\r
+ [\r
+ "email" value "username" value\r
+ users issue-ticket [\r
+ send-password-email\r
+ ] when*\r
\r
- [\r
- blank-values\r
+ "recover-2" login-template <html-content>\r
+ ] >>submit ;\r
\r
- form validate-form\r
+: <recover-action-3> ( -- action )\r
+ <action>\r
+ [\r
+ {\r
+ { "username" [ v-username ] }\r
+ { "ticket" [ v-required ] }\r
+ } validate-params\r
+ ] >>init\r
\r
- same-password-twice\r
+ [ "recover-3" login-template <html-content> ] >>display\r
\r
- "ticket" value\r
- "username" value\r
- users claim-ticket [\r
- "new-password" value >>encoded-password\r
- users update-user\r
-\r
- "recover-4" login-template serve-template\r
- ] [\r
- <400>\r
- ] if*\r
- ] >>submit\r
- ] ;\r
+ [\r
+ {\r
+ { "username" [ v-username ] }\r
+ { "ticket" [ v-required ] }\r
+ { "new-password" [ v-password ] }\r
+ { "verify-password" [ v-password ] }\r
+ } validate-params\r
+\r
+ same-password-twice\r
+ ] >>validate\r
+\r
+ [\r
+ "ticket" value\r
+ "username" value\r
+ users claim-ticket [\r
+ "new-password" value >>encoded-password\r
+ users update-user\r
+\r
+ "recover-4" login-template <html-content>\r
+ ] [\r
+ <400>\r
+ ] if*\r
+ ] >>submit ;\r
\r
! ! ! Logout\r
: <logout-action> ( -- action )\r
<tr>
<th class="field-label">User name:</th>
- <td><t:edit t:component="username" /></td>
+ <td><t:field t:name="username" /></td>
</tr>
<tr>
<th class="field-label">Password:</th>
- <td><t:edit t:component="password" /></td>
+ <td><t:password t:name="password" /></td>
</tr>
</table>
<p>
<input type="submit" value="Log in" />
- <t:validation-message />
+ <t:validation-messages />
</p>
<table>
- <tr>
- <th class="field-label">User name:</th>
- <td><t:edit t:component="username" /></td>
- </tr>
-
- <tr>
- <th class="field-label">E-mail:</th>
- <td><t:edit t:component="email" /></td>
- </tr>
-
- <tr>
- <th class="field-label">Captcha:</th>
- <td><t:edit t:component="captcha" /></td>
- </tr>
-
- <tr>
- <td></td>
- <td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to e-mail you will be blocked.</td>
- </tr>
+ <tr>
+ <th class="field-label">User name:</th>
+ <td><t:field t:name="username" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">E-mail:</th>
+ <td><t:field t:name="email" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Captcha:</th>
+ <td><t:field t:name="captcha" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to e-mail you will be blocked.</td>
+ </tr>
</table>
<table>
- <t:edit t:component="username" />
- <t:edit t:component="ticket" />
+ <t:hidden t:name="username" />
+ <t:hidden t:name="ticket" />
<tr>
- <th class="field-label">Password:</th>
- <td><t:edit t:component="new-password" /></td>
+ <th class="field-label">Password:</th>
+ <td><t:password t:name="new-password" /></td>
</tr>
<tr>
- <th class="field-label">Verify password:</th>
- <td><t:edit t:component="verify-password" /></td>
+ <th class="field-label">Verify password:</th>
+ <td><t:password t:name="verify-password" /></td>
</tr>
<tr>
- <td></td>
- <td>Enter your password twice to ensure it is correct.</td>
+ <td></td>
+ <td>Enter your password twice to ensure it is correct.</td>
</tr>
</table>
<p>
<input type="submit" value="Set password" />
- <t:validation-message />
+ <t:validation-messages />
</p>
</t:form>
<table>
- <tr>
- <th class="field-label">User name:</th>
- <td><t:edit t:component="username" /></td>
- </tr>
-
- <tr>
- <th class="field-label">Real name:</th>
- <td><t:edit t:component="realname" /></td>
- </tr>
-
- <tr>
- <td></td>
- <td>Specifying a real name is optional.</td>
- </tr>
-
- <tr>
- <th class="field-label">Password:</th>
- <td><t:edit t:component="new-password" /></td>
- </tr>
-
- <tr>
- <th class="field-label">Verify:</th>
- <td><t:edit t:component="verify-password" /></td>
- </tr>
-
- <tr>
- <td></td>
- <td>Enter your password twice to ensure it is correct.</td>
- </tr>
-
- <tr>
- <th class="field-label">E-mail:</th>
- <td><t:edit t:component="email" /></td>
- </tr>
-
- <tr>
- <td></td>
- <td>Specifying an e-mail address is optional. It enables the "recover password" feature.</td>
- </tr>
-
- <tr>
- <th class="field-label">Captcha:</th>
- <td><t:edit t:component="captcha" /></td>
- </tr>
-
- <tr>
- <td></td>
- <td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.</td>
- </tr>
+ <tr>
+ <th class="field-label">User name:</th>
+ <td><t:field t:name="username" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Real name:</th>
+ <td><t:field t:name="realname" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>Specifying a real name is optional.</td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Password:</th>
+ <td><t:password t:name="new-password" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Verify:</th>
+ <td><t:password t:name="verify-password" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>Enter your password twice to ensure it is correct.</td>
+ </tr>
+
+ <tr>
+ <th class="field-label">E-mail:</th>
+ <td><t:field t:name="email" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>Specifying an e-mail address is optional. It enables the "recover password" feature.</td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Captcha:</th>
+ <td><t:field t:name="captcha" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.</td>
+ </tr>
</table>
<p>
<input type="submit" value="Register" />
- <t:validation-message />
+ <t:validation-messages />
</p>
M: users-in-memory update-user ( user provider -- ) 2drop ;\r
\r
M: users-in-memory new-user ( user provider -- user/f )\r
- >r dup username>> r> assoc>>\r
- 2dup key? [ 3drop f ] [ pick >r set-at r> ] if ;\r
+ [ dup username>> ] dip assoc>>\r
+ 2dup key? [ 3drop f ] [ pick [ set-at ] dip ] if ;\r
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel namespaces boxes sequences strings
-io io.streams.string arrays locals
-html.elements
-http
-http.server
-http.server.sessions
-http.server.templating ;
+USING: accessors kernel namespaces http.server html.templates
+locals ;
IN: http.server.boilerplate
TUPLE: boilerplate < filter-responder template ;
: <boilerplate> f boilerplate boa ;
-SYMBOL: title
-
-: set-title ( string -- )
- title get >box ;
-
-: write-title ( -- )
- title get value>> write ;
-
-SYMBOL: style
-
-: add-style ( string -- )
- "\n" style get push-all
- style get push-all ;
-
-: write-style ( -- )
- style get >string write ;
-
-SYMBOL: atom-feed
-
-: set-atom-feed ( title url -- )
- 2array atom-feed get >box ;
-
-: write-atom-feed ( -- )
- atom-feed get value>> [
- <link "alternate" =rel "application/atom+xml" =type
- [ first =title ] [ second =href ] bi
- link/>
- ] when* ;
-
-SYMBOL: nested-template?
-
-SYMBOL: next-template
-
-: call-next-template ( -- )
- next-template get write-html ;
-
-M: f call-template* drop call-next-template ;
-
-: with-boilerplate ( body template -- )
- [
- title get [ <box> title set ] unless
- atom-feed get [ <box> atom-feed set ] unless
- style get [ SBUF" " clone style set ] unless
-
- [
- [
- nested-template? on
- write-response-body*
- ] with-string-writer
- next-template set
- ]
- [ call-template ]
- bi*
- ] with-scope ; inline
-
M:: boilerplate call-responder* ( path responder -- )
path responder call-next-method
dup content-type>> "text/html" = [
! Copyright (C) 2004 Chris Double.\r
! Copyright (C) 2006, 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: html http http.server io kernel math namespaces\r
+USING: http http.server io kernel math namespaces\r
continuations calendar sequences assocs hashtables\r
accessors arrays alarms quotations combinators fry assocs.lib ;\r
IN: http.server.callbacks\r
[ restore-request store-current-show ] when* ;\r
\r
: show-final ( quot -- * )\r
- >r redirect-to-here store-current-show r>\r
+ [ redirect-to-here store-current-show ] dip\r
call exit-with ; inline\r
\r
: resuming-callback ( responder request -- id )\r
] with-exit-continuation ;\r
\r
: show-page ( quot -- )\r
- >r redirect-to-here store-current-show r>\r
+ [ redirect-to-here store-current-show ] dip\r
[\r
[ ] t register-callback swap call exit-with\r
] callcc1 restore-request ; inline\r
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov
-! See http://factorcode.org/license.txt for BSD license.
-USING: splitting kernel io sequences xmode.code2html accessors
-http.server.components html xml.entities ;
-IN: http.server.components.code
-
-TUPLE: code-renderer < text-renderer mode ;
-
-: <code-renderer> ( mode -- renderer )
- code-renderer new-text-renderer
- swap >>mode ;
-
-M: code-renderer render-view*
- [
- [ string-lines ] [ mode>> value ] bi* htmlize-lines
- ] with-html-stream ;
-
-: <code> ( id mode -- component )
- swap <text>
- swap <code-renderer> >>renderer ;
+++ /dev/null
-IN: http.server.components.tests\r
-USING: http.server.components http.server.forms\r
-http.server.validators namespaces tools.test kernel accessors\r
-tuple-syntax mirrors\r
-http http.server.actions http.server.templating.fhtml\r
-io.streams.string io.streams.null ;\r
-\r
-validation-failed? off\r
-\r
-[ 3 ] [ "3" "n" <number> validate ] unit-test\r
-\r
-[ 123 ] [\r
- ""\r
- "n" <number>\r
- 123 >>default\r
- validate\r
-] unit-test\r
-\r
-[ f ] [ validation-failed? get ] unit-test\r
-\r
-[ t ] [ "3x" "n" <number> validate validation-error? ] unit-test\r
-\r
-[ t ] [ validation-failed? get ] unit-test\r
-\r
-[ "" ] [ "" "email" <email> validate ] unit-test\r
-\r
-[ "slava@jedit.org" ] [ "slava@jedit.org" "email" <email> validate ] unit-test\r
-\r
-[ "slava@jedit.org" ] [\r
- "slava@jedit.org"\r
- "email" <email>\r
- t >>required\r
- validate\r
-] unit-test\r
-\r
-[ t ] [\r
- "a"\r
- "email" <email>\r
- t >>required\r
- validate validation-error?\r
-] unit-test\r
-\r
-[ t ] [ "a" "email" <email> validate validation-error? ] unit-test\r
-\r
-TUPLE: test-tuple text number more-text ;\r
-\r
-: <test-tuple> test-tuple new ;\r
-\r
-: <test-form> ( -- form )\r
- "test" <form>\r
- "resource:extra/http/server/components/test/form.fhtml" <fhtml> >>view-template\r
- "resource:extra/http/server/components/test/form.fhtml" <fhtml> >>edit-template\r
- "text" <string>\r
- t >>required\r
- add-field\r
- "number" <number>\r
- 123 >>default\r
- t >>required\r
- 0 >>min-value\r
- 10 >>max-value\r
- add-field\r
- "more-text" <text>\r
- "hi" >>default\r
- add-field ;\r
-\r
-[ ] [ <test-tuple> <mirror> values set <test-form> view-form write-response-body drop ] unit-test\r
-\r
-[ ] [ <test-tuple> <mirror> values set <test-form> edit-form write-response-body drop ] unit-test\r
-\r
-[ TUPLE{ test-tuple number: 123 more-text: "hi" } ] [\r
- <test-tuple> from-tuple\r
- <test-form> set-defaults\r
- values-tuple\r
-] unit-test\r
-\r
-[\r
- H{\r
- { "text" "fdafsa" }\r
- { "number" "xxx" }\r
- { "more-text" "" }\r
- } params set\r
-\r
- H{ } clone values set\r
-\r
- [ t ] [ <test-form> (validate-form) ] unit-test\r
-\r
- [ "fdafsa" ] [ "text" value ] unit-test\r
-\r
- [ t ] [ "number" value validation-error? ] unit-test\r
-] with-scope\r
-\r
-[\r
- [ ] [\r
- "n" <number>\r
- 0 >>min-value\r
- 10 >>max-value\r
- "n" set\r
- ] unit-test\r
-\r
- [ "123" ] [\r
- "123" "n" get validate value>>\r
- ] unit-test\r
- \r
- [ ] [ "i" <integer> "i" set ] unit-test\r
-\r
- [ 3 ] [\r
- "3" "i" get validate\r
- ] unit-test\r
- \r
- [ t ] [\r
- "3.9" "i" get validate validation-error?\r
- ] unit-test\r
-\r
- H{ } clone values set\r
-\r
- [ ] [ 3 "i" set-value ] unit-test\r
-\r
- [ "3" ] [ [ "i" get render-view ] with-string-writer ] unit-test\r
-\r
- [ ] [ [ "i" get render-edit ] with-null-stream ] unit-test\r
-\r
- [ ] [ "t" <text> "t" set ] unit-test\r
-\r
- [ ] [ "hello world" "t" set-value ] unit-test\r
-\r
- [ ] [ [ "t" get render-edit ] with-null-stream ] unit-test\r
-] with-scope\r
-\r
-[ t ] [ "wake up sheeple" dup "n" <text> validate = ] unit-test\r
-\r
-[ ] [ "password" <password> "p" set ] unit-test\r
-\r
-[ ] [ "pub-date" <date> "d" set ] unit-test\r
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors namespaces kernel io math.parser assocs classes
-words classes.tuple arrays sequences splitting mirrors
-hashtables fry locals combinators continuations math
-calendar.format html html.elements xml.entities
-http.server.validators ;
-IN: http.server.components
-
-! Renderer protocol
-GENERIC: render-summary* ( value renderer -- )
-GENERIC: render-view* ( value renderer -- )
-GENERIC: render-edit* ( value id renderer -- )
-
-M: object render-summary* render-view* ;
-
-TUPLE: field type ;
-
-C: <field> field
-
-M: field render-view*
- drop escape-string write ;
-
-M: field render-edit*
- <input type>> =type =name =value input/> ;
-
-TUPLE: hidden < field ;
-
-: hidden ( -- renderer ) T{ hidden f "hidden" } ; inline
-
-! Component protocol
-SYMBOL: components
-
-TUPLE: component id required default renderer ;
-
-: component ( name -- component )
- dup components get at
- [ ] [ "No such component: " prepend throw ] ?if ;
-
-GENERIC: init ( component -- component )
-
-M: component init ;
-
-GENERIC: validate* ( value component -- result )
-GENERIC: component-string ( value component -- string )
-
-SYMBOL: values
-
-: value values get at ;
-
-: set-value values get set-at ;
-
-: blank-values H{ } clone values set ;
-
-: from-tuple <mirror> values set ;
-
-: values-tuple values get mirror-object ;
-
-: render-view-or-summary ( component -- value renderer )
- [ id>> value ] [ component-string ] [ renderer>> ] tri ;
-
-: render-view ( component -- )
- render-view-or-summary render-view* ;
-
-: render-summary ( component -- )
- render-view-or-summary render-summary* ;
-
-<PRIVATE
-
-: render-edit-string ( string component -- )
- [ id>> ] [ renderer>> ] bi render-edit* ;
-
-: render-edit-error ( component -- )
- [ id>> value ] keep
- [ [ value>> ] dip render-edit-string ]
- [ drop reason>> render-error ] 2bi ;
-
-: value-or-default ( component -- value )
- [ id>> value ] [ default>> ] bi or ;
-
-: render-edit-value ( component -- )
- [ value-or-default ]
- [ component-string ]
- [ render-edit-string ]
- tri ;
-
-PRIVATE>
-
-: render-edit ( component -- )
- dup id>> value validation-error?
- [ render-edit-error ] [ render-edit-value ] if ;
-
-: validate ( value component -- result )
- '[
- ,
- over empty? [
- [ default>> [ v-default ] when* ]
- [ required>> [ v-required ] when ]
- bi
- ] [ validate* ] if
- ] with-validator ;
-
-: new-component ( id class renderer -- component )
- swap new
- swap >>renderer
- swap >>id
- init ; inline
-
-! String input fields
-TUPLE: string < component one-line min-length max-length ;
-
-: new-string ( id class -- component )
- "text" <field> new-component
- t >>one-line ; inline
-
-: <string> ( id -- component )
- string new-string ;
-
-M: string validate*
- [ one-line>> [ v-one-line ] when ]
- [ min-length>> [ v-min-length ] when* ]
- [ max-length>> [ v-max-length ] when* ]
- tri ;
-
-M: string component-string
- drop ;
-
-! Username fields
-TUPLE: username < string ;
-
-M: username init
- 2 >>min-length
- 20 >>max-length ;
-
-: <username> ( id -- component )
- username new-string ;
-
-M: username validate*
- call-next-method v-one-word ;
-
-! E-mail fields
-TUPLE: email < string ;
-
-: <email> ( id -- component )
- email new-string
- 5 >>min-length
- 60 >>max-length ;
-
-M: email validate*
- call-next-method dup empty? [ v-email ] unless ;
-
-! URL fields
-TUPLE: url < string ;
-
-: <url> ( id -- component )
- url new-string
- 5 >>min-length
- 60 >>max-length ;
-
-M: url validate*
- call-next-method dup empty? [ v-url ] unless ;
-
-! Don't send passwords back to the user
-TUPLE: password-renderer < field ;
-
-: password-renderer T{ password-renderer f "password" } ;
-
-: blank-password >r >r drop "" r> r> ;
-
-M: password-renderer render-edit*
- blank-password call-next-method ;
-
-! Password fields
-TUPLE: password < string ;
-
-M: password init
- 6 >>min-length
- 60 >>max-length ;
-
-: <password> ( id -- component )
- password new-string
- password-renderer >>renderer ;
-
-M: password validate*
- call-next-method v-one-word ;
-
-! Number fields
-TUPLE: number < string min-value max-value ;
-
-: <number> ( id -- component )
- number new-string ;
-
-M: number validate*
- [ v-number ] [
- [ min-value>> [ v-min-value ] when* ]
- [ max-value>> [ v-max-value ] when* ]
- bi
- ] bi* ;
-
-M: number component-string
- drop dup [ number>string ] when ;
-
-! Integer fields
-TUPLE: integer < number ;
-
-: <integer> ( id -- component )
- integer new-string ;
-
-M: integer validate*
- call-next-method v-integer ;
-
-! Simple captchas
-TUPLE: captcha < string ;
-
-: <captcha> ( id -- component )
- captcha new-string ;
-
-M: captcha validate*
- drop v-captcha ;
-
-! Text areas
-TUPLE: text-renderer rows cols ;
-
-: new-text-renderer ( class -- renderer )
- new
- 60 >>cols
- 20 >>rows ;
-
-: <text-renderer> ( -- renderer )
- text-renderer new-text-renderer ;
-
-M: text-renderer render-view*
- drop escape-string write ;
-
-M: text-renderer render-edit*
- <textarea
- [ rows>> [ number>string =rows ] when* ]
- [ cols>> [ number>string =cols ] when* ] bi
- [ =id ]
- [ =name ] bi
- textarea>
- escape-string write
- </textarea> ;
-
-TUPLE: text < string ;
-
-: new-text ( id class -- component )
- new-string
- f >>one-line
- <text-renderer> >>renderer ;
-
-: <text> ( id -- component )
- text new-text ;
-
-! HTML text component
-TUPLE: html-text-renderer < text-renderer ;
-
-: <html-text-renderer> ( -- renderer )
- html-text-renderer new-text-renderer ;
-
-M: html-text-renderer render-view*
- drop escape-string write ;
-
-TUPLE: html-text < text ;
-
-: <html-text> ( id -- component )
- html-text new-text
- <html-text-renderer> >>renderer ;
-
-! Date component
-TUPLE: date < string ;
-
-: <date> ( id -- component )
- date new-string ;
-
-M: date component-string
- drop timestamp>string ;
-
-! Link components
-
-GENERIC: link-title ( obj -- string )
-GENERIC: link-href ( obj -- url )
-
-SINGLETON: link-renderer
-
-M: link-renderer render-view*
- drop <a dup link-href =href a> link-title escape-string write </a> ;
-
-TUPLE: link < string ;
-
-: <link> ( id -- component )
- link new-string
- link-renderer >>renderer ;
-
-! List components
-SYMBOL: +plain+
-SYMBOL: +ordered+
-SYMBOL: +unordered+
-
-TUPLE: list-renderer component type ;
-
-C: <list-renderer> list-renderer
-
-: render-plain-list ( seq component quot -- )
- '[ , component>> renderer>> @ ] each ; inline
-
-: render-li-list ( seq component quot -- )
- '[ <li> @ </li> ] render-plain-list ; inline
-
-: render-ordered-list ( seq quot component -- )
- <ol> render-li-list </ol> ; inline
-
-: render-unordered-list ( seq quot component -- )
- <ul> render-li-list </ul> ; inline
-
-: render-list ( value renderer quot -- )
- over type>> {
- { +plain+ [ render-plain-list ] }
- { +ordered+ [ render-ordered-list ] }
- { +unordered+ [ render-unordered-list ] }
- } case ; inline
-
-M: list-renderer render-view*
- [ render-view* ] render-list ;
-
-M: list-renderer render-summary*
- [ render-summary* ] render-list ;
-
-TUPLE: list < component ;
-
-: <list> ( id component type -- list )
- <list-renderer> list swap new-component ;
-
-M: list component-string drop ;
-
-! Choice
-TUPLE: choice-renderer choices ;
-
-C: <choice-renderer> choice-renderer
-
-M: choice-renderer render-view*
- drop escape-string write ;
-
-: render-option ( text selected? -- )
- <option [ "true" =selected ] when option>
- escape-string write
- </option> ;
-
-: render-options ( options selected -- )
- '[ dup , member? render-option ] each ;
-
-M: choice-renderer render-edit*
- <select swap =name select>
- choices>> swap 1array render-options
- </select> ;
-
-TUPLE: choice < string ;
-
-: <choice> ( id choices -- component )
- swap choice new-string
- swap <choice-renderer> >>renderer ;
-
-! Menu
-TUPLE: menu-renderer choices size ;
-
-: <menu-renderer> ( choices -- renderer )
- 5 menu-renderer boa ;
-
-M:: menu-renderer render-edit* ( value id renderer -- )
- <select
- renderer size>> [ number>string =size ] when*
- id =name
- "true" =multiple
- select>
- renderer choices>> value render-options
- </select> ;
-
-TUPLE: menu < string ;
-
-: <menu> ( id choices -- component )
- swap menu new-string
- swap <menu-renderer> >>renderer ;
-
-! Checkboxes
-TUPLE: checkbox-renderer label ;
-
-C: <checkbox-renderer> checkbox-renderer
-
-M: checkbox-renderer render-edit*
- <input
- "checkbox" =type
- swap =id
- swap [ "true" =selected ] when
- input>
- label>> escape-string write
- </input> ;
-
-TUPLE: checkbox < string ;
-
-: <checkbox> ( id label -- component )
- checkbox swap <checkbox-renderer> new-component ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: splitting kernel io sequences farkup accessors\r
-http.server.components xml.entities ;\r
-IN: http.server.components.farkup\r
-\r
-TUPLE: farkup-renderer < text-renderer ;\r
-\r
-: <farkup-renderer> ( -- renderer )\r
- farkup-renderer new-text-renderer ;\r
-\r
-M: farkup-renderer render-view*\r
- drop string-lines "\n" join convert-farkup write ;\r
-\r
-: <farkup> ( id -- component )\r
- <text>\r
- <farkup-renderer> >>renderer ;\r
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov
-! See http://factorcode.org/license.txt for BSD license.
-USING: splitting kernel io sequences inspector accessors
-http.server.components xml.entities html ;
-IN: http.server.components.inspector
-
-SINGLETON: inspector-renderer
-
-M: inspector-renderer render-view*
- drop [ describe ] with-html-stream ;
-
-TUPLE: inspector < component ;
-
-M: inspector component-string drop ;
-
-: <inspector> ( id -- component )
- inspector inspector-renderer new-component ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces db.tuples math.parser
-accessors fry locals hashtables
-http.server
-http.server.actions
-http.server.components
-http.server.forms
-http.server.validators ;
-IN: http.server.crud
-
-:: <view-action> ( form ctor -- action )
- <action>
- { { "id" [ v-number ] } } >>get-params
-
- [ "id" get ctor call select-tuple from-tuple ] >>init
-
- [ form view-form ] >>display ;
-
-: <id-redirect> ( id next -- response )
- swap number>string "id" associate <standard-redirect> ;
-
-:: <edit-action> ( form ctor next -- action )
- <action>
- { { "id" [ [ v-number ] v-optional ] } } >>get-params
-
- [
- "id" get ctor call
-
- "id" get
- [ select-tuple from-tuple ]
- [ from-tuple form set-defaults ]
- if
- ] >>init
-
- [ form edit-form ] >>display
-
- [
- f ctor call from-tuple
-
- form validate-form
-
- values-tuple
- "id" value [ update-tuple ] [ insert-tuple ] if
-
- "id" value next <id-redirect>
- ] >>submit ;
-
-:: <delete-action> ( ctor next -- action )
- <action>
- { { "id" [ v-number ] } } >>post-params
-
- [
- "id" get ctor call delete-tuples
-
- next f <standard-redirect>
- ] >>submit ;
-
-:: <list-action> ( form ctor -- action )
- <action>
- [
- blank-values
-
- f ctor call select-tuples "list" set-value
-
- form view-form
- ] >>display ;
\r
TUPLE: db-persistence < filter-responder pool ;\r
\r
-: <db-persistence> ( responder db params -- responder' )\r
+: <db-persistence> ( responder params db -- responder' )\r
<db-pool> db-persistence boa ;\r
\r
M: db-persistence call-responder*\r
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors assocs namespaces io.files sequences fry
-http.server
-http.server.actions
-http.server.components
-http.server.validators
-http.server.templating ;
-IN: http.server.forms
-
-TUPLE: form < component
-view-template edit-template summary-template
-components ;
-
-M: form init V{ } clone >>components ;
-
-: <form> ( id -- form )
- form f new-component
- dup >>renderer ;
-
-: add-field ( form component -- form )
- dup id>> pick components>> set-at ;
-
-: set-components ( form -- )
- components>> components set ;
-
-: with-form ( form quot -- )
- [ [ set-components ] [ call ] bi* ] with-scope ; inline
-
-: set-defaults ( form -- )
- [
- components get [
- swap values get [
- swap default>> or
- ] change-at
- ] assoc-each
- ] with-form ;
-
-: <form-response> ( form template -- response )
- [ components>> components set ] [ <html-content> ] bi* ;
-
-: view-form ( form -- response )
- dup view-template>> <form-response> ;
-
-: edit-form ( form -- response )
- dup edit-template>> <form-response> ;
-
-: validate-param ( id component -- )
- [ [ params get at ] [ validate ] bi* ]
- [ drop set-value ] 2bi ;
-
-: (validate-form) ( form -- error? )
- [
- validation-failed? off
- components get [ validate-param ] assoc-each
- validation-failed? get
- ] with-form ;
-
-: validate-form ( form -- )
- (validate-form) [ validation-failed ] when ;
-
-: render-form ( value form template -- )
- [
- [ from-tuple ]
- [ set-components ]
- [ call-template ]
- tri*
- ] with-scope ;
-
-M: form component-string drop ;
-
-M: form render-summary*
- dup summary-template>> render-form ;
-
-M: form render-view*
- dup view-template>> render-form ;
-
-M: form render-edit*
- nip dup edit-template>> render-form ;
M: mock-responder call-responder*
nip
path>> on
- "text/plain" <content> ;
+ [ ] <text-content> ;
: check-dispatch ( tag path -- ? )
H{ } clone base-paths set
M: path-check-responder call-responder*
drop
- "text/plain" <content> swap >array >>body ;
+ >array <text-content> ;
[ { "c" } ] [
H{ } clone base-paths set
M: base-path-check-responder call-responder*
2drop
"$funny-dispatcher" resolve-base-path
- "text/plain" <content> swap >>body ;
+ <text-content> ;
[ ] [
<dispatcher>
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel namespaces io io.timeouts strings splitting
-threads sequences prettyprint io.server logging calendar
-http html html.elements accessors math.parser combinators.lib
-tools.vocabs debugger continuations random combinators
-destructors io.encodings.8-bit fry classes words ;
+threads sequences prettyprint io.server logging calendar http
+html.streams html.elements accessors math.parser
+combinators.lib tools.vocabs debugger continuations random
+combinators destructors io.encodings.8-bit fry classes words
+math rss json.writer ;
IN: http.server
! path is a sequence of path component strings
{ "POST" [ post-data>> ] }
} case ;
-: <content> ( content-type -- response )
+: <content> ( body content-type -- response )
<response>
200 >>code
"Document follows" >>message
- swap >>content-type ;
+ swap >>content-type
+ swap >>body ;
-: <html-content> ( quot -- response )
- "text/html" <content> swap >>body ;
+: <text-content> ( body -- response )
+ "text/plain" <content> ;
+
+: <html-content> ( body -- response )
+ "text/html" <content> ;
+
+: <xml-content> ( body -- response )
+ "text/xml" <content> ;
+
+: <feed-content> ( feed -- response )
+ '[ , feed>xml ] "text/xml" <content> ;
+
+: <json-content> ( obj -- response )
+ '[ , >json ] "application/json" <content> ;
TUPLE: trivial-responder response ;
: resolve-base-path ( string -- string' )
"$" ?head [
[
- "/" split1 >r
- base-path [ "/" % % ] each "/" %
- r> %
+ "/" split1 [ base-path [ "/" % % ] each "/" % ] dip %
] "" make
] when ;
request-url ;
: replace-last-component ( path with -- path' )
- >r "/" last-split1 drop "/" r> 3append ;
+ [ "/" last-split1 drop "/" ] dip 3append ;
: relative-redirect ( to query -- url )
request get clone
{
{ [ over "http://" head? ] [ link>string ] }
{ [ over "/" head? ] [ absolute-redirect ] }
- { [ over "$" head? ] [ >r resolve-base-path r> derive-url ] }
+ { [ over "$" head? ] [ [ resolve-base-path ] dip derive-url ] }
[ relative-redirect ]
} cond ;
[ nip ] [ drop default>> ] if
] [
over first over responders>> at*
- [ >r drop rest-slice r> ] [ drop default>> ] if
+ [ [ drop rest-slice ] dip ] [ drop default>> ] if
] if ;
M: dispatcher call-responder* ( path dispatcher -- response )
] with-destructors ;
: httpd ( port -- )
- internet-server "http.server"
- latin1 [ handle-client ] with-server ;
+ dup integer? [ internet-server ] when
+ "http.server" latin1
+ [ handle-client ] with-server ;
-: httpd-main ( -- ) 8888 httpd ;
+: httpd-main ( -- )
+ 8888 httpd ;
MAIN: httpd-main
\r
: with-session\r
[\r
- >r [ save-session-after ] [ session set ] bi r> call\r
+ [ [ save-session-after ] [ session set ] bi ] dip call\r
] with-destructors ; inline\r
\r
TUPLE: foo ;\r
M: foo call-responder*\r
2drop\r
"x" [ 1+ ] schange\r
- "text/html" <content> [ "x" sget pprint ] >>body ;\r
+ [ "x" sget pprint ] <html-content> ;\r
\r
: url-responder-mock-test\r
[\r
\r
: <exiting-action>\r
<action>\r
- [\r
- "text/plain" <content> exit-with\r
- ] >>display ;\r
+ [ [ ] <text-content> exit-with ] >>display ;\r
\r
[ "auth-test.db" temp-file sqlite-db delete-file ] ignore-errors\r
\r
! Copyright (C) 2004, 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: calendar html io io.files kernel math math.order\r
+USING: calendar io io.files kernel math math.order\r
math.parser http http.server namespaces parser sequences strings\r
assocs hashtables debugger http.mime sorting html.elements\r
-logging calendar.format accessors io.encodings.binary fry ;\r
+html.templates.fhtml logging calendar.format accessors\r
+io.encodings.binary fry xml.entities destructors ;\r
IN: http.server.static\r
\r
! special maps mime types to quots with effect ( path -- )\r
swap >>root\r
H{ } clone >>special ;\r
\r
+: (serve-static) ( path mime-type -- response )\r
+ [ [ binary <file-reader> &dispose ] dip <content> ]\r
+ [ drop file-info [ size>> ] [ modified>> ] bi ] 2bi\r
+ [ "content-length" set-header ]\r
+ [ "last-modified" set-header ] bi* ;\r
+\r
: <static> ( root -- responder )\r
- [\r
- <content>\r
- swap [\r
- file-info\r
- [ size>> "content-length" set-header ]\r
- [ modified>> "last-modified" set-header ] bi\r
- ]\r
- [ '[ , binary <file-reader> output-stream get stream-copy ] >>body ] bi\r
- ] <file-responder> ;\r
+ [ (serve-static) ] <file-responder> ;\r
\r
: serve-static ( filename mime-type -- response )\r
over modified-since?\r
\r
: file. ( name dirp -- )\r
[ "/" append ] when\r
- dup <a =href a> write </a> ;\r
+ dup <a =href a> escape-string write </a> ;\r
\r
: directory. ( path -- )\r
dup file-name [\r
- [ <h1> file-name write </h1> ]\r
+ [ <h1> file-name escape-string write </h1> ]\r
[\r
<ul>\r
directory sort-keys\r
[ <li> file. </li> ] assoc-each\r
</ul>\r
] bi\r
- ] simple-html-document ;\r
+ ] simple-page ;\r
\r
: list-directory ( directory -- response )\r
file-responder get allow-listings>> [\r
file-responder set\r
".." over member?\r
[ drop <400> ] [ "/" join serve-object ] if ;\r
+\r
+! file responder integration\r
+: enable-fhtml ( responder -- responder )\r
+ [ <fhtml> <html-content> ]\r
+ "application/x-factor-server-page"\r
+ pick special>> set-at ;\r
+++ /dev/null
-USING: http.server.templating http.server.templating.chloe
-http.server.components http.server.boilerplate tools.test
-io.streams.string kernel sequences ascii boxes namespaces xml
-splitting ;
-IN: http.server.templating.chloe.tests
-
-[ f ] [ f parse-query-attr ] unit-test
-
-[ f ] [ "" parse-query-attr ] unit-test
-
-[ H{ { "a" "b" } } ] [
- blank-values
- "b" "a" set-value
- "a" parse-query-attr
-] unit-test
-
-[ H{ { "a" "b" } { "c" "d" } } ] [
- blank-values
- "b" "a" set-value
- "d" "c" set-value
- "a,c" parse-query-attr
-] unit-test
-
-: run-template
- with-string-writer [ "\r\n\t" member? not ] filter
- "?>" split1 nip ; inline
-
-: test-template ( name -- template )
- "resource:extra/http/server/templating/chloe/test/"
- swap
- ".xml" 3append <chloe> ;
-
-[ "Hello world" ] [
- [
- "test1" test-template call-template
- ] run-template
-] unit-test
-
-[ "Blah blah" "Hello world" ] [
- [
- <box> title set
- [
- "test2" test-template call-template
- ] run-template
- title get box>
- ] with-scope
-] unit-test
-
-[ "<html><head><title>Hello world</title></head><body>Blah blah</body></html>" ] [
- [
- [
- "test2" test-template call-template
- ] "test3" test-template with-boilerplate
- ] run-template
-] unit-test
-
-: test4-aux? t ;
-
-[ "True" ] [
- [
- "test4" test-template call-template
- ] run-template
-] unit-test
-
-: test5-aux? f ;
-
-[ "" ] [
- [
- "test5" test-template call-template
- ] run-template
-] unit-test
-
-SYMBOL: test6-aux?
-
-[ "True" ] [
- [
- test6-aux? on
- "test6" test-template call-template
- ] run-template
-] unit-test
-
-SYMBOL: test7-aux?
-
-[ "" ] [
- [
- test7-aux? off
- "test7" test-template call-template
- ] run-template
-] unit-test
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel sequences combinators kernel namespaces
-classes.tuple assocs splitting words arrays memoize
-io io.files io.encodings.utf8 io.streams.string
-unicode.case tuple-syntax html html.elements
-multiline xml xml.data xml.writer xml.utilities
-http.server
-http.server.auth
-http.server.flows
-http.server.actions
-http.server.components
-http.server.sessions
-http.server.templating
-http.server.boilerplate ;
-IN: http.server.templating.chloe
-
-! Chloe is Ed's favorite web designer
-
-TUPLE: chloe path ;
-
-C: <chloe> chloe
-
-DEFER: process-template
-
-: chloe-ns "http://factorcode.org/chloe/1.0" ; inline
-
-: chloe-attrs-only ( assoc -- assoc' )
- [ drop name-url chloe-ns = ] assoc-filter ;
-
-: non-chloe-attrs-only ( assoc -- assoc' )
- [ drop name-url chloe-ns = not ] assoc-filter ;
-
-: chloe-tag? ( tag -- ? )
- {
- { [ dup tag? not ] [ f ] }
- { [ dup url>> chloe-ns = not ] [ f ] }
- [ t ]
- } cond nip ;
-
-SYMBOL: tags
-
-MEMO: chloe-name ( string -- name )
- name new
- swap >>tag
- chloe-ns >>url ;
-
-: required-attr ( tag name -- value )
- dup chloe-name rot at*
- [ nip ] [ drop " attribute is required" append throw ] if ;
-
-: optional-attr ( tag name -- value )
- chloe-name swap at ;
-
-: children>string ( tag -- string )
- [ [ process-template ] each ] with-string-writer ;
-
-: title-tag ( tag -- )
- children>string set-title ;
-
-: write-title-tag ( tag -- )
- drop
- "head" tags get member? "title" tags get member? not and
- [ <title> write-title </title> ] [ write-title ] if ;
-
-: style-tag ( tag -- )
- dup "include" optional-attr dup [
- swap children>string empty? [
- "style tag cannot have both an include attribute and a body" throw
- ] unless
- utf8 file-contents
- ] [
- drop children>string
- ] if add-style ;
-
-: write-style-tag ( tag -- )
- drop <style> write-style </style> ;
-
-: atom-tag ( tag -- )
- [ "title" required-attr ]
- [ "href" required-attr ]
- bi set-atom-feed ;
-
-: write-atom-tag ( tag -- )
- drop
- "head" tags get member? [
- write-atom-feed
- ] [
- atom-feed get value>> second write
- ] if ;
-
-: component-attr ( tag -- name )
- "component" required-attr ;
-
-: view-tag ( tag -- )
- component-attr component render-view ;
-
-: edit-tag ( tag -- )
- component-attr component render-edit ;
-
-: summary-tag ( tag -- )
- component-attr component render-summary ;
-
-: parse-query-attr ( string -- assoc )
- dup empty?
- [ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ;
-
-: flow-attr ( tag -- )
- "flow" optional-attr {
- { "none" [ flow-id off ] }
- { "begin" [ begin-flow ] }
- { "current" [ ] }
- { f [ ] }
- } case ;
-
-: session-attr ( tag -- )
- "session" optional-attr {
- { "none" [ session off flow-id off ] }
- { "current" [ ] }
- { f [ ] }
- } case ;
-
-: a-start-tag ( tag -- )
- [
- <a
- dup flow-attr
- dup session-attr
- dup "value" optional-attr [ value f ] [
- [ "href" required-attr ]
- [ "query" optional-attr parse-query-attr ]
- bi
- ] ?if link>string =href
- a>
- ] with-scope ;
-
-: process-tag-children ( tag -- )
- [ process-template ] each ;
-
-: a-tag ( tag -- )
- [ a-start-tag ]
- [ process-tag-children ]
- [ drop </a> ]
- tri ;
-
-: form-start-tag ( tag -- )
- [
- [
- <form
- "POST" =method
- {
- [ flow-attr ]
- [ session-attr ]
- [ "action" required-attr resolve-base-path =action ]
- [ tag-attrs non-chloe-attrs-only print-attrs ]
- } cleave
- form>
- ] [
- hidden-form-field
- "for" optional-attr [ component render-edit ] when*
- ] bi
- ] with-scope ;
-
-: form-tag ( tag -- )
- [ form-start-tag ]
- [ process-tag-children ]
- [ drop </form> ]
- tri ;
-
-DEFER: process-chloe-tag
-
-STRING: button-tag-markup
-<t:form class="inline" xmlns:t="http://factorcode.org/chloe/1.0">
- <button type="submit"></button>
-</t:form>
-;
-
-: add-tag-attrs ( attrs tag -- )
- tag-attrs swap update ;
-
-: button-tag ( tag -- )
- button-tag-markup string>xml delegate
- {
- [ >r tag-attrs chloe-attrs-only r> add-tag-attrs ]
- [ >r tag-attrs non-chloe-attrs-only r> "button" tag-named add-tag-attrs ]
- [ >r children>string 1array r> "button" tag-named set-tag-children ]
- [ nip ]
- } 2cleave process-chloe-tag ;
-
-: attr>word ( value -- word/f )
- dup ":" split1 swap lookup
- [ ] [ "No such word: " swap append throw ] ?if ;
-
-: attr>var ( value -- word/f )
- attr>word dup symbol? [
- "Must be a symbol: " swap append throw
- ] unless ;
-
-: if-satisfied? ( tag -- ? )
- t swap
- {
- [ "code" optional-attr [ attr>word execute and ] when* ]
- [ "var" optional-attr [ attr>var get and ] when* ]
- [ "svar" optional-attr [ attr>var sget and ] when* ]
- [ "uvar" optional-attr [ attr>var uget and ] when* ]
- [ "value" optional-attr [ value and ] when* ]
- } cleave ;
-
-: if-tag ( tag -- )
- dup if-satisfied? [ process-tag-children ] [ drop ] if ;
-
-: error-message-tag ( tag -- )
- children>string render-error ;
-
-: process-chloe-tag ( tag -- )
- dup name-tag {
- { "chloe" [ [ process-template ] each ] }
- { "title" [ title-tag ] }
- { "write-title" [ write-title-tag ] }
- { "style" [ style-tag ] }
- { "write-style" [ write-style-tag ] }
- { "atom" [ atom-tag ] }
- { "write-atom" [ write-atom-tag ] }
- { "view" [ view-tag ] }
- { "edit" [ edit-tag ] }
- { "summary" [ summary-tag ] }
- { "a" [ a-tag ] }
- { "form" [ form-tag ] }
- { "button" [ button-tag ] }
- { "error-message" [ error-message-tag ] }
- { "validation-message" [ drop render-validation-message ] }
- { "if" [ if-tag ] }
- { "comment" [ drop ] }
- { "call-next-template" [ drop call-next-template ] }
- [ "Unknown chloe tag: " swap append throw ]
- } case ;
-
-: process-tag ( tag -- )
- {
- [ name-tag >lower tags get push ]
- [ write-start-tag ]
- [ process-tag-children ]
- [ write-end-tag ]
- [ drop tags get pop* ]
- } cleave ;
-
-: process-template ( xml -- )
- {
- { [ dup [ chloe-tag? ] is? ] [ process-chloe-tag ] }
- { [ dup [ tag? ] is? ] [ process-tag ] }
- { [ t ] [ write-item ] }
- } cond ;
-
-: process-chloe ( xml -- )
- [
- V{ } clone tags set
-
- nested-template? get [
- process-template
- ] [
- {
- [ xml-prolog write-prolog ]
- [ xml-before write-chunk ]
- [ process-template ]
- [ xml-after write-chunk ]
- } cleave
- ] if
- ] with-scope ;
-
-M: chloe call-template*
- path>> utf8 <file-reader> read-xml process-chloe ;
-
-INSTANCE: chloe template
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
- Hello world
-</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
- <t:title>Hello world</t:title>
- Blah blah
-</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
- <t:title>Hello world</t:title>
-</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
- <html>
- <head>
- <t:write-title />
- </head>
- <body>
- <t:call-next-template />
- </body>
- </html>
-</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <t:if t:code="http.server.templating.chloe.tests:test4-aux?">
- True
- </t:if>
-
-</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <t:if t:code="http.server.templating.chloe.tests:test5-aux?">
- True
- </t:if>
-
-</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <t:if t:var="http.server.templating.chloe.tests:test6-aux?">
- True
- </t:if>
-
-</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <t:if t:var="http.server.templating.chloe.tests:test7-aux?">
- True
- </t:if>
-
-</t:chloe>
+++ /dev/null
-Slava Pestov
-Matthew Willis
+++ /dev/null
-USING: io io.files io.streams.string io.encodings.utf8
-http.server.templating http.server.templating.fhtml kernel
-tools.test sequences parser ;
-IN: http.server.templating.fhtml.tests
-
-: test-template ( path -- ? )
- "resource:extra/http/server/templating/fhtml/test/"
- prepend
- [
- ".fhtml" append <fhtml> [ call-template ] with-string-writer
- ] keep
- ".html" append utf8 file-contents = ;
-
-[ t ] [ "example" test-template ] unit-test
-[ t ] [ "bug" test-template ] unit-test
-[ t ] [ "stack" test-template ] unit-test
-
-[
- [ ] [ "<%\n%>" parse-template drop ] unit-test
-] with-file-vocabs
+++ /dev/null
-! Copyright (C) 2005 Alex Chapman
-! Copyright (C) 2006, 2008 Slava Pestov
-! See http://factorcode.org/license.txt for BSD license.
-USING: continuations sequences kernel namespaces debugger
-combinators math quotations generic strings splitting
-accessors assocs fry
-parser io io.files io.streams.string io.encodings.utf8 source-files
-html html.elements
-http.server.static http.server http.server.templating ;
-IN: http.server.templating.fhtml
-
-: templating-vocab ( -- vocab-name ) "http.server.templating.fhtml" ;
-
-! We use a custom lexer so that %> ends a token even if not
-! followed by whitespace
-TUPLE: template-lexer < lexer ;
-
-: <template-lexer> ( lines -- lexer )
- template-lexer new-lexer ;
-
-M: template-lexer skip-word
- [
- {
- { [ 2dup nth CHAR: " = ] [ drop 1+ ] }
- { [ 2dup swap tail-slice "%>" head? ] [ drop 2 + ] }
- [ f skip ]
- } cond
- ] change-lexer-column ;
-
-DEFER: <% delimiter
-
-: check-<% ( lexer -- col )
- "<%" over line-text>> rot column>> start* ;
-
-: found-<% ( accum lexer col -- accum )
- [
- over line-text>>
- >r >r column>> r> r> subseq parsed
- \ write-html parsed
- ] 2keep 2 + >>column drop ;
-
-: still-looking ( accum lexer -- accum )
- [
- [ line-text>> ] [ column>> ] bi tail
- parsed \ print-html parsed
- ] keep next-line ;
-
-: parse-%> ( accum lexer -- accum )
- dup still-parsing? [
- dup check-<%
- [ found-<% ] [ [ still-looking ] keep parse-%> ] if*
- ] [
- drop
- ] if ;
-
-: %> lexer get parse-%> ; parsing
-
-: parse-template-lines ( lines -- quot )
- <template-lexer> [
- V{ } clone lexer get parse-%> f (parse-until)
- ] with-parser ;
-
-: parse-template ( string -- quot )
- [
- use [ clone ] change
- templating-vocab use+
- string-lines parse-template-lines
- ] with-scope ;
-
-: eval-template ( string -- ) parse-template call ;
-
-: html-error. ( error -- )
- <pre> error. </pre> ;
-
-TUPLE: fhtml path ;
-
-C: <fhtml> fhtml
-
-M: fhtml call-template* ( filename -- )
- '[
- , path>> [
- "quiet" on
- parser-notes off
- templating-vocab use+
- ! so that reload works properly
- dup source-file file set
- utf8 file-contents
- [ eval-template ] [ html-error. drop ] recover
- ] with-file-vocabs
- ] assert-depth ;
-
-! file responder integration
-: enable-fhtml ( responder -- responder )
- [ <fhtml> serve-template ]
- "application/x-factor-server-page"
- pick special>> set-at ;
-
-INSTANCE: fhtml template
+++ /dev/null
-<%
- USING: prettyprint ;
- ! Hello world
- 5 pprint
-%>
+++ /dev/null
-<% USING: math ; %>
-
-<html>
- <head><title>Simple Embedded Factor Example</title></head>
- <body>
- <% 5 [ %><p>I like repetition</p><% ] times %>
- </body>
-</html>
+++ /dev/null
-
-
-<html>
- <head><title>Simple Embedded Factor Example</title></head>
- <body>
- <p>I like repetition</p><p>I like repetition</p><p>I like repetition</p><p>I like repetition</p><p>I like repetition</p>
- </body>
-</html>
-
+++ /dev/null
-The stack: <% USING: prettyprint ; .s %>
+++ /dev/null
-The stack:
-
+++ /dev/null
-USING: accessors kernel fry io io.encodings.utf8 io.files
-http http.server debugger prettyprint continuations ;
-IN: http.server.templating
-
-MIXIN: template
-
-GENERIC: call-template* ( template -- )
-
-ERROR: template-error template error ;
-
-M: template-error error.
- "Error while processing template " write
- [ template>> pprint ":" print nl ]
- [ error>> error. ]
- bi ;
-
-: call-template ( template -- )
- [ call-template* ] [ template-error ] recover ;
-
-M: template write-response-body* call-template ;
-
-: template-convert ( template output -- )
- utf8 [ call-template ] with-file-writer ;
-
-! responder integration
-: serve-template ( template -- response )
- '[ , call-template ] <html-content> ;
+++ /dev/null
-IN: http.server.validators.tests
-USING: kernel sequences tools.test http.server.validators
-accessors ;
-
-[ "foo" v-number ] must-fail
-[ 123 ] [ "123" v-number ] unit-test
-
-[ "slava@factorcode.org" ] [
- "slava@factorcode.org" v-email
-] unit-test
-
-[ "slava+foo@factorcode.org" ] [
- "slava+foo@factorcode.org" v-email
-] unit-test
-
-[ "slava@factorcode.o" v-email ]
-[ "invalid e-mail" = ] must-fail-with
-
-[ "sla@@factorcode.o" v-email ]
-[ "invalid e-mail" = ] must-fail-with
-
-[ "slava@factorcodeorg" v-email ]
-[ "invalid e-mail" = ] must-fail-with
-
-[ "http://www.factorcode.org" ]
-[ "http://www.factorcode.org" v-url ] unit-test
-
-[ "http:/www.factorcode.org" v-url ]
-[ "invalid URL" = ] must-fail-with
+++ /dev/null
-! Copyright (C) 2006, 2008 Slava Pestov
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel continuations sequences math namespaces sets
-math.parser assocs regexp fry unicode.categories sequences ;
-IN: http.server.validators
-
-SYMBOL: validation-failed?
-
-TUPLE: validation-error value reason ;
-
-C: <validation-error> validation-error
-
-: with-validator ( value quot -- result )
- [ validation-failed? on <validation-error> ] recover ; inline
-
-: v-default ( str def -- str )
- over empty? spin ? ;
-
-: v-required ( str -- str )
- dup empty? [ "required" throw ] when ;
-
-: v-optional ( str quot -- str )
- over empty? [ 2drop f ] [ call ] if ; inline
-
-: v-min-length ( str n -- str )
- over length over < [
- [ "must be at least " % # " characters" % ] "" make
- throw
- ] [
- drop
- ] if ;
-
-: v-max-length ( str n -- str )
- over length over > [
- [ "must be no more than " % # " characters" % ] "" make
- throw
- ] [
- drop
- ] if ;
-
-: v-number ( str -- n )
- dup string>number [ ] [ "must be a number" throw ] ?if ;
-
-: v-integer ( n -- n )
- dup integer? [ "must be an integer" throw ] unless ;
-
-: v-min-value ( x n -- x )
- 2dup < [
- [ "must be at least " % # ] "" make throw
- ] [
- drop
- ] if ;
-
-: v-max-value ( x n -- x )
- 2dup > [
- [ "must be no more than " % # ] "" make throw
- ] [
- drop
- ] if ;
-
-: v-regexp ( str what regexp -- str )
- >r over r> matches?
- [ drop ] [ "invalid " prepend throw ] if ;
-
-: v-email ( str -- str )
- #! From http://www.regular-expressions.info/email.html
- "e-mail"
- R' [A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}'i
- v-regexp ;
-
-: v-url ( str -- str )
- "URL"
- R' (ftp|http|https)://(\w+:?\w*@)?(\S+)(:[0-9]+)?(/|/([\w#!:.?+=&%@!\-/]))?'
- v-regexp ;
-
-: v-captcha ( str -- str )
- dup empty? [ "must remain blank" throw ] unless ;
-
-: v-one-line ( str -- str )
- dup "\r\n" intersect empty?
- [ "must be a single line" throw ] unless ;
-
-: v-one-word ( str -- str )
- dup [ alpha? ] all?
- [ "must be a single word" throw ] unless ;
: handle-overlapped ( timeout -- ? )
wait-for-overlapped [
- >r drop GetLastError
- [ 1array ] [ expected-io-error? ] bi
- [ r> 2drop f ] [ r> resume-callback t ] if
+ dup [
+ >r drop GetLastError 1array r> resume-callback t
+ ] [
+ 2drop f
+ ] if
] [
resume-callback t
] if ;
+++ /dev/null
-Doug Coleman
-Slava Pestov
--- /dev/null
+Doug Coleman
+Slava Pestov
--- /dev/null
+! Copyright (C) 2007 Doug Coleman, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays combinators concurrency.mailboxes concurrency.futures io
+ io.encodings.8-bit io.sockets kernel namespaces sequences
+ sequences.lib splitting threads calendar classes.tuple
+ ascii assocs accessors destructors ;
+IN: irc.client
+
+! ======================================
+! Setup and running objects
+! ======================================
+
+SYMBOL: current-irc-client
+
+: irc-port 6667 ; ! Default irc port
+
+! "setup" objects
+TUPLE: irc-profile server port nickname password ;
+C: <irc-profile> irc-profile
+
+TUPLE: irc-channel-profile name password ;
+: <irc-channel-profile> ( -- irc-channel-profile ) irc-channel-profile new ;
+
+! "live" objects
+TUPLE: nick name channels log ;
+C: <nick> nick
+
+TUPLE: irc-client profile nick stream in-messages out-messages join-messages
+ listeners is-running ;
+: <irc-client> ( profile -- irc-client )
+ f V{ } clone V{ } clone <nick>
+ f <mailbox> <mailbox> <mailbox> H{ } clone f irc-client boa ;
+
+TUPLE: irc-listener in-messages out-messages ;
+: <irc-listener> ( -- irc-listener )
+ <mailbox> <mailbox> irc-listener boa ;
+
+! ======================================
+! Message objects
+! ======================================
+
+SINGLETON: irc-end ! Message used when the client isn't running anymore
+
+TUPLE: irc-message line prefix command parameters trailing timestamp ;
+TUPLE: logged-in < irc-message name ;
+TUPLE: ping < irc-message ;
+TUPLE: join < irc-message ;
+TUPLE: part < irc-message name channel ;
+TUPLE: quit < irc-message ;
+TUPLE: privmsg < irc-message name ;
+TUPLE: kick < irc-message channel who ;
+TUPLE: roomlist < irc-message channel names ;
+TUPLE: nick-in-use < irc-message asterisk name ;
+TUPLE: notice < irc-message type ;
+TUPLE: mode < irc-message name channel mode ;
+TUPLE: unhandled < irc-message ;
+
+<PRIVATE
+
+! ======================================
+! Shortcuts
+! ======================================
+
+: irc-client> ( -- irc-client ) current-irc-client get ;
+: irc-stream> ( -- stream ) irc-client> stream>> ;
+: irc-write ( s -- ) irc-stream> stream-write ;
+: irc-print ( s -- ) irc-stream> [ stream-print ] keep stream-flush ;
+
+! ======================================
+! IRC client messages
+! ======================================
+
+: /NICK ( nick -- )
+ "NICK " irc-write irc-print ;
+
+: /LOGIN ( nick -- )
+ dup /NICK
+ "USER " irc-write irc-write
+ " hostname servername :irc.factor" irc-print ;
+
+: /CONNECT ( server port -- stream )
+ <inet> latin1 <client> drop ;
+
+: /JOIN ( channel password -- )
+ "JOIN " irc-write
+ [ " :" swap 3append ] when* irc-print ;
+
+: /PART ( channel text -- )
+ [ "PART " irc-write irc-write ] dip
+ " :" irc-write irc-print ;
+
+: /KICK ( channel who -- )
+ [ "KICK " irc-write irc-write ] dip
+ " " irc-write irc-print ;
+
+: /PRIVMSG ( nick line -- )
+ [ "PRIVMSG " irc-write irc-write ] dip
+ " :" irc-write irc-print ;
+
+: /ACTION ( nick line -- )
+ [ 1 , "ACTION " % % 1 , ] "" make /PRIVMSG ;
+
+: /QUIT ( text -- )
+ "QUIT :" irc-write irc-print ;
+
+: /PONG ( text -- )
+ "PONG " irc-write irc-print ;
+
+! ======================================
+! Server message handling
+! ======================================
+
+USE: prettyprint
+
+GENERIC: handle-incoming-irc ( irc-message -- )
+
+M: irc-message handle-incoming-irc ( irc-message -- )
+ . ;
+
+M: logged-in handle-incoming-irc ( logged-in -- )
+ name>> irc-client> nick>> (>>name) ;
+
+M: ping handle-incoming-irc ( ping -- )
+ trailing>> /PONG ;
+
+M: nick-in-use handle-incoming-irc ( nick-in-use -- )
+ name>> "_" append /NICK ;
+
+M: privmsg handle-incoming-irc ( privmsg -- )
+ dup name>> irc-client> listeners>> at
+ [ in-messages>> mailbox-put ] [ drop ] if* ;
+
+M: join handle-incoming-irc ( join -- )
+ irc-client> join-messages>> mailbox-put ;
+
+! ======================================
+! Client message handling
+! ======================================
+
+GENERIC: handle-outgoing-irc ( obj -- )
+
+M: privmsg handle-outgoing-irc ( privmsg -- )
+ [ name>> ] [ trailing>> ] bi /PRIVMSG ;
+
+! ======================================
+! Message parsing
+! ======================================
+
+: split-at-first ( seq separators -- before after )
+ dupd [ member? ] curry find
+ [ cut 1 tail ]
+ [ swap ]
+ if ;
+
+: remove-heading-: ( seq -- seq ) dup ":" head? [ 1 tail ] when ;
+
+: parse-name ( string -- string )
+ remove-heading-: "!" split-at-first drop ;
+
+: split-prefix ( string -- string/f string )
+ dup ":" head?
+ [ remove-heading-: " " split1 ]
+ [ f swap ]
+ if ;
+
+: split-trailing ( string -- string string/f )
+ ":" split1 ;
+
+: string>irc-message ( string -- object )
+ dup split-prefix split-trailing
+ [ [ blank? ] trim " " split unclip swap ] dip
+ now irc-message boa ;
+
+: parse-irc-line ( string -- message )
+ string>irc-message
+ dup command>> {
+ { "PING" [ \ ping ] }
+ { "NOTICE" [ \ notice ] }
+ { "001" [ \ logged-in ] }
+ { "433" [ \ nick-in-use ] }
+ { "JOIN" [ \ join ] }
+ { "PART" [ \ part ] }
+ { "PRIVMSG" [ \ privmsg ] }
+ { "QUIT" [ \ quit ] }
+ { "MODE" [ \ mode ] }
+ { "KICK" [ \ kick ] }
+ [ drop \ unhandled ]
+ } case
+ [ [ tuple-slots ] [ parameters>> ] bi append ] dip prefix >tuple ;
+
+! ======================================
+! Reader/Writer
+! ======================================
+
+: stream-readln-or-close ( stream -- str/f )
+ dup stream-readln [ nip ] [ dispose f ] if* ;
+
+: handle-reader-message ( irc-message -- )
+ irc-client> in-messages>> mailbox-put ;
+
+: handle-stream-close ( -- )
+ irc-client> f >>is-running in-messages>> irc-end swap mailbox-put ;
+
+: reader-loop ( -- )
+ irc-client> stream>> stream-readln-or-close [
+ parse-irc-line handle-reader-message
+ ] [
+ handle-stream-close
+ ] if* ;
+
+: writer-loop ( -- )
+ irc-client> out-messages>> mailbox-get handle-outgoing-irc ;
+
+! ======================================
+! Processing loops
+! ======================================
+
+: in-multiplexer-loop ( -- )
+ irc-client> in-messages>> mailbox-get handle-incoming-irc ;
+
+! FIXME: Hack, this should be handled better
+GENERIC: add-name ( name obj -- obj )
+M: object add-name nip ;
+M: privmsg add-name swap >>name ;
+
+: listener-loop ( name -- ) ! FIXME: take different values from the stack?
+ dup irc-client> listeners>> at [
+ out-messages>> mailbox-get add-name
+ irc-client> out-messages>>
+ mailbox-put
+ ] [ drop ] if* ;
+
+: spawn-irc-loop ( quot name -- )
+ [ [ irc-client> is-running>> ] compose ] dip
+ spawn-server drop ;
+
+: spawn-irc ( -- )
+ [ reader-loop ] "irc-reader-loop" spawn-irc-loop
+ [ writer-loop ] "irc-writer-loop" spawn-irc-loop
+ [ in-multiplexer-loop ] "in-multiplexer-loop" spawn-irc-loop ;
+
+! ======================================
+! Listener join request handling
+! ======================================
+
+: make-registered-listener ( join -- listener )
+ <irc-listener> swap trailing>>
+ dup [ listener-loop ] curry "listener" spawn-irc-loop
+ [ irc-client> listeners>> set-at ] curry keep ;
+
+: make-join-future ( name -- future )
+ [ [ swap trailing>> = ] curry ! compare name with channel name
+ irc-client> join-messages>> 60 seconds rot mailbox-get-timeout?
+ make-registered-listener ]
+ curry future ;
+
+PRIVATE>
+
+: (connect-irc) ( irc-client -- )
+ [ profile>> [ server>> ] keep port>> /CONNECT ] keep
+ swap >>stream
+ t >>is-running drop ;
+
+: connect-irc ( irc-client -- )
+ dup current-irc-client [
+ [ (connect-irc) ] [ profile>> nickname>> /LOGIN ] bi
+ spawn-irc
+ ] with-variable ;
+
+: listen-to ( irc-client name -- future )
+ swap current-irc-client [ [ f /JOIN ] keep make-join-future ] with-variable ;
+
+! shorcut for privmsgs, etc
+: sender>> ( obj -- string )
+ prefix>> parse-name ;
--- /dev/null
+An IRC client framework
+++ /dev/null
-! Copyright (C) 2007 Doug Coleman, Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays calendar combinators channels concurrency.messaging fry io
- io.encodings.8-bit io.sockets kernel math namespaces sequences
- sequences.lib splitting strings threads
- continuations destructors classes.tuple ascii accessors ;
-IN: irc
-
-! utils
-: split-at-first ( seq separators -- before after )
- dupd '[ , member? ] find
- [ cut rest ]
- [ swap ]
- if ;
-
-: spawn-server-linked ( quot name -- thread )
- >r '[ , [ ] [ ] while ] r>
- spawn-linked ;
-! ---
-
-! Default irc port
-: irc-port 6667 ;
-
-! Message used when the client isn't running anymore
-SINGLETON: irc-end
-
-! "setup" objects
-TUPLE: irc-profile server port nickname password default-channels ;
-C: <irc-profile> irc-profile
-
-TUPLE: irc-channel-profile name password auto-rejoin ;
-C: <irc-channel-profile> irc-channel-profile
-
-! "live" objects
-TUPLE: nick name channels log ;
-C: <nick> nick
-
-TUPLE: irc-client profile nick stream stream-channel controller-channel
- listeners is-running ;
-: <irc-client> ( profile -- irc-client )
- f V{ } clone V{ } clone <nick>
- f <channel> <channel> V{ } clone f irc-client boa ;
-
-USE: prettyprint
-TUPLE: irc-listener channel ;
-! FIXME: spawn-server-linked con manejo de excepciones, mandar un mensaje final (ya se maneja esto al recibir mensajes del channel? )
-! tener la opción de dejar de correr un client??
-: <irc-listener> ( quot -- irc-listener )
- <channel> irc-listener boa swap
- [
- [ channel>> '[ , from ] ]
- [ '[ , curry f spawn drop ] ]
- bi* compose "irc-listener" spawn-server-linked drop
- ] [ drop ] 2bi ;
-
-! TUPLE: irc-channel name topic members log attributes ;
-! C: <irc-channel> irc-channel
-
-! the delegate of all irc messages
-TUPLE: irc-message line prefix command parameters trailing timestamp ;
-C: <irc-message> irc-message
-
-! "irc message" objects
-TUPLE: logged-in < irc-message name ;
-C: <logged-in> logged-in
-
-TUPLE: ping < irc-message ;
-C: <ping> ping
-
-TUPLE: join_ < irc-message ;
-C: <join> join_
-
-TUPLE: part < irc-message name channel ;
-C: <part> part
-
-TUPLE: quit ;
-C: <quit> quit
-
-TUPLE: privmsg < irc-message name ;
-C: <privmsg> privmsg
-
-TUPLE: kick < irc-message channel who ;
-C: <kick> kick
-
-TUPLE: roomlist < irc-message channel names ;
-C: <roomlist> roomlist
-
-TUPLE: nick-in-use < irc-message name ;
-C: <nick-in-use> nick-in-use
-
-TUPLE: notice < irc-message type ;
-C: <notice> notice
-
-TUPLE: mode < irc-message name channel mode ;
-C: <mode> mode
-
-TUPLE: unhandled < irc-message ;
-C: <unhandled> unhandled
-
-SYMBOL: irc-client
-: irc-client> ( -- irc-client ) irc-client get ;
-: irc-stream> ( -- stream ) irc-client> stream>> ;
-
-: remove-heading-: ( seq -- seq ) dup ":" head? [ rest ] when ;
-
-: parse-name ( string -- string )
- remove-heading-: "!" split-at-first drop ;
-
-: sender>> ( obj -- string )
- prefix>> parse-name ;
-
-: split-prefix ( string -- string/f string )
- dup ":" head?
- [ remove-heading-: " " split1 ]
- [ f swap ]
- if ;
-
-: split-trailing ( string -- string string/f )
- ":" split1 ;
-
-: string>irc-message ( string -- object )
- dup split-prefix split-trailing
- [ [ blank? ] trim " " split unclip swap ] dip
- now <irc-message> ;
-
-: me? ( name -- ? )
- irc-client> nick>> name>> = ;
-
-: irc-write ( s -- )
- irc-stream> stream-write ;
-
-: irc-print ( s -- )
- irc-stream> [ stream-print ] keep stream-flush ;
-
-! Irc commands
-
-: NICK ( nick -- )
- "NICK " irc-write irc-print ;
-
-: LOGIN ( nick -- )
- dup NICK
- "USER " irc-write irc-write
- " hostname servername :irc.factor" irc-print ;
-
-: CONNECT ( server port -- stream )
- <inet> latin1 <client> drop ;
-
-: JOIN ( channel password -- )
- "JOIN " irc-write
- [ " :" swap 3append ] when* irc-print ;
-
-: PART ( channel text -- )
- [ "PART " irc-write irc-write ] dip
- " :" irc-write irc-print ;
-
-: KICK ( channel who -- )
- [ "KICK " irc-write irc-write ] dip
- " " irc-write irc-print ;
-
-: PRIVMSG ( nick line -- )
- [ "PRIVMSG " irc-write irc-write ] dip
- " :" irc-write irc-print ;
-
-: SAY ( nick line -- )
- PRIVMSG ;
-
-: ACTION ( nick line -- )
- [ 1 , "ACTION " % % 1 , ] "" make PRIVMSG ;
-
-: QUIT ( text -- )
- "QUIT :" irc-write irc-print ;
-
-: join-channel ( channel-profile -- )
- [ name>> ] keep password>> JOIN ;
-
-: irc-connect ( irc-client -- )
- [ profile>> [ server>> ] keep port>> CONNECT ] keep
- swap >>stream t >>is-running drop ;
-
-GENERIC: handle-irc ( obj -- )
-
-M: object handle-irc ( obj -- )
- drop ;
-
-M: logged-in handle-irc ( obj -- )
- name>>
- irc-client> [ nick>> swap >>name drop ] keep
- profile>> default-channels>> [ join-channel ] each ;
-
-M: ping handle-irc ( obj -- )
- "PONG " irc-write
- trailing>> irc-print ;
-
-M: nick-in-use handle-irc ( obj -- )
- name>> "_" append NICK ;
-
-: parse-irc-line ( string -- message )
- string>irc-message
- dup command>> {
- { "PING" [ \ ping ] }
- { "NOTICE" [ \ notice ] }
- { "001" [ \ logged-in ] }
- { "433" [ \ nick-in-use ] }
- { "JOIN" [ \ join_ ] }
- { "PART" [ \ part ] }
- { "PRIVMSG" [ \ privmsg ] }
- { "QUIT" [ \ quit ] }
- { "MODE" [ \ mode ] }
- { "KICK" [ \ kick ] }
- [ drop \ unhandled ]
- } case
- [ [ tuple-slots ] [ parameters>> ] bi append ] dip prefix >tuple ;
-
-! Reader
-: handle-reader-message ( irc-client irc-message -- )
- dup handle-irc swap stream-channel>> to ;
-
-: reader-loop ( irc-client -- )
- dup stream>> stream-readln [
- dup print parse-irc-line handle-reader-message
- ] [
- f >>is-running
- dup stream>> dispose
- irc-end over controller-channel>> to
- stream-channel>> irc-end swap to
- ] if* ;
-
-! Controller commands
-GENERIC: handle-command ( obj -- )
-
-M: object handle-command ( obj -- )
- . ;
-
-TUPLE: send-message to text ;
-C: <send-message> send-message
-M: send-message handle-command ( obj -- )
- dup to>> swap text>> SAY ;
-
-TUPLE: send-action to text ;
-C: <send-action> send-action
-M: send-action handle-command ( obj -- )
- dup to>> swap text>> ACTION ;
-
-TUPLE: send-quit text ;
-C: <send-quit> send-quit
-M: send-quit handle-command ( obj -- )
- text>> QUIT ;
-
-: irc-listen ( irc-client quot -- )
- [ listeners>> ] [ <irc-listener> ] bi* swap push ;
-
-! Controller loop
-: controller-loop ( irc-client -- )
- controller-channel>> from handle-command ;
-
-! Multiplexer
-: multiplex-message ( irc-client message -- )
- swap listeners>> [ channel>> ] map
- [ '[ , , to ] "message" spawn drop ] each-with ;
-
-: multiplexer-loop ( irc-client -- )
- dup stream-channel>> from multiplex-message ;
-
-! process looping and starting
-: (spawn-irc-loop) ( irc-client quot name -- )
- [ over >r curry r> '[ @ , is-running>> ] ] dip
- spawn-server-linked drop ;
-
-: spawn-irc-loop ( irc-client quot name -- )
- '[ , , , [ (spawn-irc-loop) receive ] [ print ] recover ]
- f spawn drop ;
-
-: spawn-irc ( irc-client -- )
- [ [ reader-loop ] "reader-loop" spawn-irc-loop ]
- [ [ controller-loop ] "controller-loop" spawn-irc-loop ]
- [ [ multiplexer-loop ] "multiplexer-loop" spawn-irc-loop ]
- tri ;
-
-: do-irc ( irc-client -- )
- irc-client [
- irc-client>
- [ irc-connect ]
- [ profile>> nickname>> LOGIN ]
- [ spawn-irc ]
- tri
- ] with-variable ;
\ No newline at end of file
+++ /dev/null
-An IRC client framework
--- /dev/null
+USING: arrays json.reader kernel multiline strings tools.test ;
+IN: json.reader.tests
+
+{ f } [ "false" json> ] unit-test
+{ t } [ "true" json> ] unit-test
+{ json-null } [ "null" json> ] unit-test
+{ 0 } [ "0" json> ] unit-test
+{ 102 } [ "102" json> ] unit-test
+{ -102 } [ "-102" json> ] unit-test
+{ 102 } [ "+102" json> ] unit-test
+{ 102.0 } [ "102.0" json> ] unit-test
+{ 102.5 } [ "102.5" json> ] unit-test
+{ 102.5 } [ "102.50" json> ] unit-test
+{ -10250 } [ "-102.5e2" json> ] unit-test
+{ -10250 } [ "-102.5E+2" json> ] unit-test
+{ 10.25 } [ "1025e-2" json> ] unit-test
+{ 0.125 } [ "0.125" json> ] unit-test
+{ -0.125 } [ "-0.125" json> ] unit-test
+
+{ " fuzzy pickles " } [ <" " fuzzy pickles " "> json> ] unit-test
+{ "while 1:\n\tpass" } [ <" "while 1:\n\tpass" "> json> ] unit-test
+{ 8 9 10 12 13 34 47 92 } >string 1array [ <" "\b\t\n\f\r\"\/\\" "> json> ] unit-test
+{ HEX: abcd } >string 1array [ <" "\uaBCd" "> json> ] unit-test
+
+{ { 1 "two" 3.0 } } [ <" [1, "two", 3.0] "> json> ] unit-test
+{ H{ { "US$" 1.0 } { "EU€" 1.5 } } } [ <" { "US$":1.00, "EU\u20AC":1.50 } "> json> ] unit-test
+{ H{
+ { "fib" { 1 1 2 3 5 8 H{ { "etc" "etc" } } } }
+ { "prime" { 2 3 5 7 11 13 } }
+} } [ <" {
+ "fib": [1, 1, 2, 3, 5, 8,
+ { "etc":"etc" } ],
+ "prime":
+ [ 2,3, 5,7,
+11,
+13
+] }
+"> json> ] unit-test
+
+{ 0 } [ " 0" json> ] unit-test
+{ 0 } [ "0 " json> ] unit-test
+{ 0 } [ " 0 " json> ] unit-test
+
! See http://factorcode.org/license.txt for BSD license.
USING: kernel parser-combinators namespaces sequences promises strings
assocs math math.parser math.vectors math.functions math.order
- lazy-lists hashtables ascii ;
+ lists lists.lazy hashtables ascii ;
IN: json.reader
! Grammar for JSON from RFC 4627
+SYMBOL: json-null
+
: [<&>] ( quot -- quot )
{ } make unclip [ <&> ] reduce ;
" " token
"\n" token <|>
"\r" token <|>
- "\t" token <|>
- "" token <|> ;
+ "\t" token <|> <*> ;
LAZY: spaced ( parser -- parser )
'ws' swap &> 'ws' <& ;
"," token spaced ;
LAZY: 'false' ( -- parser )
- "false" token ;
+ "false" token [ drop f ] <@ ;
LAZY: 'null' ( -- parser )
- "null" token ;
+ "null" token [ drop json-null ] <@ ;
LAZY: 'true' ( -- parser )
- "true" token ;
+ "true" token [ drop t ] <@ ;
LAZY: 'quot' ( -- parser )
"\"" token ;
+LAZY: 'hex-digit' ( -- parser )
+ [ digit> ] satisfy [ digit> ] <@ ;
+
+: hex-digits>ch ( digits -- ch )
+ 0 [ swap 16 * + ] reduce ;
+
+LAZY: 'string-char' ( -- parser )
+ [ quotable? ] satisfy
+ "\\b" token [ drop 8 ] <@ <|>
+ "\\t" token [ drop CHAR: \t ] <@ <|>
+ "\\n" token [ drop CHAR: \n ] <@ <|>
+ "\\f" token [ drop 12 ] <@ <|>
+ "\\r" token [ drop CHAR: \r ] <@ <|>
+ "\\\"" token [ drop CHAR: " ] <@ <|>
+ "\\/" token [ drop CHAR: / ] <@ <|>
+ "\\\\" token [ drop CHAR: \\ ] <@ <|>
+ "\\u" token 'hex-digit' 4 exactly-n &>
+ [ hex-digits>ch ] <@ <|> ;
+
LAZY: 'string' ( -- parser )
'quot'
- [
- [ quotable? ] keep
- [ CHAR: \\ = or ] keep
- CHAR: " = not and
- ] satisfy <*> &>
+ 'string-char' <*> &>
'quot' <& [ >string ] <@ ;
DEFER: 'value'
LAZY: 'plus' ( -- parser )
"+" token ;
+LAZY: 'sign' ( -- parser )
+ 'minus' 'plus' <|> ;
+
LAZY: 'zero' ( -- parser )
"0" token [ drop 0 ] <@ ;
: sign-number ( pair -- number )
#! Pair is { minus? num }
#! Convert the json number value to a factor number
- dup second swap first [ -1 * ] when ;
+ dup second swap first [ first "-" = [ -1 * ] when ] when* ;
LAZY: 'exp' ( -- parser )
'e'
- 'minus' 'plus' <|> <?> &>
+ 'sign' <?> &>
'digit0-9' <+> [ decimal>integer ] <@ <&> [ sign-number ] <@ ;
: sequence>frac ( seq -- num )
dup second dup [ 10 swap first ^ swap first * ] [ drop first ] if ;
LAZY: 'number' ( -- parser )
- 'minus' <?>
+ 'sign' <?>
[ 'int' , 'frac' 0 succeed <|> , ] [<&>] [ sum ] <@
'exp' <?> <&> [ raise-to-power ] <@ <&> [ sign-number ] <@ ;
'object' ,
'array' ,
'number' ,
- ] [<|>] ;
+ ] [<|>] spaced ;
: json> ( string -- object )
#! Parse a json formatted string to a factor object
+++ /dev/null
-Chris Double
-Samuel Tardieu
-Matthew Willis
+++ /dev/null
-Chris Double
+++ /dev/null
-USING: lazy-lists.examples lazy-lists tools.test ;
-IN: lazy-lists.examples.tests
-
-[ { 1 3 5 7 } ] [ 4 odds ltake list>array ] unit-test
-[ { 0 1 4 9 16 } ] [ first-five-squares ] unit-test
+++ /dev/null
-! Rewritten by Matthew Willis, July 2006
-! Copyright (C) 2004 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-
-USING: lazy-lists math kernel sequences quotations ;
-IN: lazy-lists.examples
-
-: naturals 0 lfrom ;
-: positives 1 lfrom ;
-: evens 0 [ 2 + ] lfrom-by ;
-: odds 1 lfrom [ 2 mod 1 = ] lfilter ;
-: powers-of-2 1 [ 2 * ] lfrom-by ;
-: ones 1 [ ] lfrom-by ;
-: squares naturals [ dup * ] lmap ;
-: first-five-squares 5 squares ltake list>array ;
+++ /dev/null
-! Copyright (C) 2006 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-
-USING: help.markup help.syntax sequences strings ;
-IN: lazy-lists
-
-{ car cons cdr nil nil? list? uncons } related-words
-
-HELP: cons
-{ $values { "car" "the head of the lazy list" } { "cdr" "the tail of the lazy list" } { "cons" "a cons object" } }
-{ $description "Constructs a cons cell." } ;
-
-HELP: car
-{ $values { "cons" "a cons object" } { "car" "the first item in the list" } }
-{ $description "Returns the first item in the list." } ;
-
-HELP: cdr
-{ $values { "cons" "a cons object" } { "cdr" "a cons object" } }
-{ $description "Returns the tail of the list." } ;
-
-HELP: nil
-{ $values { "cons" "An empty cons" } }
-{ $description "Returns a representation of an empty list" } ;
-
-HELP: nil?
-{ $values { "cons" "a cons object" } { "?" "a boolean" } }
-{ $description "Return true if the cons object is the nil cons." } ;
-
-HELP: list? ( object -- ? )
-{ $values { "object" "an object" } { "?" "a boolean" } }
-{ $description "Returns true if the object conforms to the list protocol." } ;
-
-{ 1list 2list 3list } related-words
-
-HELP: 1list
-{ $values { "obj" "an object" } { "cons" "a cons object" } }
-{ $description "Create a list with 1 element." } ;
-
-HELP: 2list
-{ $values { "a" "an object" } { "b" "an object" } { "cons" "a cons object" } }
-{ $description "Create a list with 2 elements." } ;
-
-HELP: 3list
-{ $values { "a" "an object" } { "b" "an object" } { "c" "an object" } { "cons" "a cons object" } }
-{ $description "Create a list with 3 elements." } ;
-
-HELP: lazy-cons
-{ $values { "car" "a quotation with stack effect ( -- X )" } { "cdr" "a quotation with stack effect ( -- cons )" } { "promise" "the resulting cons object" } }
-{ $description "Constructs a cons object for a lazy list from two quotations. The " { $snippet "car" } " quotation should return the head of the list, and the " { $snippet "cons" } " quotation the tail when called. When " { $link cons } " or " { $link cdr } " are called on the lazy-cons object then the appropriate quotation is called." }
-{ $see-also cons car cdr nil nil? } ;
-
-{ 1lazy-list 2lazy-list 3lazy-list } related-words
-
-HELP: 1lazy-list
-{ $values { "a" "a quotation with stack effect ( -- X )" } { "lazy-cons" "a lazy-cons object" } }
-{ $description "Create a lazy list with 1 element. The element is the result of calling the quotation. The quotation is only called when the list element is requested." } ;
-
-HELP: 2lazy-list
-{ $values { "a" "a quotation with stack effect ( -- X )" } { "b" "a quotation with stack effect ( -- X )" } { "lazy-cons" "a lazy-cons object" } }
-{ $description "Create a lazy list with 2 elements. The elements are the result of calling the quotations. The quotations are only called when the list elements are requested." } ;
-
-HELP: 3lazy-list
-{ $values { "a" "a quotation with stack effect ( -- X )" } { "b" "a quotation with stack effect ( -- X )" } { "c" "a quotation with stack effect ( -- X )" } { "lazy-cons" "a lazy-cons object" } }
-{ $description "Create a lazy list with 3 elements. The elements are the result of calling the quotations. The quotations are only called when the list elements are requested." } ;
-
-HELP: <memoized-cons>
-{ $values { "cons" "a cons object" } { "memoized-cons" "the resulting memoized-cons object" } }
-{ $description "Constructs a cons object that wraps an existing cons object. Requests for the car, cdr and nil? will be remembered after the first call, and the previous result returned on subsequent calls." }
-{ $see-also cons car cdr nil nil? } ;
-
-HELP: lnth
-{ $values { "n" "an integer index" } { "list" "a cons object" } { "elt" "the element at the nth index" } }
-{ $description "Outputs the nth element of the list." }
-{ $see-also llength cons car cdr } ;
-
-HELP: llength
-{ $values { "list" "a cons object" } { "n" "a non-negative integer" } }
-{ $description "Outputs the length of the list. This should not be called on an infinite list." }
-{ $see-also lnth cons car cdr } ;
-
-HELP: uncons
-{ $values { "cons" "a cons object" } { "car" "the head of the list" } { "cdr" "the tail of the list" } }
-{ $description "Put the head and tail of the list on the stack." } ;
-
-{ leach lreduce lmap lmap-with ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lreduce lwhile luntil } related-words
-
-HELP: leach
-{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj -- )" } }
-{ $description "Call the quotation for each item in the list." } ;
-
-HELP: lreduce
-{ $values { "list" "a cons object" } { "identity" "an object" } { "quot" "a quotation with stack effect ( prev elt -- next )" } { "result" "the final result" } }
-{ $description "Combines successive elements of the list using a binary operation, and outputs the final result." } ;
-
-HELP: lmap
-{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj -- X )" } { "result" "resulting cons object" } }
-{ $description "Perform a similar functionality to that of the " { $link map } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-map> } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
-
-HELP: lmap-with
-{ $values { "value" "an object" } { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj elt -- X )" } { "result" "resulting cons object" } }
-{ $description "Variant of " { $link lmap } " which pushes a retained object on each invocation of the quotation." } ;
-
-HELP: ltake
-{ $values { "n" "a non negative integer" } { "list" "a cons object" } { "result" "resulting cons object" } }
-{ $description "Outputs a lazy list containing the first n items in the list. This is done a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-take> } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
-
-HELP: lfilter
-{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( -- X )" } { "result" "resulting cons object" } }
-{ $description "Perform a similar functionality to that of the " { $link filter } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-filter> } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
-
-HELP: lwhile
-{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( X -- bool )" } { "result" "resulting cons object" } }
-{ $description "Outputs a lazy list containing the first items in the list as long as " { $snippet "quot" } " evaluates to t. No evaluation of the list elements occurs initially but a " { $link <lazy-while> } " object is returned with conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
-
-HELP: luntil
-{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( X -- bool )" } { "result" "resulting cons object" } }
-{ $description "Outputs a lazy list containing the first items in the list until after " { $snippet "quot" } " evaluates to t. No evaluation of the list elements occurs initially but a " { $link <lazy-while> } " object is returned with conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
-
-HELP: list>vector
-{ $values { "list" "a cons object" } { "vector" "the list converted to a vector" } }
-{ $description "Convert a list to a vector. If the list is a lazy infinite list then this will enter an infinite loop." }
-{ $see-also list>array } ;
-
-HELP: list>array
-{ $values { "list" "a cons object" } { "array" "the list converted to an array" } }
-{ $description "Convert a list to an array. If the list is a lazy infinite list then this will enter an infinite loop." }
-{ $see-also list>vector } ;
-
-HELP: lappend
-{ $values { "list1" "a cons object" } { "list2" "a cons object" } { "result" "a lazy list of list2 appended to list1" } }
-{ $description "Perform a similar functionality to that of the " { $link append } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-append> } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required. Successive calls to " { $link cdr } " will iterate through list1, followed by list2." } ;
-
-HELP: lfrom-by
-{ $values { "n" "an integer" } { "quot" "a quotation with stack effect ( -- int )" } { "list" "a lazy list of integers" } }
-{ $description "Return an infinite lazy list of values starting from n, with each successive value being the result of applying quot to n." } ;
-
-HELP: lfrom
-{ $values { "n" "an integer" } { "list" "a lazy list of integers" } }
-{ $description "Return an infinite lazy list of incrementing integers starting from n." } ;
-
-HELP: seq>list
-{ $values { "index" "an integer 0 or greater" } { "seq" "a sequence" } { "list" "a list" } }
-{ $description "Convert the sequence into a list, starting from the 'index' offset into the sequence." }
-{ $see-also >list } ;
-
-HELP: >list
-{ $values { "object" "an object" } { "list" "a list" } }
-{ $description "Convert the object into a list. Existing lists are passed through intact, sequences are converted using " { $link seq>list } " and other objects cause an error to be thrown." }
-{ $see-also seq>list } ;
-
-HELP: lconcat
-{ $values { "list" "a list of lists" } { "result" "a list" } }
-{ $description "Concatenates a list of lists together into one list." } ;
-
-HELP: lcartesian-product
-{ $values { "list1" "a list" } { "list2" "a list" } { "result" "list of cartesian products" } }
-{ $description "Given two lists, return a list containing the cartesian product of those lists." } ;
-
-HELP: lcartesian-product*
-{ $values { "lists" "a list of lists" } { "result" "list of cartesian products" } }
-{ $description "Given a list of lists, return a list containing the cartesian product of those lists." } ;
-
-HELP: lcomp
-{ $values { "list" "a list of lists" } { "quot" "a quotation with stack effect ( seq -- X )" } { "result" "the resulting list" } }
-{ $description "Get the cartesian product of the lists in " { $snippet "list" } " and call " { $snippet "quot" } " call with each element from the cartesian product on the stack, the result of which is returned in the final " { $snippet "list" } "." } ;
-
-HELP: lcomp*
-{ $values { "list" "a list of lists" } { "guards" "a sequence of quotations with stack effect ( seq -- bool )" } { "quot" "a quotation with stack effect ( seq -- X )" } { "list" "the resulting list" } { "result" "a list" } }
-{ $description "Get the cartesian product of the lists in " { $snippet "list" } ", filter it by applying each guard quotation to it and call " { $snippet "quot" } " call with each element from the remaining cartesian product items on the stack, the result of which is returned in the final " { $snippet "list" } "." }
-{ $examples
- { $code "{ 1 2 3 } >list { 4 5 6 } >list 2list { [ first odd? ] } [ first2 + ] lcomp*" }
-} ;
-
-HELP: lmerge
-{ $values { "list1" "a list" } { "list2" "a list" } { "result" "lazy list merging list1 and list2" } }
-{ $description "Return the result of merging the two lists in a lazy manner." }
-{ $examples
- { $example "USING: lazy-lists prettyprint ;" "{ 1 2 3 } >list { 4 5 6 } >list lmerge list>array ." "{ 1 4 2 5 3 6 }" }
-} ;
-
-HELP: lcontents
-{ $values { "stream" "a stream" } { "result" string } }
-{ $description "Returns a lazy list of all characters in the file. " { $link car } " returns the next character in the file, " { $link cdr } " returns the remaining characters as a lazy list. " { $link nil? } " indicates end of file." }
-{ $see-also llines } ;
-
-HELP: llines
-{ $values { "stream" "a stream" } { "result" "a list" } }
-{ $description "Returns a lazy list of all lines in the file. " { $link car } " returns the next lines in the file, " { $link cdr } " returns the remaining lines as a lazy list. " { $link nil? } " indicates end of file." }
-{ $see-also lcontents } ;
-
+++ /dev/null
-! Copyright (C) 2006 Matthew Willis and Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-!
-USING: lazy-lists tools.test kernel math io sequences ;
-IN: lazy-lists.tests
-
-[ { 1 2 3 4 } ] [
- { 1 2 3 4 } >list list>array
-] unit-test
-
-[ { { 1 4 } { 1 5 } { 2 4 } { 2 5 } { 3 4 } { 3 5 } } ] [
- { 1 2 3 } >list { 4 5 } >list 2list lcartesian-product* list>array
-] unit-test
-
-[ { { 1 4 } { 1 5 } { 2 4 } { 2 5 } { 3 4 } { 3 5 } } ] [
- { 1 2 3 } >list { 4 5 } >list lcartesian-product list>array
-] unit-test
-
-[ { 5 6 6 7 7 8 } ] [
- { 1 2 3 } >list { 4 5 } >list 2list [ first2 + ] lcomp list>array
-] unit-test
-
-[ { 5 6 7 8 } ] [
- { 1 2 3 } >list { 4 5 } >list 2list { [ first odd? ] } [ first2 + ] lcomp* list>array
-] unit-test
-
-[ { 4 5 6 } ] [
- 3 { 1 2 3 } >list [ + ] lmap-with list>array
-] unit-test
+++ /dev/null
-! Copyright (C) 2004 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-!
-! Updated by Matthew Willis, July 2006
-! Updated by Chris Double, September 2006
-!
-USING: kernel sequences math vectors arrays namespaces
-quotations promises combinators io ;
-IN: lazy-lists
-
-! Lazy List Protocol
-MIXIN: list
-GENERIC: car ( cons -- car )
-GENERIC: cdr ( cons -- cdr )
-GENERIC: nil? ( cons -- ? )
-
-M: promise car ( promise -- car )
- force car ;
-
-M: promise cdr ( promise -- cdr )
- force cdr ;
-
-M: promise nil? ( cons -- bool )
- force nil? ;
-
-TUPLE: cons car cdr ;
-
-C: cons cons
-
-M: cons car ( cons -- car )
- cons-car ;
-
-M: cons cdr ( cons -- cdr )
- cons-cdr ;
-
-: nil ( -- cons )
- T{ cons f f f } ;
-
-M: cons nil? ( cons -- bool )
- nil eq? ;
-
-: 1list ( obj -- cons )
- nil cons ;
-
-: 2list ( a b -- cons )
- nil cons cons ;
-
-: 3list ( a b c -- cons )
- nil cons cons cons ;
-
-! Both 'car' and 'cdr' are promises
-TUPLE: lazy-cons car cdr ;
-
-: lazy-cons ( car cdr -- promise )
- [ promise ] bi@ \ lazy-cons boa
- T{ promise f f t f } clone
- [ set-promise-value ] keep ;
-
-M: lazy-cons car ( lazy-cons -- car )
- lazy-cons-car force ;
-
-M: lazy-cons cdr ( lazy-cons -- cdr )
- lazy-cons-cdr force ;
-
-M: lazy-cons nil? ( lazy-cons -- bool )
- nil eq? ;
-
-: 1lazy-list ( a -- lazy-cons )
- [ nil ] lazy-cons ;
-
-: 2lazy-list ( a b -- lazy-cons )
- 1lazy-list 1quotation lazy-cons ;
-
-: 3lazy-list ( a b c -- lazy-cons )
- 2lazy-list 1quotation lazy-cons ;
-
-: lnth ( n list -- elt )
- swap [ cdr ] times car ;
-
-: (llength) ( list acc -- n )
- over nil? [ nip ] [ [ cdr ] dip 1+ (llength) ] if ;
-
-: llength ( list -- n )
- 0 (llength) ;
-
-: uncons ( cons -- car cdr )
- #! Return the car and cdr of the lazy list
- dup car swap cdr ;
-
-: leach ( list quot -- )
- swap dup nil? [ 2drop ] [ uncons swapd over 2slip leach ] if ; inline
-
-: lreduce ( list identity quot -- result )
- swapd leach ; inline
-
-TUPLE: memoized-cons original car cdr nil? ;
-
-: not-memoized ( -- obj )
- { } ;
-
-: not-memoized? ( obj -- bool )
- not-memoized eq? ;
-
-: <memoized-cons> ( cons -- memoized-cons )
- not-memoized not-memoized not-memoized
- memoized-cons boa ;
-
-M: memoized-cons car ( memoized-cons -- car )
- dup memoized-cons-car not-memoized? [
- dup memoized-cons-original car [ swap set-memoized-cons-car ] keep
- ] [
- memoized-cons-car
- ] if ;
-
-M: memoized-cons cdr ( memoized-cons -- cdr )
- dup memoized-cons-cdr not-memoized? [
- dup memoized-cons-original cdr [ swap set-memoized-cons-cdr ] keep
- ] [
- memoized-cons-cdr
- ] if ;
-
-M: memoized-cons nil? ( memoized-cons -- bool )
- dup memoized-cons-nil? not-memoized? [
- dup memoized-cons-original nil? [ swap set-memoized-cons-nil? ] keep
- ] [
- memoized-cons-nil?
- ] if ;
-
-TUPLE: lazy-map cons quot ;
-
-C: <lazy-map> lazy-map
-
-: lmap ( list quot -- result )
- over nil? [ 2drop nil ] [ <lazy-map> <memoized-cons> ] if ;
-
-M: lazy-map car ( lazy-map -- car )
- [ lazy-map-cons car ] keep
- lazy-map-quot call ;
-
-M: lazy-map cdr ( lazy-map -- cdr )
- [ lazy-map-cons cdr ] keep
- lazy-map-quot lmap ;
-
-M: lazy-map nil? ( lazy-map -- bool )
- lazy-map-cons nil? ;
-
-: lmap-with ( value list quot -- result )
- with lmap ;
-
-TUPLE: lazy-take n cons ;
-
-C: <lazy-take> lazy-take
-
-: ltake ( n list -- result )
- over zero? [ 2drop nil ] [ <lazy-take> ] if ;
-
-M: lazy-take car ( lazy-take -- car )
- lazy-take-cons car ;
-
-M: lazy-take cdr ( lazy-take -- cdr )
- [ lazy-take-n 1- ] keep
- lazy-take-cons cdr ltake ;
-
-M: lazy-take nil? ( lazy-take -- bool )
- dup lazy-take-n zero? [
- drop t
- ] [
- lazy-take-cons nil?
- ] if ;
-
-TUPLE: lazy-until cons quot ;
-
-C: <lazy-until> lazy-until
-
-: luntil ( list quot -- result )
- over nil? [ drop ] [ <lazy-until> ] if ;
-
-M: lazy-until car ( lazy-until -- car )
- lazy-until-cons car ;
-
-M: lazy-until cdr ( lazy-until -- cdr )
- [ lazy-until-cons uncons swap ] keep lazy-until-quot tuck call
- [ 2drop nil ] [ luntil ] if ;
-
-M: lazy-until nil? ( lazy-until -- bool )
- drop f ;
-
-TUPLE: lazy-while cons quot ;
-
-C: <lazy-while> lazy-while
-
-: lwhile ( list quot -- result )
- over nil? [ drop ] [ <lazy-while> ] if ;
-
-M: lazy-while car ( lazy-while -- car )
- lazy-while-cons car ;
-
-M: lazy-while cdr ( lazy-while -- cdr )
- [ lazy-while-cons cdr ] keep lazy-while-quot lwhile ;
-
-M: lazy-while nil? ( lazy-while -- bool )
- [ car ] keep lazy-while-quot call not ;
-
-TUPLE: lazy-filter cons quot ;
-
-C: <lazy-filter> lazy-filter
-
-: lfilter ( list quot -- result )
- over nil? [ 2drop nil ] [ <lazy-filter> <memoized-cons> ] if ;
-
-: car-filter? ( lazy-filter -- ? )
- [ lazy-filter-cons car ] keep
- lazy-filter-quot call ;
-
-: skip ( lazy-filter -- )
- [ lazy-filter-cons cdr ] keep
- set-lazy-filter-cons ;
-
-M: lazy-filter car ( lazy-filter -- car )
- dup car-filter? [ lazy-filter-cons ] [ dup skip ] if car ;
-
-M: lazy-filter cdr ( lazy-filter -- cdr )
- dup car-filter? [
- [ lazy-filter-cons cdr ] keep
- lazy-filter-quot lfilter
- ] [
- dup skip cdr
- ] if ;
-
-M: lazy-filter nil? ( lazy-filter -- bool )
- dup lazy-filter-cons nil? [
- drop t
- ] [
- dup car-filter? [
- drop f
- ] [
- dup skip nil?
- ] if
- ] if ;
-
-: list>vector ( list -- vector )
- [ [ , ] leach ] V{ } make ;
-
-: list>array ( list -- array )
- [ [ , ] leach ] { } make ;
-
-TUPLE: lazy-append list1 list2 ;
-
-C: <lazy-append> lazy-append
-
-: lappend ( list1 list2 -- result )
- over nil? [ nip ] [ <lazy-append> ] if ;
-
-M: lazy-append car ( lazy-append -- car )
- lazy-append-list1 car ;
-
-M: lazy-append cdr ( lazy-append -- cdr )
- [ lazy-append-list1 cdr ] keep
- lazy-append-list2 lappend ;
-
-M: lazy-append nil? ( lazy-append -- bool )
- drop f ;
-
-TUPLE: lazy-from-by n quot ;
-
-C: lfrom-by lazy-from-by ( n quot -- list )
-
-: lfrom ( n -- list )
- [ 1+ ] lfrom-by ;
-
-M: lazy-from-by car ( lazy-from-by -- car )
- lazy-from-by-n ;
-
-M: lazy-from-by cdr ( lazy-from-by -- cdr )
- [ lazy-from-by-n ] keep
- lazy-from-by-quot dup slip lfrom-by ;
-
-M: lazy-from-by nil? ( lazy-from-by -- bool )
- drop f ;
-
-TUPLE: lazy-zip list1 list2 ;
-
-C: <lazy-zip> lazy-zip
-
-: lzip ( list1 list2 -- lazy-zip )
- over nil? over nil? or
- [ 2drop nil ] [ <lazy-zip> ] if ;
-
-M: lazy-zip car ( lazy-zip -- car )
- [ lazy-zip-list1 car ] keep lazy-zip-list2 car 2array ;
-
-M: lazy-zip cdr ( lazy-zip -- cdr )
- [ lazy-zip-list1 cdr ] keep lazy-zip-list2 cdr lzip ;
-
-M: lazy-zip nil? ( lazy-zip -- bool )
- drop f ;
-
-TUPLE: sequence-cons index seq ;
-
-C: <sequence-cons> sequence-cons
-
-: seq>list ( index seq -- list )
- 2dup length >= [
- 2drop nil
- ] [
- <sequence-cons>
- ] if ;
-
-M: sequence-cons car ( sequence-cons -- car )
- [ sequence-cons-index ] keep
- sequence-cons-seq nth ;
-
-M: sequence-cons cdr ( sequence-cons -- cdr )
- [ sequence-cons-index 1+ ] keep
- sequence-cons-seq seq>list ;
-
-M: sequence-cons nil? ( sequence-cons -- bool )
- drop f ;
-
-: >list ( object -- list )
- {
- { [ dup sequence? ] [ 0 swap seq>list ] }
- { [ dup list? ] [ ] }
- [ "Could not convert object to a list" throw ]
- } cond ;
-
-TUPLE: lazy-concat car cdr ;
-
-C: <lazy-concat> lazy-concat
-
-DEFER: lconcat
-
-: (lconcat) ( car cdr -- list )
- over nil? [
- nip lconcat
- ] [
- <lazy-concat>
- ] if ;
-
-: lconcat ( list -- result )
- dup nil? [
- drop nil
- ] [
- uncons (lconcat)
- ] if ;
-
-M: lazy-concat car ( lazy-concat -- car )
- lazy-concat-car car ;
-
-M: lazy-concat cdr ( lazy-concat -- cdr )
- [ lazy-concat-car cdr ] keep lazy-concat-cdr (lconcat) ;
-
-M: lazy-concat nil? ( lazy-concat -- bool )
- dup lazy-concat-car nil? [
- lazy-concat-cdr nil?
- ] [
- drop f
- ] if ;
-
-: lcartesian-product ( list1 list2 -- result )
- swap [ swap [ 2array ] lmap-with ] lmap-with lconcat ;
-
-: lcartesian-product* ( lists -- result )
- dup nil? [
- drop nil
- ] [
- [ car ] keep cdr [ car lcartesian-product ] keep cdr list>array swap [
- swap [ swap [ suffix ] lmap-with ] lmap-with lconcat
- ] reduce
- ] if ;
-
-: lcomp ( list quot -- result )
- [ lcartesian-product* ] dip lmap ;
-
-: lcomp* ( list guards quot -- result )
- [ [ lcartesian-product* ] dip [ lfilter ] each ] dip lmap ;
-
-DEFER: lmerge
-
-: (lmerge) ( list1 list2 -- result )
- over [ car ] curry -rot
- [
- dup [ car ] curry -rot
- [
- [ cdr ] bi@ lmerge
- ] 2curry lazy-cons
- ] 2curry lazy-cons ;
-
-: lmerge ( list1 list2 -- result )
- {
- { [ over nil? ] [ nip ] }
- { [ dup nil? ] [ drop ] }
- { [ t ] [ (lmerge) ] }
- } cond ;
-
-TUPLE: lazy-io stream car cdr quot ;
-
-C: <lazy-io> lazy-io
-
-: lcontents ( stream -- result )
- f f [ stream-read1 ] <lazy-io> ;
-
-: llines ( stream -- result )
- f f [ stream-readln ] <lazy-io> ;
-
-M: lazy-io car ( lazy-io -- car )
- dup lazy-io-car dup [
- nip
- ] [
- drop dup lazy-io-stream over lazy-io-quot call
- swap dupd set-lazy-io-car
- ] if ;
-
-M: lazy-io cdr ( lazy-io -- cdr )
- dup lazy-io-cdr dup [
- nip
- ] [
- drop dup
- [ lazy-io-stream ] keep
- [ lazy-io-quot ] keep
- car [
- [ f f ] dip <lazy-io> [ swap set-lazy-io-cdr ] keep
- ] [
- 3drop nil
- ] if
- ] if ;
-
-M: lazy-io nil? ( lazy-io -- bool )
- car not ;
-
-INSTANCE: cons list
-INSTANCE: sequence-cons list
-INSTANCE: memoized-cons list
-INSTANCE: promise list
-INSTANCE: lazy-io list
-INSTANCE: lazy-concat list
-INSTANCE: lazy-cons list
-INSTANCE: lazy-map list
-INSTANCE: lazy-take list
-INSTANCE: lazy-append list
-INSTANCE: lazy-from-by list
-INSTANCE: lazy-zip list
-INSTANCE: lazy-while list
-INSTANCE: lazy-until list
-INSTANCE: lazy-filter list
+++ /dev/null
-<html>
- <head>
- <title>Lazy Evaluation</title>
- <link rel="stylesheet" type="text/css" href="style.css">
- </head>
- <body>
- <h1>Lazy Evaluation</h1>
-<p>The 'lazy' vocabulary adds lazy lists to Factor. This provides the
- ability to describe infinite structures, and to delay execution of
- expressions until they are actually used.</p>
-<p>Lazy lists, like normal lists, are composed of a head and tail. In
- a lazy list the head and tail are something called a 'promise'.
- To convert a
- 'promise' into its actual value a word called 'force' is used. To
- convert a value into a 'promise' the word to use is 'delay'.</p>
-<table border="1">
-<tr><td><a href="#delay">delay</a></td></tr>
-<tr><td><a href="#force">force</a></td></tr>
-</table>
-
-<p>Many of the lazy list words are named similar to the standard list
- words but with an 'l' suffixed to it. Here are the commonly used
- words and their equivalent list operation:</p>
-<table border="1">
-<tr><th>Lazy List</th><th>Normal List</th></tr>
-<tr><td><a href="#lnil">lnil</a></td><td>[ ]</td></tr>
-<tr><td><a href="#lnilp">lnil?</a></td><td>Test for nil value</td></tr>
-<tr><td><a href="#lcons">lcons</a></td><td>cons</td></tr>
-<tr><td><a href="#lunit">lunit</a></td><td>unit</td></tr>
-<tr><td><a href="#lcar">lcar</a></td><td>car</td></tr>
-<tr><td><a href="#lcdr">lcdr</a></td><td>cdr</td></tr>
-<tr><td><a href="#lnth">lnth</a></td><td>nth</td></tr>
-<tr><td><a href="#luncons">luncons</a></td><td>uncons</td></tr>
-<tr><td><a href="#lmap">lmap</a></td><td>map</td></tr>
-<tr><td><a href="#lsubset">lsubset</a></td><td>subset</td></tr>
-<tr><td><a href="#leach">leach</a></td><td>each</td></tr>
-<tr><td><a href="#lappend">lappend</a></td><td>append</td></tr>
-</table>
-<p>A few additional words specific to lazy lists are:</p>
-<table border="1">
-<tr><td><a href="#ltake">ltake</a></td><td>Returns a normal list containing a specified
-number of items from the lazy list.</td></tr>
-<tr><td><a href="#lappendstar">lappend*</a></td><td>Given a lazy list of lazy lists,
-concatenate them together in a lazy manner, returning a single lazy
-list.</td></tr>
-<tr><td><a href="#list>llist">list>llist</a></td><td>Given a normal list, return a lazy list
-that contains the same elements as the normal list.</td></tr>
-</table>
-<h2>Reference</h2>
-<!-- delay description -->
-<a name="delay">
-<h3>delay ( quot -- <promise> )</h3>
-<p>'delay' is used to convert a value or expression into a promise.
- The word 'force' is used to convert that promise back to its
- value, or to force evaluation of the expression to return a value.
-</p>
-<p>The value on the stack that 'delay' expects must be quoted. This is
- a requirement to prevent it from being evaluated.
-</p>
-<pre class="code">
- ( 1 ) [ 42 ] <a href="#delay">delay</a> dup .
- => << promise [ ] [ 42 ] [ ] [ ] >>
- ( 2 ) <a href="#force">force</a> .
- => 42
-</pre>
-
-<!-- force description -->
-<a name="force">
-<h3>force ( <promise> -- value )</h3>
-<p>'force' will evaluate a promises original expression
- and leave the value of that expression on the stack.
-</p>
-<p>A promise can be forced multiple times but the expression
- is only evaluated once. Future calls of 'force' on the promise
- will returned the cached value of the original force. If the
- expression contains side effects, such as i/o, then that i/o
- will only occur on the first 'force'. See below for an example
- (steps 3-5).
-</p>
-<p>If a promise is itself delayed, a force will evaluate all promises
- until a value is returned. Due to this behaviour it is generally not
- possible to delay a promise. The example below shows what happens
- in this case.
-</p>
-<pre class="code">
- ( 1 ) [ 42 ] <a href="#delay">delay</a> dup .
- => << promise [ ] [ 42 ] [ ] [ ] >>
- ( 2 ) <a href="#force">force</a> .
- => 42
-
- #! Multiple forces on a promise returns cached value
- ( 3 ) [ "hello" print 42 ] <a href="#delay">delay</a> dup .
- => << promise [ ] [ "hello" print 42 ] [ ] [ ] >>
- ( 4 ) dup <a href="#force">force</a> .
- => hello
- 42
- ( 5 ) <a href="#force">force</a> .
- => 42
-
- #! Forcing a delayed promise cascades up to return
- #! original value, rather than the promise.
- ( 6 ) [ [ 42 ] <a href="#delay">delay</a> ] <a href="#delay">delay</a> dup .
- => << promise [ ] [ [ 42 ] delay ] [ ] [ ] >>
- ( 7 ) <a href="#force">force</a> .
- => 42
-</pre>
-
-<!-- lnil description -->
-<a name="lnil">
-<h3>lnil ( -- lcons )</h3>
-<p>Returns a value representing the empty lazy list.</p>
-<pre class="code">
- ( 1 ) <a href="#lnil">lnil</a> .
- => << promise [ ] [ [ ] ] t [ ] >>
-</pre>
-
-<!-- lnil description -->
-<a name="lnilp">
-<h3>lnil? ( lcons -- bool )</h3>
-<p>Returns true if the given lazy cons is the value representing
- the empty lazy list.</p>
-<pre class="code">
- ( 1 ) <a href="#lnil">lnil</a> <a href="#lnilp">lnil?</a> .
- => t
- ( 2 ) [ 1 ] <a href="#list2llist">list>llist</a> dup <a href="#lnilp">lnil?</a> .
- => [ ]
- ( 3 ) <a href="#lcdr">lcdr</a> <a href="#lnilp">lnil?</a> .
- => t
-</pre>
-
-<!-- lcons description -->
-<a name="lcons">
-<h3>lcons ( car-promise cdr-promise -- lcons )</h3>
-<p>Provides the same effect as 'cons' does for normal lists.
- Both values provided must be promises (ie. expressions that have
- had <a href="#delay">delay</a> called on them).
-</p>
-<p>As the car and cdr passed on the stack are promises, they are not
- evaluated until <a href="#lcar">lcar</a> or <a href="#lcdr">lcdr</a>
- are called on the lazy cons.</p>
-<pre class="code">
- ( 1 ) [ "car" ] <a href="#delay">delay</a> [ "cdr" ] <a href="#delay">delay</a> <a href="#lcons">lcons</a> dup .
- => << promise ... >>
- ( 2 ) dup <a href="#lcar">lcar</a> .
- => "car"
- ( 3 ) dup <a href="#lcdr">lcdr</a> .
- => "cdr"
-</pre>
-
-<!-- lunit description -->
-<a name="lunit">
-<h3>lunit ( value-promise -- llist )</h3>
-<p>Provides the same effect as 'unit' does for normal lists. It
-creates a lazy list where the first element is the value given.</p>
-<p>Like <a href="#lcons">lcons</a>, the value on the stack must be
- a promise and is not evaluated until the <a href="#lcar">lcar</a>
- of the list is requested.</a>
-<pre class="code">
- ( 1 ) [ 42 ] <a href="#delay">delay</a> <a href="#lunit">lunit</a> dup .
- => << promise ... >>
- ( 2 ) dup <a href="#lcar">lcar</a> .
- => 42
- ( 3 ) dup <a href="#lcdr">lcdr</a> <a href="#lnilp">lnil?</a> .
- => t
- ( 4 ) [ . ] <a href="#leach">leach</a>
- => 42
-</pre>
-
-<!-- lcar description -->
-<a name="lcar">
-<h3>lcar ( lcons -- value )</h3>
-<p>Provides the same effect as 'car' does for normal lists. It
-returns the first element in a lazy cons cell. This will force
-the evaluation of that element.</p>
-<pre class="code">
- ( 1 ) [ 42 ] <a href="#delay">delay</a> <a href="#lunit">lunit</a> dup .
- => << promise ... >>
- ( 2 ) <a href="#lcar">lcar</a> .
- => 42
-</pre>
-
-<!-- lcdr description -->
-<a name="lcdr">
-<h3>lcdr ( lcons -- value )</h3>
-<p>Provides the same effect as 'cdr' does for normal lists. It
-returns the second element in a lazy cons cell and forces it. This
-causes that element to be evaluated immediately.</p>
-<pre class="code">
- ( 1 ) [ 1 ] <a href="#delay">delay</a> [ 5 6 + ] <a href="#delay">delay</a> <a href="#lcons">lcons</a> dup .
- => << promise ... >>
- ( 2 ) <a href="#lcdr">lcdr</a> .
- => 11
-</pre>
-
-<pre class="code">
- ( 1 ) 5 <a href="#lfrom">lfrom</a> dup .
- => << promise ... >>
- ( 2 ) <a href="#lcdr">lcdr</a> dup <a href="#lcar">lcar</a> .
- => 6
- ( 3 ) <a href="#lcdr">lcdr</a> dup <a href="#lcar">lcar</a> .
- => 7
- ( 4 ) <a href="#lcdr">lcdr</a> dup <a href="#lcar">lcar</a> .
- => 8
-</pre>
-
-<!-- lnth description -->
-<a name="lnth">
-<h3>lnth ( n llist -- value )</h3>
-<p>Provides the same effect as 'nth' does for normal lists. It
-returns the nth value in the lazy list. It causes all the values up to
-'n' to be evaluated.</p>
-<pre class="code">
- ( 1 ) 1 <a href="#lfrom">lfrom</a> dup .
- => << promise ... >>
- ( 2 ) 5 swap <a href="#lnth">lnth</a> .
- => 6
-</pre>
-
-<!-- luncons description -->
-<a name="luncons">
-<h3>luncons ( lcons -- car cdr )</h3>
-<p>Provides the same effect as 'uncons' does for normal lists. It
-returns the car and cdr of the lazy list.</p>
-<pre class="code">
- ( 1 ) [ 5 ] <a href="#delay">delay</a> [ 6 ] <a href="#delay">delay</a> <a href="#lcons">lcons</a> dup .
- => << promise ... >>
- ( 2 ) <a href="#luncons">luncons</a> . .
- => 6
- 5
-</pre>
-
-<!-- lmap description -->
-<a name="lmap">
-<h3>lmap ( llist quot -- llist )</h3>
-<p>Lazily maps over a lazy list applying the quotation to each element.
-A new lazy list is returned which contains the results of the
-quotation.</p>
-<p>When intially called nothing in the original lazy list is
-evaluated. Only when <a href="#lcar">lcar</a> is called will the item
-in the list be evaluated and applied to the quotation. Ditto with <a
-href="#lcdr">lcdr</a>, thus allowing infinite lists to be mapped over.</p>
-<pre class="code">
- ( 1 ) 1 <a href="#lfrom">lfrom</a>
- => < infinite list of incrementing numbers >
- ( 2 ) [ 2 * ] <a href="#lmap">lmap</a>
- => < infinite list of numbers incrementing by 2 >
- ( 3 ) 5 swap <a href="#ltake">ltake</a> <a href="#llist2list">llist>list</a> .
- => [ 2 4 6 8 10 ]
-</pre>
-
-<!-- lsubset description -->
-<a name="lsubset">
-<h3>lsubset ( llist pred -- llist )</h3>
-<p>Provides the same effect as 'subset' does for normal lists. It
-lazily iterates over a lazy list applying the predicate quotation to each
-element. If that quotation returns true, the element will be included
-in the resulting lazy list. If it is false, the element will be skipped.
-A new lazy list is returned which contains all elements where the
-predicate returned true.</p>
-<p>Like <a href="#lmap">lmap</a>, when initially called no evaluation
-will occur. A lazy list is returned that when values are retrieved
-from in then items are evaluated and checked against the predicate.</p>
-<pre class="code">
- ( 1 ) 1 <a href="#lfrom">lfrom</a>
- => < infinite list of incrementing numbers >
- ( 2 ) [ <a href="#primep">prime?</a> ] <a href="#lsubset">lsubset</a>
- => < infinite list of prime numbers >
- ( 3 ) 5 swap <a href="#ltake">ltake</a> <a href="#llist2list">llist>list</a> .
- => [ 2 3 5 7 11 ]
-</pre>
-
-<!-- leach description -->
-<a name="leach">
-<h3>leach ( llist quot -- )</h3>
-<p>Provides the same effect as 'each' does for normal lists. It
-lazily iterates over a lazy list applying the quotation to each
-element. If this operation is applied to an infinite list it will
-never return unless the quotation escapes out by calling a continuation.</p>
-<pre class="code">
- ( 1 ) 1 <a href="#lfrom">lfrom</a>
- => < infinite list of incrementing numbers >
- ( 2 ) [ 2 mod 1 = ] <a href="#lsubset">lsubset</a>
- => < infinite list of odd numbers >
- ( 3 ) [ . ] <a href="#leach">leach</a>
- => 1
- 3
- 5
- 7
- ... for ever ...
-</pre>
-
-<!-- ltake description -->
-<a name="ltake">
-<h3>ltake ( n llist -- llist )</h3>
-<p>Iterates over the lazy list 'n' times, appending each element to a
-lazy list. This provides a convenient way of getting elements out of
-an infinite lazy list.</p>
-<pre class="code">
- ( 1 ) : ones [ 1 ] delay [ ones ] delay <a href="#lcons">lcons</a> ;
- ( 2 ) 5 ones <a href="#ltake">ltake</a> <a href="#llist2list">llist>list</a> .
- => [ 1 1 1 1 1 ]
-</pre>
-
-<!-- lappend description -->
-<a name="lappend">
-<h3>lappend ( llist1 llist2 -- llist )</h3>
-<p>Lazily appends two lists together. The actual appending is done
-lazily on iteration rather than immediately so it works very fast no
-matter how large the list.</p>
-<pre class="code">
- ( 1 ) [ 1 2 3 ] <a href="#list2llist">list>llist</a> [ 4 5 6 ] <a href="#list2llist">list>llist</a> <a href="#lappend">lappend</a>
- ( 2 ) [ . ] <a href="#leach">leach</a>
- => 1
- 2
- 3
- 4
- 5
- 6
-</pre>
-
-<!-- lappend* description -->
-<a name="lappendstar">
-<h3>lappend* ( llists -- llist )</h3>
-<p>Given a lazy list of lazy lists, concatenate them together in a
-lazy fashion. The actual appending is done lazily on iteration rather
-than immediately so it works very fast no matter how large the lists.</p>
-<pre class="code">
- ( 1 ) [ 1 2 3 ] <a href="#list2>llist">list>llist</a>
- ( 2 ) [ 4 5 6 ] <a href="#list2llist">list>llist</a>
- ( 3 ) [ 7 8 9 ] <a href="#list2llist">list>llist</a>
- ( 4 ) 3list <a href="#list2llist">list>llist</a> <a href="#lappendstar">lappend*</a>
- ( 5 ) [ . ] <a href="#leach">leach</a>
- => 1
- 2
- 3
- 4
- 5
- 6
- 7
- 8
- 9
-</pre>
-
-<!-- list>llist description -->
-<a name="list2llist">
-<h3>list>llist ( list -- llist )</h3>
-<p>Converts a normal list into a lazy list. This is done lazily so the
-initial list is not iterated through immediately.</p>
-<pre class="code">
- ( 1 ) [ 1 2 3 ] <a href="#list2llist">list>llist</a>
- ( 2 ) [ . ] <a href="#leach">leach</a>
- => 1
- 2
- 3
-</pre>
-
-<p class="footer">
-News and updates to this software can be obtained from the authors
-weblog: <a href="http://radio.weblogs.com/0102385">Chris Double</a>.</p>
-<p id="copyright">Copyright (c) 2004, Chris Double. All Rights Reserved.</p>
-</body> </html>
+++ /dev/null
-Lazy lists
+++ /dev/null
-extensions
-collections
--- /dev/null
+! Copyright (C) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: lcs html.elements kernel qualified ;
+FROM: accessors => item>> ;
+FROM: io => write ;
+FROM: sequences => each empty? ;
+FROM: xml.entities => escape-string ;
+IN: lcs.diff2html
+
+GENERIC: diff-line ( obj -- )
+
+: write-item ( item -- )
+ item>> dup empty? [ drop " " ] [ escape-string ] if write ;
+
+M: retain diff-line
+ <tr>
+ dup [
+ <td "retain" =class td>
+ write-item
+ </td>
+ ] bi@
+ </tr> ;
+
+M: insert diff-line
+ <tr>
+ <td> </td>
+ <td "insert" =class td>
+ write-item
+ </td>
+ </tr> ;
+
+M: delete diff-line
+ <tr>
+ <td "delete" =class td>
+ write-item
+ </td>
+ <td> </td>
+ </tr> ;
+
+: htmlize-diff ( diff -- )
+ <table "comparison" =class table>
+ <tr> <th> "Old" write </th> <th> "New" write </th> </tr>
+ [ diff-line ] each
+ </table> ;
! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license.
-USING: lisp lisp.parser tools.test sequences math kernel parser ;
+USING: lisp lisp.parser tools.test sequences math kernel parser arrays ;
IN: lisp.test
[
init-env
- "#f" [ f ] lisp-define
+ "#f" [ f ] lisp-define
"#t" [ t ] lisp-define
- "+" "math" "+" define-primitve
- "-" "math" "-" define-primitve
+ "+" "math" "+" define-primitive
+ "-" "math" "-" define-primitive
+
+ "list" [ >array ] lisp-define
{ 5 } [
[ 2 3 ] "+" <lisp-symbol> funcall
] unit-test
{ 3 } [
- "((lambda (x y) (+ x y)) 1 2)" lisp-string>factor call
+ "((lambda (x y) (+ x y)) 1 2)" lisp-eval
] unit-test
{ 42 } [
- "((lambda (x y z) (+ x (- y z))) 40 3 1)" lisp-string>factor call
+ "((lambda (x y z) (+ x (- y z))) 40 3 1)" lisp-eval
] unit-test
{ 1 } [
- "(if #t 1 2)" lisp-string>factor call
+ "(if #t 1 2)" lisp-eval
] unit-test
{ "b" } [
- "(cond (#f \"a\") (#t \"b\"))" lisp-string>factor call
+ "(cond (#f \"a\") (#t \"b\"))" lisp-eval
] unit-test
{ 5 } [
- "(begin (+ 1 4))" lisp-string>factor call
+ "(begin (+ 1 4))" lisp-eval
] unit-test
{ 3 } [
- "((lambda (x) (if x (begin (+ 1 2)) (- 3 5))) #t)" lisp-string>factor call
+ "((lambda (x) (if x (begin (+ 1 2)) (- 3 5))) #t)" lisp-eval
+ ] unit-test
+
+ { { 1 2 3 4 5 } } [
+ "(list 1 2 3 4 5)" lisp-eval
] unit-test
-] with-interactive-vocabs
\ No newline at end of file
+
+] with-interactive-vocabs
! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license.
USING: kernel peg sequences arrays strings combinators.lib
-namespaces combinators math bake locals locals.private accessors
-vectors syntax lisp.parser assocs parser sequences.lib words quotations ;
+namespaces combinators math locals locals.private accessors
+vectors syntax lisp.parser assocs parser sequences.lib words quotations
+fry lists ;
IN: lisp
DEFER: convert-form
DEFER: funcall
DEFER: lookup-var
+DEFER: lisp-macro?
+DEFER: lookup-macro
+DEFER: macro-call
! Functions to convert s-exps to quotations
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: convert-body ( s-exp -- quot )
- [ convert-form ] map [ ] [ compose ] reduce ; inline
-
-: convert-if ( s-exp -- quot )
- rest [ convert-form ] map reverse first3 [ % , , if ] bake ;
-
-: convert-begin ( s-exp -- quot )
- rest [ convert-form ] map >quotation [ , [ funcall ] each ] bake ;
-
-: convert-cond ( s-exp -- quot )
- rest [ body>> >array [ convert-form ] map first2 swap `{ [ % funcall ] , } bake ]
- map >array [ , cond ] bake ;
-
-: convert-general-form ( s-exp -- quot )
- unclip convert-form swap convert-body [ , % funcall ] bake ;
+: convert-body ( cons -- quot )
+ [ ] [ convert-form compose ] reduce-cons ; inline
+
+: convert-if ( cons -- quot )
+ cdr first3 [ convert-form ] tri@ '[ @ , , if ] ;
+
+: convert-begin ( cons -- quot )
+ cdr [ convert-form ] [ ] map-as '[ , [ funcall ] each ] ;
+
+: convert-cond ( cons -- quot )
+ cdr [ body>> first2 [ convert-form ] bi@ [ '[ @ funcall ] ] dip 2array ]
+ { } map-as '[ , cond ] ;
+
+: convert-general-form ( cons -- quot )
+ uncons convert-form swap convert-body swap '[ , @ funcall ] ;
! words for convert-lambda
<PRIVATE
: localize-body ( assoc body -- assoc newbody )
- [ dup lisp-symbol? [ over dupd [ name>> ] dip at swap or ]
- [ dup s-exp? [ body>> localize-body <s-exp> ] when ] if
- ] map ;
-
+ [ dup lisp-symbol? [ over dupd [ name>> ] dip at swap or ]
+ [ dup cons? [ localize-body ] when ] if
+ ] map-cons ;
+
: localize-lambda ( body vars -- newbody newvars )
- make-locals dup push-locals swap
- [ swap localize-body <s-exp> convert-form swap pop-locals ] dip swap ;
+ make-locals dup push-locals swap
+ [ swap localize-body cons convert-form swap pop-locals ] dip swap ;
-: split-lambda ( s-exp -- body vars )
- first3 -rot nip [ body>> ] bi@ [ name>> ] map ; inline
-
+: split-lambda ( cons -- body vars )
+ first3 -rot nip [ body>> ] bi@ [ name>> ] map ; inline
+
: rest-lambda ( body vars -- quot )
- "&rest" swap [ remove ] [ index ] 2bi
- [ localize-lambda <lambda> ] dip
- [ , cut swap [ % , ] bake , compose ] bake ;
-
+ "&rest" swap [ index ] [ remove ] 2bi
+ localize-lambda <lambda>
+ '[ , cut '[ @ , ] , compose ] ;
+
: normal-lambda ( body vars -- quot )
- localize-lambda <lambda> [ , compose ] bake ;
+ localize-lambda <lambda> '[ , compose ] ;
PRIVATE>
-
-: convert-lambda ( s-exp -- quot )
- split-lambda dup "&rest" swap member? [ rest-lambda ] [ normal-lambda ] if ;
-
-: convert-quoted ( s-exp -- quot )
- second [ , ] bake ;
-
-: convert-list-form ( s-exp -- quot )
- dup first dup lisp-symbol?
- [ name>>
- { { "lambda" [ convert-lambda ] }
- { "quote" [ convert-quoted ] }
- { "if" [ convert-if ] }
- { "begin" [ convert-begin ] }
- { "cond" [ convert-cond ] }
- [ drop convert-general-form ]
- } case ]
- [ drop convert-general-form ] if ;
-
+
+: convert-lambda ( cons -- quot )
+ split-lambda "&rest" over member? [ rest-lambda ] [ normal-lambda ] if ;
+
+: convert-quoted ( cons -- quot )
+ cdr 1quotation ;
+
+: form-dispatch ( lisp-symbol -- quot )
+ name>>
+ { { "lambda" [ convert-lambda ] }
+ { "quote" [ convert-quoted ] }
+ { "if" [ convert-if ] }
+ { "begin" [ convert-begin ] }
+ { "cond" [ convert-cond ] }
+ [ drop convert-general-form ]
+ } case ;
+
+: macro-expand ( cons -- quot )
+ uncons lookup-macro macro-call convert-form ;
+
+: convert-list-form ( cons -- quot )
+ dup car
+ { { [ dup lisp-macro? ] [ macro-expand ] }
+ { [ dup lisp-symbol? ] [ form-dispatch ] }
+ [ drop convert-general-form ]
+ } cond ;
+
: convert-form ( lisp-form -- quot )
- { { [ dup s-exp? ] [ body>> convert-list-form ] }
- { [ dup lisp-symbol? ] [ [ , lookup-var ] bake ] }
- [ [ , ] bake ]
- } cond ;
-
+ {
+ { [ dup cons? ] [ convert-list-form ] }
+ { [ dup lisp-symbol? ] [ '[ , lookup-var ] ] }
+ [ 1quotation ]
+ } cond ;
+
: lisp-string>factor ( str -- quot )
- lisp-expr parse-result-ast convert-form lambda-rewrite call ;
-
+ lisp-expr parse-result-ast convert-form lambda-rewrite call ;
+
+: lisp-eval ( str -- * )
+ lisp-string>factor call ;
+
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: lisp-env
ERROR: no-such-var var ;
: init-env ( -- )
- H{ } clone lisp-env set ;
+ H{ } clone lisp-env set ;
: lisp-define ( name quot -- )
- swap lisp-env get set-at ;
-
+ swap lisp-env get set-at ;
+
: lisp-get ( name -- word )
- dup lisp-env get at [ ] [ no-such-var throw ] ?if ;
-
+ dup lisp-env get at [ ] [ no-such-var throw ] ?if ;
+
: lookup-var ( lisp-symbol -- quot )
- name>> lisp-get ;
-
+ name>> lisp-get ;
+
: funcall ( quot sym -- * )
- dup lisp-symbol? [ lookup-var ] when call ; inline
-
-: define-primitve ( name vocab word -- )
- swap lookup [ [ , ] compose call ] bake lisp-define ;
\ No newline at end of file
+ dup lisp-symbol? [ lookup-var ] when call ; inline
+
+: define-primitive ( name vocab word -- )
+ swap lookup 1quotation '[ , compose call ] lisp-define ;
\ No newline at end of file
! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license.
-USING: lisp.parser tools.test peg peg.ebnf ;
+USING: lisp.parser tools.test peg peg.ebnf lists ;
IN: lisp.parser.tests
] unit-test
{ -42 } [
- "-42" "atom" \ lisp-expr rule parse parse-result-ast
+ "-42" "atom" \ lisp-expr rule parse parse-result-ast
] unit-test
{ 37/52 } [
- "37/52" "atom" \ lisp-expr rule parse parse-result-ast
+ "37/52" "atom" \ lisp-expr rule parse parse-result-ast
] unit-test
{ 123.98 } [
- "123.98" "atom" \ lisp-expr rule parse parse-result-ast
+ "123.98" "atom" \ lisp-expr rule parse parse-result-ast
] unit-test
{ "" } [
- "\"\"" "atom" \ lisp-expr rule parse parse-result-ast
+ "\"\"" "atom" \ lisp-expr rule parse parse-result-ast
] unit-test
{ "aoeu" } [
- "\"aoeu\"" "atom" \ lisp-expr rule parse parse-result-ast
+ "\"aoeu\"" "atom" \ lisp-expr rule parse parse-result-ast
] unit-test
{ "aoeu\"de" } [
- "\"aoeu\\\"de\"" "atom" \ lisp-expr rule parse parse-result-ast
+ "\"aoeu\\\"de\"" "atom" \ lisp-expr rule parse parse-result-ast
] unit-test
{ T{ lisp-symbol f "foobar" } } [
- "foobar" "atom" \ lisp-expr rule parse parse-result-ast
+ "foobar" "atom" \ lisp-expr rule parse parse-result-ast
] unit-test
{ T{ lisp-symbol f "+" } } [
- "+" "atom" \ lisp-expr rule parse parse-result-ast
+ "+" "atom" \ lisp-expr rule parse parse-result-ast
] unit-test
-{ T{ s-exp f
- V{ T{ lisp-symbol f "foo" } 1 2 "aoeu" } } } [
- "(foo 1 2 \"aoeu\")" lisp-expr parse-result-ast
+{ T{ cons f f f }
+} [
+ "()" lisp-expr parse-result-ast
+] unit-test
+
+{ T{
+ cons
+ f
+ T{ lisp-symbol f "foo" }
+ T{
+ cons
+ f
+ 1
+ T{ cons f 2 T{ cons f "aoeu" T{ cons f f f } } }
+ } } } [
+ "(foo 1 2 \"aoeu\")" lisp-expr parse-result-ast
+] unit-test
+
+{ T{ cons f
+ 1
+ T{ cons f
+ T{ cons f 3 T{ cons f 4 T{ cons f f f } } }
+ T{ cons f 2 T{ cons f f } } }
+ }
+} [
+ "(1 (3 4) 2)" lisp-expr parse-result-ast
] unit-test
\ No newline at end of file
! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel peg.ebnf peg.expr math.parser sequences arrays strings
-combinators.lib math ;
+USING: kernel peg peg.ebnf peg.expr math.parser sequences arrays strings
+combinators.lib math fry accessors lists ;
IN: lisp.parser
TUPLE: lisp-symbol name ;
C: <lisp-symbol> lisp-symbol
-TUPLE: s-exp body ;
-C: <s-exp> s-exp
-
EBNF: lisp-expr
_ = (" " | "\t" | "\n")*
LPAREN = "("
number = float
| rational
| integer
-id-specials = "!" | "$" | "%" | "&" | "*" | "/" | ":" | "<" | "#"
- | " =" | ">" | "?" | "^" | "_" | "~" | "+" | "-" | "." | "@"
+id-specials = "!" | "$" | "%" | "&" | "*" | "/" | ":"
+ | "<" | "#" | " =" | ">" | "?" | "^" | "_"
+ | "~" | "+" | "-" | "." | "@"
letters = [a-zA-Z] => [[ 1array >string ]]
initials = letters | id-specials
numbers = [0-9] => [[ 1array >string ]]
atom = number
| identifier
| string
-list-item = _ (atom|s-expression) _ => [[ second ]]
-s-expression = LPAREN (list-item)* RPAREN => [[ second <s-exp> ]]
+list-item = _ ( atom | s-expression ) _ => [[ second ]]
+s-expression = LPAREN (list-item)* RPAREN => [[ second seq>cons ]]
;EBNF
\ No newline at end of file
--- /dev/null
+James Cash
--- /dev/null
+Chris Double
+Samuel Tardieu
+Matthew Willis
--- /dev/null
+Chris Double
--- /dev/null
+USING: lazy-lists.examples lazy-lists tools.test ;
+IN: lazy-lists.examples.tests
+
+[ { 1 3 5 7 } ] [ 4 odds ltake list>array ] unit-test
+[ { 0 1 4 9 16 } ] [ first-five-squares ] unit-test
--- /dev/null
+! Rewritten by Matthew Willis, July 2006
+! Copyright (C) 2004 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: lazy-lists math kernel sequences quotations ;
+IN: lazy-lists.examples
+
+: naturals 0 lfrom ;
+: positives 1 lfrom ;
+: evens 0 [ 2 + ] lfrom-by ;
+: odds 1 lfrom [ 2 mod 1 = ] lfilter ;
+: powers-of-2 1 [ 2 * ] lfrom-by ;
+: ones 1 [ ] lfrom-by ;
+: squares naturals [ dup * ] lmap ;
+: first-five-squares 5 squares ltake list>array ;
--- /dev/null
+! Copyright (C) 2006 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: help.markup help.syntax sequences strings lists ;
+IN: lists.lazy
+
+HELP: lazy-cons
+{ $values { "car" "a quotation with stack effect ( -- X )" } { "cdr" "a quotation with stack effect ( -- cons )" } { "promise" "the resulting cons object" } }
+{ $description "Constructs a cons object for a lazy list from two quotations. The " { $snippet "car" } " quotation should return the head of the list, and the " { $snippet "cons" } " quotation the tail when called. When " { $link cons } " or " { $link cdr } " are called on the lazy-cons object then the appropriate quotation is called." }
+{ $see-also cons car cdr nil nil? } ;
+
+{ 1lazy-list 2lazy-list 3lazy-list } related-words
+
+HELP: 1lazy-list
+{ $values { "a" "a quotation with stack effect ( -- X )" } { "lazy-cons" "a lazy-cons object" } }
+{ $description "Create a lazy list with 1 element. The element is the result of calling the quotation. The quotation is only called when the list element is requested." } ;
+
+HELP: 2lazy-list
+{ $values { "a" "a quotation with stack effect ( -- X )" } { "b" "a quotation with stack effect ( -- X )" } { "lazy-cons" "a lazy-cons object" } }
+{ $description "Create a lazy list with 2 elements. The elements are the result of calling the quotations. The quotations are only called when the list elements are requested." } ;
+
+HELP: 3lazy-list
+{ $values { "a" "a quotation with stack effect ( -- X )" } { "b" "a quotation with stack effect ( -- X )" } { "c" "a quotation with stack effect ( -- X )" } { "lazy-cons" "a lazy-cons object" } }
+{ $description "Create a lazy list with 3 elements. The elements are the result of calling the quotations. The quotations are only called when the list elements are requested." } ;
+
+HELP: <memoized-cons>
+{ $values { "cons" "a cons object" } { "memoized-cons" "the resulting memoized-cons object" } }
+{ $description "Constructs a cons object that wraps an existing cons object. Requests for the car, cdr and nil? will be remembered after the first call, and the previous result returned on subsequent calls." }
+{ $see-also cons car cdr nil nil? } ;
+
+HELP: lnth
+{ $values { "n" "an integer index" } { "list" "a cons object" } { "elt" "the element at the nth index" } }
+{ $description "Outputs the nth element of the list." }
+{ $see-also llength cons car cdr } ;
+
+HELP: llength
+{ $values { "list" "a cons object" } { "n" "a non-negative integer" } }
+{ $description "Outputs the length of the list. This should not be called on an infinite list." }
+{ $see-also lnth cons car cdr } ;
+
+HELP: uncons
+{ $values { "cons" "a cons object" } { "car" "the head of the list" } { "cdr" "the tail of the list" } }
+{ $description "Put the head and tail of the list on the stack." } ;
+
+{ leach lreduce lmap lmap-with ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lreduce lwhile luntil } related-words
+
+HELP: leach
+{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj -- )" } }
+{ $description "Call the quotation for each item in the list." } ;
+
+HELP: lreduce
+{ $values { "list" "a cons object" } { "identity" "an object" } { "quot" "a quotation with stack effect ( prev elt -- next )" } { "result" "the final result" } }
+{ $description "Combines successive elements of the list using a binary operation, and outputs the final result." } ;
+
+HELP: lmap
+{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj -- X )" } { "result" "resulting cons object" } }
+{ $description "Perform a similar functionality to that of the " { $link map } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-map> } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
+
+HELP: lmap-with
+{ $values { "value" "an object" } { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj elt -- X )" } { "result" "resulting cons object" } }
+{ $description "Variant of " { $link lmap } " which pushes a retained object on each invocation of the quotation." } ;
+
+HELP: ltake
+{ $values { "n" "a non negative integer" } { "list" "a cons object" } { "result" "resulting cons object" } }
+{ $description "Outputs a lazy list containing the first n items in the list. This is done a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-take> } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
+
+HELP: lfilter
+{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( -- X )" } { "result" "resulting cons object" } }
+{ $description "Perform a similar functionality to that of the " { $link filter } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-filter> } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
+
+HELP: lwhile
+{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( X -- bool )" } { "result" "resulting cons object" } }
+{ $description "Outputs a lazy list containing the first items in the list as long as " { $snippet "quot" } " evaluates to t. No evaluation of the list elements occurs initially but a " { $link <lazy-while> } " object is returned with conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
+
+HELP: luntil
+{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( X -- bool )" } { "result" "resulting cons object" } }
+{ $description "Outputs a lazy list containing the first items in the list until after " { $snippet "quot" } " evaluates to t. No evaluation of the list elements occurs initially but a " { $link <lazy-while> } " object is returned with conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
+
+HELP: list>vector
+{ $values { "list" "a cons object" } { "vector" "the list converted to a vector" } }
+{ $description "Convert a list to a vector. If the list is a lazy infinite list then this will enter an infinite loop." }
+{ $see-also list>array } ;
+
+HELP: list>array
+{ $values { "list" "a cons object" } { "array" "the list converted to an array" } }
+{ $description "Convert a list to an array. If the list is a lazy infinite list then this will enter an infinite loop." }
+{ $see-also list>vector } ;
+
+HELP: lappend
+{ $values { "list1" "a cons object" } { "list2" "a cons object" } { "result" "a lazy list of list2 appended to list1" } }
+{ $description "Perform a similar functionality to that of the " { $link append } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-append> } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required. Successive calls to " { $link cdr } " will iterate through list1, followed by list2." } ;
+
+HELP: lfrom-by
+{ $values { "n" "an integer" } { "quot" "a quotation with stack effect ( -- int )" } { "list" "a lazy list of integers" } }
+{ $description "Return an infinite lazy list of values starting from n, with each successive value being the result of applying quot to n." } ;
+
+HELP: lfrom
+{ $values { "n" "an integer" } { "list" "a lazy list of integers" } }
+{ $description "Return an infinite lazy list of incrementing integers starting from n." } ;
+
+HELP: seq>list
+{ $values { "index" "an integer 0 or greater" } { "seq" "a sequence" } { "list" "a list" } }
+{ $description "Convert the sequence into a list, starting from the 'index' offset into the sequence." }
+{ $see-also >list } ;
+
+HELP: >list
+{ $values { "object" "an object" } { "list" "a list" } }
+{ $description "Convert the object into a list. Existing lists are passed through intact, sequences are converted using " { $link seq>list } " and other objects cause an error to be thrown." }
+{ $see-also seq>list } ;
+
+HELP: lconcat
+{ $values { "list" "a list of lists" } { "result" "a list" } }
+{ $description "Concatenates a list of lists together into one list." } ;
+
+HELP: lcartesian-product
+{ $values { "list1" "a list" } { "list2" "a list" } { "result" "list of cartesian products" } }
+{ $description "Given two lists, return a list containing the cartesian product of those lists." } ;
+
+HELP: lcartesian-product*
+{ $values { "lists" "a list of lists" } { "result" "list of cartesian products" } }
+{ $description "Given a list of lists, return a list containing the cartesian product of those lists." } ;
+
+HELP: lcomp
+{ $values { "list" "a list of lists" } { "quot" "a quotation with stack effect ( seq -- X )" } { "result" "the resulting list" } }
+{ $description "Get the cartesian product of the lists in " { $snippet "list" } " and call " { $snippet "quot" } " call with each element from the cartesian product on the stack, the result of which is returned in the final " { $snippet "list" } "." } ;
+
+HELP: lcomp*
+{ $values { "list" "a list of lists" } { "guards" "a sequence of quotations with stack effect ( seq -- bool )" } { "quot" "a quotation with stack effect ( seq -- X )" } { "list" "the resulting list" } { "result" "a list" } }
+{ $description "Get the cartesian product of the lists in " { $snippet "list" } ", filter it by applying each guard quotation to it and call " { $snippet "quot" } " call with each element from the remaining cartesian product items on the stack, the result of which is returned in the final " { $snippet "list" } "." }
+{ $examples
+ { $code "{ 1 2 3 } >list { 4 5 6 } >list 2list { [ first odd? ] } [ first2 + ] lcomp*" }
+} ;
+
+HELP: lmerge
+{ $values { "list1" "a list" } { "list2" "a list" } { "result" "lazy list merging list1 and list2" } }
+{ $description "Return the result of merging the two lists in a lazy manner." }
+{ $examples
+ { $example "USING: lazy-lists prettyprint ;" "{ 1 2 3 } >list { 4 5 6 } >list lmerge list>array ." "{ 1 4 2 5 3 6 }" }
+} ;
+
+HELP: lcontents
+{ $values { "stream" "a stream" } { "result" string } }
+{ $description "Returns a lazy list of all characters in the file. " { $link car } " returns the next character in the file, " { $link cdr } " returns the remaining characters as a lazy list. " { $link nil? } " indicates end of file." }
+{ $see-also llines } ;
+
+HELP: llines
+{ $values { "stream" "a stream" } { "result" "a list" } }
+{ $description "Returns a lazy list of all lines in the file. " { $link car } " returns the next lines in the file, " { $link cdr } " returns the remaining lines as a lazy list. " { $link nil? } " indicates end of file." }
+{ $see-also lcontents } ;
+
--- /dev/null
+! Copyright (C) 2006 Matthew Willis and Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+!
+USING: lists lists.lazy tools.test kernel math io sequences ;
+IN: lists.lazy.tests
+
+[ { 1 2 3 4 } ] [
+ { 1 2 3 4 } >list list>array
+] unit-test
+
+[ { { 1 4 } { 1 5 } { 2 4 } { 2 5 } { 3 4 } { 3 5 } } ] [
+ { 1 2 3 } >list { 4 5 } >list 2list lcartesian-product* list>array
+] unit-test
+
+[ { { 1 4 } { 1 5 } { 2 4 } { 2 5 } { 3 4 } { 3 5 } } ] [
+ { 1 2 3 } >list { 4 5 } >list lcartesian-product list>array
+] unit-test
+
+[ { 5 6 6 7 7 8 } ] [
+ { 1 2 3 } >list { 4 5 } >list 2list [ first2 + ] lcomp list>array
+] unit-test
+
+[ { 5 6 7 8 } ] [
+ { 1 2 3 } >list { 4 5 } >list 2list { [ first odd? ] } [ first2 + ] lcomp* list>array
+] unit-test
+
+[ { 4 5 6 } ] [
+ 3 { 1 2 3 } >list [ + ] lmap-with list>array
+] unit-test
--- /dev/null
+! Copyright (C) 2004 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+!
+! Updated by Matthew Willis, July 2006
+! Updated by Chris Double, September 2006
+! Updated by James Cash, June 2008
+!
+USING: kernel sequences math vectors arrays namespaces
+quotations promises combinators io lists accessors ;
+IN: lists.lazy
+
+M: promise car ( promise -- car )
+ force car ;
+
+M: promise cdr ( promise -- cdr )
+ force cdr ;
+
+M: promise nil? ( cons -- bool )
+ force nil? ;
+
+! Both 'car' and 'cdr' are promises
+TUPLE: lazy-cons car cdr ;
+
+: lazy-cons ( car cdr -- promise )
+ [ promise ] bi@ \ lazy-cons boa
+ T{ promise f f t f } clone
+ [ set-promise-value ] keep ;
+
+M: lazy-cons car ( lazy-cons -- car )
+ car>> force ;
+
+M: lazy-cons cdr ( lazy-cons -- cdr )
+ cdr>> force ;
+
+M: lazy-cons nil? ( lazy-cons -- bool )
+ nil eq? ;
+
+: 1lazy-list ( a -- lazy-cons )
+ [ nil ] lazy-cons ;
+
+: 2lazy-list ( a b -- lazy-cons )
+ 1lazy-list 1quotation lazy-cons ;
+
+: 3lazy-list ( a b c -- lazy-cons )
+ 2lazy-list 1quotation lazy-cons ;
+
+: lnth ( n list -- elt )
+ swap [ cdr ] times car ;
+
+: (llength) ( list acc -- n )
+ over nil? [ nip ] [ [ cdr ] dip 1+ (llength) ] if ;
+
+: llength ( list -- n )
+ 0 (llength) ;
+
+: leach ( list quot -- )
+ over nil? [ 2drop ] [ [ uncons ] dip tuck call leach ] if ; inline
+
+: lreduce ( list identity quot -- result )
+ swapd leach ; inline
+
+TUPLE: memoized-cons original car cdr nil? ;
+
+: not-memoized ( -- obj )
+ { } ;
+
+: not-memoized? ( obj -- bool )
+ not-memoized eq? ;
+
+: <memoized-cons> ( cons -- memoized-cons )
+ not-memoized not-memoized not-memoized
+ memoized-cons boa ;
+
+M: memoized-cons car ( memoized-cons -- car )
+ dup car>> not-memoized? [
+ dup original>> car [ >>car drop ] keep
+ ] [
+ car>>
+ ] if ;
+
+M: memoized-cons cdr ( memoized-cons -- cdr )
+ dup cdr>> not-memoized? [
+ dup original>> cdr [ >>cdr drop ] keep
+ ] [
+ cdr>>
+ ] if ;
+
+M: memoized-cons nil? ( memoized-cons -- bool )
+ dup nil?>> not-memoized? [
+ dup original>> nil? [ >>nil? drop ] keep
+ ] [
+ nil?>>
+ ] if ;
+
+TUPLE: lazy-map cons quot ;
+
+C: <lazy-map> lazy-map
+
+: lmap ( list quot -- result )
+ over nil? [ 2drop nil ] [ <lazy-map> <memoized-cons> ] if ;
+
+M: lazy-map car ( lazy-map -- car )
+ [ cons>> car ] keep
+ quot>> call ;
+
+M: lazy-map cdr ( lazy-map -- cdr )
+ [ cons>> cdr ] keep
+ quot>> lmap ;
+
+M: lazy-map nil? ( lazy-map -- bool )
+ cons>> nil? ;
+
+: lmap-with ( value list quot -- result )
+ with lmap ;
+
+TUPLE: lazy-take n cons ;
+
+C: <lazy-take> lazy-take
+
+: ltake ( n list -- result )
+ over zero? [ 2drop nil ] [ <lazy-take> ] if ;
+
+M: lazy-take car ( lazy-take -- car )
+ cons>> car ;
+
+M: lazy-take cdr ( lazy-take -- cdr )
+ [ n>> 1- ] keep
+ cons>> cdr ltake ;
+
+M: lazy-take nil? ( lazy-take -- bool )
+ dup n>> zero? [
+ drop t
+ ] [
+ cons>> nil?
+ ] if ;
+
+TUPLE: lazy-until cons quot ;
+
+C: <lazy-until> lazy-until
+
+: luntil ( list quot -- result )
+ over nil? [ drop ] [ <lazy-until> ] if ;
+
+M: lazy-until car ( lazy-until -- car )
+ cons>> car ;
+
+M: lazy-until cdr ( lazy-until -- cdr )
+ [ cons>> uncons ] keep quot>> tuck call
+ [ 2drop nil ] [ luntil ] if ;
+
+M: lazy-until nil? ( lazy-until -- bool )
+ drop f ;
+
+TUPLE: lazy-while cons quot ;
+
+C: <lazy-while> lazy-while
+
+: lwhile ( list quot -- result )
+ over nil? [ drop ] [ <lazy-while> ] if ;
+
+M: lazy-while car ( lazy-while -- car )
+ cons>> car ;
+
+M: lazy-while cdr ( lazy-while -- cdr )
+ [ cons>> cdr ] keep quot>> lwhile ;
+
+M: lazy-while nil? ( lazy-while -- bool )
+ [ car ] keep quot>> call not ;
+
+TUPLE: lazy-filter cons quot ;
+
+C: <lazy-filter> lazy-filter
+
+: lfilter ( list quot -- result )
+ over nil? [ 2drop nil ] [ <lazy-filter> <memoized-cons> ] if ;
+
+: car-filter? ( lazy-filter -- ? )
+ [ cons>> car ] keep
+ quot>> call ;
+
+: skip ( lazy-filter -- )
+ dup cons>> cdr >>cons ;
+
+M: lazy-filter car ( lazy-filter -- car )
+ dup car-filter? [ cons>> ] [ dup skip ] if car ;
+
+M: lazy-filter cdr ( lazy-filter -- cdr )
+ dup car-filter? [
+ [ cons>> cdr ] keep
+ quot>> lfilter
+ ] [
+ dup skip cdr
+ ] if ;
+
+M: lazy-filter nil? ( lazy-filter -- bool )
+ dup cons>> nil? [
+ drop t
+ ] [
+ dup car-filter? [
+ drop f
+ ] [
+ dup skip nil?
+ ] if
+ ] if ;
+
+: list>vector ( list -- vector )
+ [ [ , ] leach ] V{ } make ;
+
+: list>array ( list -- array )
+ [ [ , ] leach ] { } make ;
+
+TUPLE: lazy-append list1 list2 ;
+
+C: <lazy-append> lazy-append
+
+: lappend ( list1 list2 -- result )
+ over nil? [ nip ] [ <lazy-append> ] if ;
+
+M: lazy-append car ( lazy-append -- car )
+ list1>> car ;
+
+M: lazy-append cdr ( lazy-append -- cdr )
+ [ list1>> cdr ] keep
+ list2>> lappend ;
+
+M: lazy-append nil? ( lazy-append -- bool )
+ drop f ;
+
+TUPLE: lazy-from-by n quot ;
+
+C: lfrom-by lazy-from-by ( n quot -- list )
+
+: lfrom ( n -- list )
+ [ 1+ ] lfrom-by ;
+
+M: lazy-from-by car ( lazy-from-by -- car )
+ n>> ;
+
+M: lazy-from-by cdr ( lazy-from-by -- cdr )
+ [ n>> ] keep
+ quot>> dup slip lfrom-by ;
+
+M: lazy-from-by nil? ( lazy-from-by -- bool )
+ drop f ;
+
+TUPLE: lazy-zip list1 list2 ;
+
+C: <lazy-zip> lazy-zip
+
+: lzip ( list1 list2 -- lazy-zip )
+ over nil? over nil? or
+ [ 2drop nil ] [ <lazy-zip> ] if ;
+
+M: lazy-zip car ( lazy-zip -- car )
+ [ list1>> car ] keep list2>> car 2array ;
+
+M: lazy-zip cdr ( lazy-zip -- cdr )
+ [ list1>> cdr ] keep list2>> cdr lzip ;
+
+M: lazy-zip nil? ( lazy-zip -- bool )
+ drop f ;
+
+TUPLE: sequence-cons index seq ;
+
+C: <sequence-cons> sequence-cons
+
+: seq>list ( index seq -- list )
+ 2dup length >= [
+ 2drop nil
+ ] [
+ <sequence-cons>
+ ] if ;
+
+M: sequence-cons car ( sequence-cons -- car )
+ [ index>> ] keep
+ seq>> nth ;
+
+M: sequence-cons cdr ( sequence-cons -- cdr )
+ [ index>> 1+ ] keep
+ seq>> seq>list ;
+
+M: sequence-cons nil? ( sequence-cons -- bool )
+ drop f ;
+
+: >list ( object -- list )
+ {
+ { [ dup sequence? ] [ 0 swap seq>list ] }
+ { [ dup list? ] [ ] }
+ [ "Could not convert object to a list" throw ]
+ } cond ;
+
+TUPLE: lazy-concat car cdr ;
+
+C: <lazy-concat> lazy-concat
+
+DEFER: lconcat
+
+: (lconcat) ( car cdr -- list )
+ over nil? [
+ nip lconcat
+ ] [
+ <lazy-concat>
+ ] if ;
+
+: lconcat ( list -- result )
+ dup nil? [
+ drop nil
+ ] [
+ uncons swap (lconcat)
+ ] if ;
+
+M: lazy-concat car ( lazy-concat -- car )
+ car>> car ;
+
+M: lazy-concat cdr ( lazy-concat -- cdr )
+ [ car>> cdr ] keep cdr>> (lconcat) ;
+
+M: lazy-concat nil? ( lazy-concat -- bool )
+ dup car>> nil? [
+ cdr>> nil?
+ ] [
+ drop f
+ ] if ;
+
+: lcartesian-product ( list1 list2 -- result )
+ swap [ swap [ 2array ] lmap-with ] lmap-with lconcat ;
+
+: lcartesian-product* ( lists -- result )
+ dup nil? [
+ drop nil
+ ] [
+ [ car ] keep cdr [ car lcartesian-product ] keep cdr list>array swap [
+ swap [ swap [ suffix ] lmap-with ] lmap-with lconcat
+ ] reduce
+ ] if ;
+
+: lcomp ( list quot -- result )
+ [ lcartesian-product* ] dip lmap ;
+
+: lcomp* ( list guards quot -- result )
+ [ [ lcartesian-product* ] dip [ lfilter ] each ] dip lmap ;
+
+DEFER: lmerge
+
+: (lmerge) ( list1 list2 -- result )
+ over [ car ] curry -rot
+ [
+ dup [ car ] curry -rot
+ [
+ [ cdr ] bi@ lmerge
+ ] 2curry lazy-cons
+ ] 2curry lazy-cons ;
+
+: lmerge ( list1 list2 -- result )
+ {
+ { [ over nil? ] [ nip ] }
+ { [ dup nil? ] [ drop ] }
+ { [ t ] [ (lmerge) ] }
+ } cond ;
+
+TUPLE: lazy-io stream car cdr quot ;
+
+C: <lazy-io> lazy-io
+
+: lcontents ( stream -- result )
+ f f [ stream-read1 ] <lazy-io> ;
+
+: llines ( stream -- result )
+ f f [ stream-readln ] <lazy-io> ;
+
+M: lazy-io car ( lazy-io -- car )
+ dup car>> dup [
+ nip
+ ] [
+ drop dup stream>> over quot>> call
+ swap dupd set-lazy-io-car
+ ] if ;
+
+M: lazy-io cdr ( lazy-io -- cdr )
+ dup cdr>> dup [
+ nip
+ ] [
+ drop dup
+ [ stream>> ] keep
+ [ quot>> ] keep
+ car [
+ [ f f ] dip <lazy-io> [ >>cdr drop ] keep
+ ] [
+ 3drop nil
+ ] if
+ ] if ;
+
+M: lazy-io nil? ( lazy-io -- bool )
+ car not ;
+
+INSTANCE: sequence-cons list
+INSTANCE: memoized-cons list
+INSTANCE: promise list
+INSTANCE: lazy-io list
+INSTANCE: lazy-concat list
+INSTANCE: lazy-cons list
+INSTANCE: lazy-map list
+INSTANCE: lazy-take list
+INSTANCE: lazy-append list
+INSTANCE: lazy-from-by list
+INSTANCE: lazy-zip list
+INSTANCE: lazy-while list
+INSTANCE: lazy-until list
+INSTANCE: lazy-filter list
--- /dev/null
+<html>
+ <head>
+ <title>Lazy Evaluation</title>
+ <link rel="stylesheet" type="text/css" href="style.css">
+ </head>
+ <body>
+ <h1>Lazy Evaluation</h1>
+<p>The 'lazy' vocabulary adds lazy lists to Factor. This provides the
+ ability to describe infinite structures, and to delay execution of
+ expressions until they are actually used.</p>
+<p>Lazy lists, like normal lists, are composed of a head and tail. In
+ a lazy list the head and tail are something called a 'promise'.
+ To convert a
+ 'promise' into its actual value a word called 'force' is used. To
+ convert a value into a 'promise' the word to use is 'delay'.</p>
+<table border="1">
+<tr><td><a href="#delay">delay</a></td></tr>
+<tr><td><a href="#force">force</a></td></tr>
+</table>
+
+<p>Many of the lazy list words are named similar to the standard list
+ words but with an 'l' suffixed to it. Here are the commonly used
+ words and their equivalent list operation:</p>
+<table border="1">
+<tr><th>Lazy List</th><th>Normal List</th></tr>
+<tr><td><a href="#lnil">lnil</a></td><td>[ ]</td></tr>
+<tr><td><a href="#lnilp">lnil?</a></td><td>Test for nil value</td></tr>
+<tr><td><a href="#lcons">lcons</a></td><td>cons</td></tr>
+<tr><td><a href="#lunit">lunit</a></td><td>unit</td></tr>
+<tr><td><a href="#lcar">lcar</a></td><td>car</td></tr>
+<tr><td><a href="#lcdr">lcdr</a></td><td>cdr</td></tr>
+<tr><td><a href="#lnth">lnth</a></td><td>nth</td></tr>
+<tr><td><a href="#luncons">luncons</a></td><td>uncons</td></tr>
+<tr><td><a href="#lmap">lmap</a></td><td>map</td></tr>
+<tr><td><a href="#lsubset">lsubset</a></td><td>subset</td></tr>
+<tr><td><a href="#leach">leach</a></td><td>each</td></tr>
+<tr><td><a href="#lappend">lappend</a></td><td>append</td></tr>
+</table>
+<p>A few additional words specific to lazy lists are:</p>
+<table border="1">
+<tr><td><a href="#ltake">ltake</a></td><td>Returns a normal list containing a specified
+number of items from the lazy list.</td></tr>
+<tr><td><a href="#lappendstar">lappend*</a></td><td>Given a lazy list of lazy lists,
+concatenate them together in a lazy manner, returning a single lazy
+list.</td></tr>
+<tr><td><a href="#list>llist">list>llist</a></td><td>Given a normal list, return a lazy list
+that contains the same elements as the normal list.</td></tr>
+</table>
+<h2>Reference</h2>
+<!-- delay description -->
+<a name="delay">
+<h3>delay ( quot -- <promise> )</h3>
+<p>'delay' is used to convert a value or expression into a promise.
+ The word 'force' is used to convert that promise back to its
+ value, or to force evaluation of the expression to return a value.
+</p>
+<p>The value on the stack that 'delay' expects must be quoted. This is
+ a requirement to prevent it from being evaluated.
+</p>
+<pre class="code">
+ ( 1 ) [ 42 ] <a href="#delay">delay</a> dup .
+ => << promise [ ] [ 42 ] [ ] [ ] >>
+ ( 2 ) <a href="#force">force</a> .
+ => 42
+</pre>
+
+<!-- force description -->
+<a name="force">
+<h3>force ( <promise> -- value )</h3>
+<p>'force' will evaluate a promises original expression
+ and leave the value of that expression on the stack.
+</p>
+<p>A promise can be forced multiple times but the expression
+ is only evaluated once. Future calls of 'force' on the promise
+ will returned the cached value of the original force. If the
+ expression contains side effects, such as i/o, then that i/o
+ will only occur on the first 'force'. See below for an example
+ (steps 3-5).
+</p>
+<p>If a promise is itself delayed, a force will evaluate all promises
+ until a value is returned. Due to this behaviour it is generally not
+ possible to delay a promise. The example below shows what happens
+ in this case.
+</p>
+<pre class="code">
+ ( 1 ) [ 42 ] <a href="#delay">delay</a> dup .
+ => << promise [ ] [ 42 ] [ ] [ ] >>
+ ( 2 ) <a href="#force">force</a> .
+ => 42
+
+ #! Multiple forces on a promise returns cached value
+ ( 3 ) [ "hello" print 42 ] <a href="#delay">delay</a> dup .
+ => << promise [ ] [ "hello" print 42 ] [ ] [ ] >>
+ ( 4 ) dup <a href="#force">force</a> .
+ => hello
+ 42
+ ( 5 ) <a href="#force">force</a> .
+ => 42
+
+ #! Forcing a delayed promise cascades up to return
+ #! original value, rather than the promise.
+ ( 6 ) [ [ 42 ] <a href="#delay">delay</a> ] <a href="#delay">delay</a> dup .
+ => << promise [ ] [ [ 42 ] delay ] [ ] [ ] >>
+ ( 7 ) <a href="#force">force</a> .
+ => 42
+</pre>
+
+<!-- lnil description -->
+<a name="lnil">
+<h3>lnil ( -- lcons )</h3>
+<p>Returns a value representing the empty lazy list.</p>
+<pre class="code">
+ ( 1 ) <a href="#lnil">lnil</a> .
+ => << promise [ ] [ [ ] ] t [ ] >>
+</pre>
+
+<!-- lnil description -->
+<a name="lnilp">
+<h3>lnil? ( lcons -- bool )</h3>
+<p>Returns true if the given lazy cons is the value representing
+ the empty lazy list.</p>
+<pre class="code">
+ ( 1 ) <a href="#lnil">lnil</a> <a href="#lnilp">lnil?</a> .
+ => t
+ ( 2 ) [ 1 ] <a href="#list2llist">list>llist</a> dup <a href="#lnilp">lnil?</a> .
+ => [ ]
+ ( 3 ) <a href="#lcdr">lcdr</a> <a href="#lnilp">lnil?</a> .
+ => t
+</pre>
+
+<!-- lcons description -->
+<a name="lcons">
+<h3>lcons ( car-promise cdr-promise -- lcons )</h3>
+<p>Provides the same effect as 'cons' does for normal lists.
+ Both values provided must be promises (ie. expressions that have
+ had <a href="#delay">delay</a> called on them).
+</p>
+<p>As the car and cdr passed on the stack are promises, they are not
+ evaluated until <a href="#lcar">lcar</a> or <a href="#lcdr">lcdr</a>
+ are called on the lazy cons.</p>
+<pre class="code">
+ ( 1 ) [ "car" ] <a href="#delay">delay</a> [ "cdr" ] <a href="#delay">delay</a> <a href="#lcons">lcons</a> dup .
+ => << promise ... >>
+ ( 2 ) dup <a href="#lcar">lcar</a> .
+ => "car"
+ ( 3 ) dup <a href="#lcdr">lcdr</a> .
+ => "cdr"
+</pre>
+
+<!-- lunit description -->
+<a name="lunit">
+<h3>lunit ( value-promise -- llist )</h3>
+<p>Provides the same effect as 'unit' does for normal lists. It
+creates a lazy list where the first element is the value given.</p>
+<p>Like <a href="#lcons">lcons</a>, the value on the stack must be
+ a promise and is not evaluated until the <a href="#lcar">lcar</a>
+ of the list is requested.</a>
+<pre class="code">
+ ( 1 ) [ 42 ] <a href="#delay">delay</a> <a href="#lunit">lunit</a> dup .
+ => << promise ... >>
+ ( 2 ) dup <a href="#lcar">lcar</a> .
+ => 42
+ ( 3 ) dup <a href="#lcdr">lcdr</a> <a href="#lnilp">lnil?</a> .
+ => t
+ ( 4 ) [ . ] <a href="#leach">leach</a>
+ => 42
+</pre>
+
+<!-- lcar description -->
+<a name="lcar">
+<h3>lcar ( lcons -- value )</h3>
+<p>Provides the same effect as 'car' does for normal lists. It
+returns the first element in a lazy cons cell. This will force
+the evaluation of that element.</p>
+<pre class="code">
+ ( 1 ) [ 42 ] <a href="#delay">delay</a> <a href="#lunit">lunit</a> dup .
+ => << promise ... >>
+ ( 2 ) <a href="#lcar">lcar</a> .
+ => 42
+</pre>
+
+<!-- lcdr description -->
+<a name="lcdr">
+<h3>lcdr ( lcons -- value )</h3>
+<p>Provides the same effect as 'cdr' does for normal lists. It
+returns the second element in a lazy cons cell and forces it. This
+causes that element to be evaluated immediately.</p>
+<pre class="code">
+ ( 1 ) [ 1 ] <a href="#delay">delay</a> [ 5 6 + ] <a href="#delay">delay</a> <a href="#lcons">lcons</a> dup .
+ => << promise ... >>
+ ( 2 ) <a href="#lcdr">lcdr</a> .
+ => 11
+</pre>
+
+<pre class="code">
+ ( 1 ) 5 <a href="#lfrom">lfrom</a> dup .
+ => << promise ... >>
+ ( 2 ) <a href="#lcdr">lcdr</a> dup <a href="#lcar">lcar</a> .
+ => 6
+ ( 3 ) <a href="#lcdr">lcdr</a> dup <a href="#lcar">lcar</a> .
+ => 7
+ ( 4 ) <a href="#lcdr">lcdr</a> dup <a href="#lcar">lcar</a> .
+ => 8
+</pre>
+
+<!-- lnth description -->
+<a name="lnth">
+<h3>lnth ( n llist -- value )</h3>
+<p>Provides the same effect as 'nth' does for normal lists. It
+returns the nth value in the lazy list. It causes all the values up to
+'n' to be evaluated.</p>
+<pre class="code">
+ ( 1 ) 1 <a href="#lfrom">lfrom</a> dup .
+ => << promise ... >>
+ ( 2 ) 5 swap <a href="#lnth">lnth</a> .
+ => 6
+</pre>
+
+<!-- luncons description -->
+<a name="luncons">
+<h3>luncons ( lcons -- car cdr )</h3>
+<p>Provides the same effect as 'uncons' does for normal lists. It
+returns the car and cdr of the lazy list.</p>
+<pre class="code">
+ ( 1 ) [ 5 ] <a href="#delay">delay</a> [ 6 ] <a href="#delay">delay</a> <a href="#lcons">lcons</a> dup .
+ => << promise ... >>
+ ( 2 ) <a href="#luncons">luncons</a> . .
+ => 6
+ 5
+</pre>
+
+<!-- lmap description -->
+<a name="lmap">
+<h3>lmap ( llist quot -- llist )</h3>
+<p>Lazily maps over a lazy list applying the quotation to each element.
+A new lazy list is returned which contains the results of the
+quotation.</p>
+<p>When intially called nothing in the original lazy list is
+evaluated. Only when <a href="#lcar">lcar</a> is called will the item
+in the list be evaluated and applied to the quotation. Ditto with <a
+href="#lcdr">lcdr</a>, thus allowing infinite lists to be mapped over.</p>
+<pre class="code">
+ ( 1 ) 1 <a href="#lfrom">lfrom</a>
+ => < infinite list of incrementing numbers >
+ ( 2 ) [ 2 * ] <a href="#lmap">lmap</a>
+ => < infinite list of numbers incrementing by 2 >
+ ( 3 ) 5 swap <a href="#ltake">ltake</a> <a href="#llist2list">llist>list</a> .
+ => [ 2 4 6 8 10 ]
+</pre>
+
+<!-- lsubset description -->
+<a name="lsubset">
+<h3>lsubset ( llist pred -- llist )</h3>
+<p>Provides the same effect as 'subset' does for normal lists. It
+lazily iterates over a lazy list applying the predicate quotation to each
+element. If that quotation returns true, the element will be included
+in the resulting lazy list. If it is false, the element will be skipped.
+A new lazy list is returned which contains all elements where the
+predicate returned true.</p>
+<p>Like <a href="#lmap">lmap</a>, when initially called no evaluation
+will occur. A lazy list is returned that when values are retrieved
+from in then items are evaluated and checked against the predicate.</p>
+<pre class="code">
+ ( 1 ) 1 <a href="#lfrom">lfrom</a>
+ => < infinite list of incrementing numbers >
+ ( 2 ) [ <a href="#primep">prime?</a> ] <a href="#lsubset">lsubset</a>
+ => < infinite list of prime numbers >
+ ( 3 ) 5 swap <a href="#ltake">ltake</a> <a href="#llist2list">llist>list</a> .
+ => [ 2 3 5 7 11 ]
+</pre>
+
+<!-- leach description -->
+<a name="leach">
+<h3>leach ( llist quot -- )</h3>
+<p>Provides the same effect as 'each' does for normal lists. It
+lazily iterates over a lazy list applying the quotation to each
+element. If this operation is applied to an infinite list it will
+never return unless the quotation escapes out by calling a continuation.</p>
+<pre class="code">
+ ( 1 ) 1 <a href="#lfrom">lfrom</a>
+ => < infinite list of incrementing numbers >
+ ( 2 ) [ 2 mod 1 = ] <a href="#lsubset">lsubset</a>
+ => < infinite list of odd numbers >
+ ( 3 ) [ . ] <a href="#leach">leach</a>
+ => 1
+ 3
+ 5
+ 7
+ ... for ever ...
+</pre>
+
+<!-- ltake description -->
+<a name="ltake">
+<h3>ltake ( n llist -- llist )</h3>
+<p>Iterates over the lazy list 'n' times, appending each element to a
+lazy list. This provides a convenient way of getting elements out of
+an infinite lazy list.</p>
+<pre class="code">
+ ( 1 ) : ones [ 1 ] delay [ ones ] delay <a href="#lcons">lcons</a> ;
+ ( 2 ) 5 ones <a href="#ltake">ltake</a> <a href="#llist2list">llist>list</a> .
+ => [ 1 1 1 1 1 ]
+</pre>
+
+<!-- lappend description -->
+<a name="lappend">
+<h3>lappend ( llist1 llist2 -- llist )</h3>
+<p>Lazily appends two lists together. The actual appending is done
+lazily on iteration rather than immediately so it works very fast no
+matter how large the list.</p>
+<pre class="code">
+ ( 1 ) [ 1 2 3 ] <a href="#list2llist">list>llist</a> [ 4 5 6 ] <a href="#list2llist">list>llist</a> <a href="#lappend">lappend</a>
+ ( 2 ) [ . ] <a href="#leach">leach</a>
+ => 1
+ 2
+ 3
+ 4
+ 5
+ 6
+</pre>
+
+<!-- lappend* description -->
+<a name="lappendstar">
+<h3>lappend* ( llists -- llist )</h3>
+<p>Given a lazy list of lazy lists, concatenate them together in a
+lazy fashion. The actual appending is done lazily on iteration rather
+than immediately so it works very fast no matter how large the lists.</p>
+<pre class="code">
+ ( 1 ) [ 1 2 3 ] <a href="#list2>llist">list>llist</a>
+ ( 2 ) [ 4 5 6 ] <a href="#list2llist">list>llist</a>
+ ( 3 ) [ 7 8 9 ] <a href="#list2llist">list>llist</a>
+ ( 4 ) 3list <a href="#list2llist">list>llist</a> <a href="#lappendstar">lappend*</a>
+ ( 5 ) [ . ] <a href="#leach">leach</a>
+ => 1
+ 2
+ 3
+ 4
+ 5
+ 6
+ 7
+ 8
+ 9
+</pre>
+
+<!-- list>llist description -->
+<a name="list2llist">
+<h3>list>llist ( list -- llist )</h3>
+<p>Converts a normal list into a lazy list. This is done lazily so the
+initial list is not iterated through immediately.</p>
+<pre class="code">
+ ( 1 ) [ 1 2 3 ] <a href="#list2llist">list>llist</a>
+ ( 2 ) [ . ] <a href="#leach">leach</a>
+ => 1
+ 2
+ 3
+</pre>
+
+<p class="footer">
+News and updates to this software can be obtained from the authors
+weblog: <a href="http://radio.weblogs.com/0102385">Chris Double</a>.</p>
+<p id="copyright">Copyright (c) 2004, Chris Double. All Rights Reserved.</p>
+</body> </html>
--- /dev/null
+Lazy lists
--- /dev/null
+extensions
+collections
--- /dev/null
+! Copyright (C) 2006 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+
+IN: lists
+USING: help.markup help.syntax ;
+
+{ car cons cdr nil nil? list? uncons } related-words
+
+HELP: cons
+{ $values { "car" "the head of the lazy list" } { "cdr" "the tail of the lazy list" } { "cons" "a cons object" } }
+{ $description "Constructs a cons cell." } ;
+
+HELP: car
+{ $values { "cons" "a cons object" } { "car" "the first item in the list" } }
+{ $description "Returns the first item in the list." } ;
+
+HELP: cdr
+{ $values { "cons" "a cons object" } { "cdr" "a cons object" } }
+{ $description "Returns the tail of the list." } ;
+
+HELP: nil
+{ $values { "cons" "An empty cons" } }
+{ $description "Returns a representation of an empty list" } ;
+
+HELP: nil?
+{ $values { "cons" "a cons object" } { "?" "a boolean" } }
+{ $description "Return true if the cons object is the nil cons." } ;
+
+HELP: list? ( object -- ? )
+{ $values { "object" "an object" } { "?" "a boolean" } }
+{ $description "Returns true if the object conforms to the list protocol." } ;
+
+{ 1list 2list 3list } related-words
+
+HELP: 1list
+{ $values { "obj" "an object" } { "cons" "a cons object" } }
+{ $description "Create a list with 1 element." } ;
+
+HELP: 2list
+{ $values { "a" "an object" } { "b" "an object" } { "cons" "a cons object" } }
+{ $description "Create a list with 2 elements." } ;
+
+HELP: 3list
+{ $values { "a" "an object" } { "b" "an object" } { "c" "an object" } { "cons" "a cons object" } }
+{ $description "Create a list with 3 elements." } ;
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 James Cash
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test lists math ;
+
+IN: lists.tests
+
+{ { 3 4 5 6 } } [
+ T{ cons f 1
+ T{ cons f 2
+ T{ cons f 3
+ T{ cons f 4
+ T{ cons f f f } } } } } [ 2 + ] map-cons
+] unit-test
+
+{ 10 } [
+ T{ cons f 1
+ T{ cons f 2
+ T{ cons f 3
+ T{ cons f 4
+ T{ cons f f f } } } } } 0 [ + ] reduce-cons
+] unit-test
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 James Cash
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences accessors ;
+
+IN: lists
+
+! Lazy List Protocol
+MIXIN: list
+GENERIC: car ( cons -- car )
+GENERIC: cdr ( cons -- cdr )
+GENERIC: nil? ( cons -- ? )
+
+TUPLE: cons car cdr ;
+
+C: cons cons
+
+M: cons car ( cons -- car )
+ car>> ;
+
+M: cons cdr ( cons -- cdr )
+ cdr>> ;
+
+: nil ( -- cons )
+ T{ cons f f f } ;
+
+M: cons nil? ( cons -- bool )
+ nil eq? ;
+
+: 1list ( obj -- cons )
+ nil cons ;
+
+: 2list ( a b -- cons )
+ nil cons cons ;
+
+: 3list ( a b c -- cons )
+ nil cons cons cons ;
+
+: uncons ( cons -- cdr car )
+ [ cdr ] [ car ] bi ;
+
+: seq>cons ( seq -- cons )
+ <reversed> nil [ f cons swap >>cdr ] reduce ;
+
+: (map-cons) ( acc cons quot -- seq )
+ over nil? [ 2drop ]
+ [ [ uncons ] dip [ call ] keep swapd [ suffix ] 2dip (map-cons) ] if ;
+
+: map-cons ( cons quot -- seq )
+ [ { } clone ] 2dip (map-cons) ;
+
+: cons>seq ( cons -- array )
+ [ ] map-cons ;
+
+: reduce-cons ( cons identity quot -- result )
+ pick nil? [ drop nip ]
+ [ [ uncons ] 2dip swapd [ call ] keep reduce-cons ] if ;
+
+INSTANCE: cons list
\ No newline at end of file
--- /dev/null
+Implementation of lisp-style linked lists
--- /dev/null
+cons
+lists
+sequences
[ 3 ] [ 1 [let | a [ ] | 3 ] ] unit-test
[ ] [ 1 2 [let | a [ ] b [ ] | ] ] unit-test
+
+:: a-word-with-locals ( a b -- ) ;
+
+: new-definition "USING: math ;\nIN: locals.tests\n: a-word-with-locals ( -- x ) 2 3 + ;\n" ;
+
+[ ] [ new-definition eval ] unit-test
+
+[ t ] [
+ [ \ a-word-with-locals see ] with-string-writer
+ new-definition =
+] unit-test
M: lambda-word definition
"lambda" word-prop body>> ;
+M: lambda-word reset-word
+ [ f "lambda" set-word-prop ] [ call-next-method ] bi ;
+
INTERSECTION: lambda-macro macro lambda-word ;
M: lambda-macro definer drop \ MACRO:: \ ; ;
M: lambda-macro definition
"lambda" word-prop body>> ;
+M: lambda-macro reset-word
+ [ f "lambda" set-word-prop ] [ call-next-method ] bi ;
+
INTERSECTION: lambda-method method-body lambda-word ;
M: lambda-method definer drop \ M:: \ ; ;
M: lambda-method definition
"lambda" word-prop body>> ;
+M: lambda-method reset-word
+ [ f "lambda" set-word-prop ] [ call-next-method ] bi ;
+
INTERSECTION: lambda-memoized memoized lambda-word ;
M: lambda-memoized definer drop \ MEMO:: \ ; ;
M: lambda-memoized definition
"lambda" word-prop body>> ;
+M: lambda-memoized reset-word
+ [ f "lambda" set-word-prop ] [ call-next-method ] bi ;
+
: method-stack-effect ( method -- effect )
dup "lambda" word-prop vars>>
swap "method-generic" word-prop stack-effect
--- /dev/null
+IN: logging.tests
+USING: tools.test logging math ;
+
+: input-logging-test ( a b -- c ) + ;
+
+\ input-logging-test NOTICE add-input-logging
+
+: output-logging-test ( a b -- c ) + ;
+
+\ output-logging-test DEBUG add-output-logging
+
+: error-logging-test ( a b -- c ) / ;
+
+\ error-logging-test ERROR add-error-logging
+
+"logging-test" [
+ [ 4 ] [ 1 3 input-logging-test ] unit-test
+
+ [ 4 ] [ 1 3 output-logging-test ] unit-test
+
+ [ 4/3 ] [ 4 3 error-logging-test ] unit-test
+
+ [ f ] [ 1 0 error-logging-test ] unit-test
+] with-logging
words kernel arrays shuffle tools.annotations\r
prettyprint.config prettyprint debugger io.streams.string\r
splitting continuations effects arrays.lib parser strings\r
-combinators.lib quotations ;\r
+combinators.lib quotations fry symbols accessors ;\r
IN: logging\r
\r
-SYMBOL: DEBUG\r
-SYMBOL: NOTICE\r
-SYMBOL: WARNING\r
-SYMBOL: ERROR\r
-SYMBOL: CRITICAL\r
+SYMBOLS: DEBUG NOTICE WARNING ERROR CRITICAL ;\r
\r
-: log-levels\r
- { DEBUG NOTICE NOTICE WARNING ERROR CRITICAL } ;\r
+: log-levels { DEBUG NOTICE NOTICE WARNING ERROR CRITICAL } ;\r
\r
: send-to-log-server ( array string -- )\r
prefix "log-server" get send ;\r
\r
SYMBOL: log-service\r
\r
-: check-log-message\r
- pick string?\r
- pick word?\r
- pick word? and and\r
- [ "Bad parameters to log-message" throw ] unless ;\r
+: check-log-message ( msg word level -- msg word level )\r
+ 3dup [ string? ] [ word? ] [ word? ] tri* and and\r
+ [ "Bad parameters to log-message" throw ] unless ; inline\r
\r
: log-message ( msg word level -- )\r
check-log-message\r
log-service get dup [\r
- >r >r >r string-lines r> word-name r> word-name r>\r
+ [ [ string-lines ] [ word-name ] [ word-name ] tri* ] dip\r
4array "log-message" send-to-log-server\r
] [\r
4drop\r
PRIVATE>\r
\r
: (define-logging) ( word level quot -- )\r
- >r >r dup r> r> 2curry annotate ;\r
+ [ dup ] 2dip 2curry annotate ;\r
\r
: call-logging-quot ( quot word level -- quot' )\r
"called" -rot [ log-message ] 3curry prepose ;\r
\r
: log-stack ( n word level -- )\r
log-service get [\r
- >r >r [ ndup ] keep narray stack>message\r
- r> r> log-message\r
+ [ [ ndup ] keep narray stack>message ] 2dip log-message\r
] [\r
3drop\r
] if ; inline\r
\r
-: input# stack-effect effect-in length ;\r
+: input# stack-effect in>> length ;\r
\r
: input-logging-quot ( quot word level -- quot' )\r
- over input# -rot [ log-stack ] 3curry prepose ;\r
+ rot [ [ input# ] keep ] 2dip '[ , , , log-stack @ ] ;\r
\r
: add-input-logging ( word level -- )\r
[ input-logging-quot ] (define-logging) ;\r
\r
-: output# stack-effect effect-out length ;\r
+: output# stack-effect out>> length ;\r
\r
: output-logging-quot ( quot word level -- quot' )\r
- over output# -rot [ log-stack ] 3curry compose ;\r
+ [ [ output# ] keep ] dip '[ @ , , , log-stack ] ;\r
\r
: add-output-logging ( word level -- )\r
[ output-logging-quot ] (define-logging) ;\r
\r
: (log-error) ( object word level -- )\r
log-service get [\r
- >r >r [ print-error ] with-string-writer r> r> log-message\r
+ [ [ print-error ] with-string-writer ] 2dip log-message\r
] [\r
2drop rethrow\r
] if ;\r
\r
: log-critical ( error word -- ) CRITICAL (log-error) ;\r
\r
-: stack-balancer ( effect word -- quot )\r
- >r dup effect-in length r> [ over >r ERROR log-stack r> ndrop ] 2curry\r
- swap effect-out length f <repetition> append >quotation ;\r
+: stack-balancer ( effect -- quot )\r
+ [ in>> length [ ndrop ] curry ]\r
+ [ out>> length f <repetition> >quotation ]\r
+ bi append ;\r
\r
: error-logging-quot ( quot word -- quot' )\r
- [ [ log-error ] curry ] keep\r
- [ stack-effect ] keep stack-balancer compose\r
- [ recover ] 2curry ;\r
+ dup stack-effect stack-balancer\r
+ '[ , [ , log-error @ ] recover ] ;\r
\r
: add-error-logging ( word level -- )\r
- [ over >r input-logging-quot r> error-logging-quot ]\r
+ [ [ input-logging-quot ] 2keep drop error-logging-quot ]\r
(define-logging) ;\r
\r
: LOG:\r
#! Syntax: name level\r
- CREATE-WORD\r
- dup scan-word\r
- [ >r >r 1array stack>message r> r> log-message ] 2curry\r
+ CREATE-WORD dup scan-word\r
+ '[ 1array stack>message , , log-message ]\r
define ; parsing\r
IN: macros.tests
USING: tools.test macros math kernel arrays
-vectors ;
+vectors io.streams.string prettyprint parser ;
+MACRO: see-test ( a b -- c ) + ;
+
+[ "USING: macros math ;\nIN: macros.tests\nMACRO: see-test ( a b -- c ) + ;\n" ]
+[ [ \ see-test see ] with-string-writer ]
+unit-test
+
+[ t ] [
+ "USING: math ;\nIN: macros.tests\n: see-test ( a b -- c ) - ;\n" dup eval
+ [ \ see-test see ] with-string-writer =
+] unit-test
M: macro definition "macro" word-prop ;
+M: macro reset-word
+ [ f "macro" set-word-prop ] [ call-next-method ] bi ;
+
: macro-expand ( ... word -- quot ) "macro" word-prop call ;
: n*quot ( n seq -- seq' ) <repetition> concat >quotation ;
! Copyright (c) 2007 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
-USING: lazy-lists math.erato tools.test ;
+USING: lists lists.lazy math.erato tools.test ;
IN: math.erato.tests
[ { 2 3 5 7 11 13 17 19 } ] [ 20 lerato list>array ] unit-test
! Copyright (c) 2007 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
-USING: bit-arrays kernel lazy-lists math math.functions math.primes.list
+USING: bit-arrays kernel lists lists.lazy math math.functions math.primes.list
math.ranges sequences ;
IN: math.erato
[ 0.0 ] [ 0 sin ] unit-test
[ 0.0 ] [ 0 asin ] unit-test
+[ t ] [ 10 atan real? ] unit-test
+[ f ] [ 10 atanh real? ] unit-test
+
+[ t ] [ 10 asin sin 10 1.e-10 ~ ] unit-test
+[ t ] [ -1 sqrt neg dup acos cos 1.e-10 ~ ] unit-test
+[ t ] [ 10 asinh sinh 10 1.e-10 ~ ] unit-test
+
[ 100 ] [ 100 100 gcd nip ] unit-test
[ 100 ] [ 1000 100 gcd nip ] unit-test
[ 100 ] [ 100 1000 gcd nip ] unit-test
M: number (^)
swap >polar 3dup ^theta >r ^mag r> polar> ;
+: [-1,1]? ( x -- ? )
+ dup complex? [ drop f ] [ abs 1 <= ] if ; inline
+
+: >=1? ( x -- ? )
+ dup complex? [ drop f ] [ 1 >= ] if ; inline
+
: exp ( x -- y ) >rect swap fexp swap polar> ; inline
: log ( x -- y ) >polar swap flog swap rect> ; inline
: cos ( x -- y )
- >float-rect 2dup
- fcosh swap fcos * -rot
- fsinh swap fsin neg * rect> ; foldable
+ dup complex? [
+ >float-rect 2dup
+ fcosh swap fcos * -rot
+ fsinh swap fsin neg * rect>
+ ] [ fcos ] if ; foldable
: sec ( x -- y ) cos recip ; inline
: cosh ( x -- y )
- >float-rect 2dup
- fcos swap fcosh * -rot
- fsin swap fsinh * rect> ; foldable
+ dup complex? [
+ >float-rect 2dup
+ fcos swap fcosh * -rot
+ fsin swap fsinh * rect>
+ ] [ fcosh ] if ; foldable
: sech ( x -- y ) cosh recip ; inline
: sin ( x -- y )
- >float-rect 2dup
- fcosh swap fsin * -rot
- fsinh swap fcos * rect> ; foldable
+ dup complex? [
+ >float-rect 2dup
+ fcosh swap fsin * -rot
+ fsinh swap fcos * rect>
+ ] [ fsin ] if ; foldable
: cosec ( x -- y ) sin recip ; inline
: sinh ( x -- y )
- >float-rect 2dup
- fcos swap fsinh * -rot
- fsin swap fcosh * rect> ; foldable
+ dup complex? [
+ >float-rect 2dup
+ fcos swap fsinh * -rot
+ fsin swap fcosh * rect>
+ ] [ fsinh ] if ; foldable
: cosech ( x -- y ) sinh recip ; inline
-: tan ( x -- y ) dup sin swap cos / ; inline
+: tan ( x -- y )
+ dup complex? [ dup sin swap cos / ] [ ftan ] if ; inline
-: tanh ( x -- y ) dup sinh swap cosh / ; inline
+: tanh ( x -- y )
+ dup complex? [ dup sinh swap cosh / ] [ ftanh ] if ; inline
-: cot ( x -- y ) dup cos swap sin / ; inline
+: cot ( x -- y ) tan recip ; inline
-: coth ( x -- y ) dup cosh swap sinh / ; inline
+: coth ( x -- y ) tanh recip ; inline
-: acosh ( x -- y ) dup sq 1- sqrt + log ; inline
+: acosh ( x -- y )
+ dup >=1? [ facosh ] [ dup sq 1- sqrt + log ] if ; inline
: asech ( x -- y ) recip acosh ; inline
-: asinh ( x -- y ) dup sq 1+ sqrt + log ; inline
+: asinh ( x -- y )
+ dup complex? [ dup sq 1+ sqrt + log ] [ fasinh ] if ; inline
: acosech ( x -- y ) recip asinh ; inline
-: atanh ( x -- y ) dup 1+ swap 1- neg / log 2 / ; inline
+: atanh ( x -- y )
+ dup [-1,1]? [ fatanh ] [ dup 1+ swap 1- neg / log 2 / ] if ; inline
: acoth ( x -- y ) recip atanh ; inline
-: [-1,1]? ( x -- ? )
- dup complex? [ drop f ] [ abs 1 <= ] if ; inline
-
: i* ( x -- y ) >rect neg swap rect> ;
: -i* ( x -- y ) >rect swap neg rect> ;
: asin ( x -- y )
- dup [-1,1]? [ >float fasin ] [ i* asinh -i* ] if ; inline
+ dup [-1,1]? [ fasin ] [ i* asinh -i* ] if ; inline
: acos ( x -- y )
- dup [-1,1]? [ >float facos ] [ asin pi 2 / swap - ] if ;
+ dup [-1,1]? [ facos ] [ asin pi 2 / swap - ] if ;
inline
: atan ( x -- y )
- dup [-1,1]? [ >float fatan ] [ i* atanh i* ] if ; inline
+ dup complex? [ i* atanh i* ] [ fatan ] if ; inline
: asec ( x -- y ) recip acos ; inline
"double" "libm" "atan" { "double" } alien-invoke ;
foldable
+: facosh ( x -- y )
+ "double" "libm" "acosh" { "double" } alien-invoke ;
+ foldable
+
+: fasinh ( x -- y )
+ "double" "libm" "asinh" { "double" } alien-invoke ;
+ foldable
+
+: fatanh ( x -- y )
+ "double" "libm" "atanh" { "double" } alien-invoke ;
+ foldable
+
: fatan2 ( x y -- z )
"double" "libm" "atan2" { "double" "double" } alien-invoke ;
foldable
"double" "libm" "sin" { "double" } alien-invoke ;
foldable
+: ftan ( x -- y )
+ "double" "libm" "tan" { "double" } alien-invoke ;
+ foldable
+
: fcosh ( x -- y )
"double" "libm" "cosh" { "double" } alien-invoke ;
foldable
"double" "libm" "sinh" { "double" } alien-invoke ;
foldable
+: ftanh ( x -- y )
+ "double" "libm" "tanh" { "double" } alien-invoke ;
+ foldable
+
: fexp ( x -- y )
"double" "libm" "exp" { "double" } alien-invoke ;
foldable
! Copyright (C) 2007 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel lazy-lists math math.primes namespaces sequences ;
+USING: arrays kernel lists lists.lazy math math.primes namespaces sequences ;
IN: math.primes.factors
<PRIVATE
-USING: arrays math.primes tools.test lazy-lists ;
+USING: arrays math.primes tools.test lists lists.lazy ;
{ 1237 } [ 1234 next-prime ] unit-test
{ f t } [ 1234 prime? 1237 prime? ] unit-test
! Copyright (C) 2007 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators kernel lazy-lists math math.functions math.miller-rabin
+USING: combinators kernel lists lists.lazy math math.functions math.miller-rabin
math.order math.primes.list math.ranges sequences sorting ;
IN: math.primes
! Copyright (C) 2007 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: math kernel memoize tools.test parser ;
+USING: math kernel memoize tools.test parser
+prettyprint io.streams.string sequences ;
IN: memoize.tests
MEMO: fib ( m -- n )
[ 89 ] [ 10 fib ] unit-test
[ "USING: kernel math memoize ; IN: memoize.tests MEMO: x ( a b c d e -- f g h i j ) >r >r >r >r 1+ r> r> r> r> ;" eval ] must-fail
+
+MEMO: see-test ( a -- b ) reverse ;
+
+[ "USING: memoize sequences ;\nIN: memoize.tests\nMEMO: see-test ( a -- b ) reverse ;\n" ]
+[ [ \ see-test see ] with-string-writer ]
+unit-test
+
+[ ] [ "IN: memoize.tests : fib ;" eval ] unit-test
+
+[ "IN: memoize.tests\n: fib ( -- ) ;\n" ] [ [ \ fib see ] with-string-writer ] unit-test
PREDICATE: memoized < word "memoize" word-prop ;
M: memoized definer drop \ MEMO: \ ; ;
+
M: memoized definition "memo-quot" word-prop ;
+M: memoized reset-word
+ [ { "memoize" "memo-quot" } reset-props ]
+ [ call-next-method ]
+ bi ;
+
: memoize-quot ( quot effect -- memo-quot )
gensym swap dupd "declared-effect" set-word-prop
dup rot define-memoized 1quotation ;
: reset-memoized ( word -- )
"memoize" word-prop clear-assoc ;
+
+: invalidate-memoized ! ( inputs... word )
+ [ #in packer call ] [ "memoize" word-prop delete-at ] bi ;
-USING: tools.test monads math kernel sequences lazy-lists promises ;
+USING: tools.test monads math kernel sequences lists lists.lazy promises ;
IN: monads.tests
[ 5 ] [ 1 identity-monad return [ 4 + ] fmap run-identity ] unit-test
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel sequences sequences.deep splitting
-accessors fry locals combinators namespaces lazy-lists
+accessors fry locals combinators namespaces lists lists.lazy
shuffle ;
IN: monads
! Copyright (C) 2007, 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs combinators hashtables kernel lazy-lists math namespaces openal parser-combinators promises sequences strings symbols synth synth.buffers unicode.case ;
+USING: accessors assocs combinators hashtables kernel lists lists.lazy math namespaces openal parser-combinators promises sequences strings symbols synth synth.buffers unicode.case ;
IN: morse
<PRIVATE
combinators arrays words assocs parser namespaces definitions
prettyprint prettyprint.backend quotations arrays.lib
debugger io compiler.units kernel.private effects accessors
-hashtables sorting shuffle math.order ;
+hashtables sorting shuffle math.order sets ;
IN: multi-methods
! PART I: Converting hook specializers
]
[
[ pair? ] filter
- [ keys [ hooks get push-new ] each ] keep
+ [ keys [ hooks get adjoin ] each ] keep
] bi append ;
: canonicalize-specializer-2 ( specializer -- specializer' )
! USING: kernel quotations namespaces sequences assocs.lib ;
USING: kernel namespaces namespaces.private quotations sequences
- assocs.lib math.parser math sequences.lib locals ;
+ assocs.lib math.parser math sequences.lib locals mirrors ;
IN: namespaces.lib
] with-scope
]
] ;
+
+: make-object ( quot class -- object )
+ new [ <mirror> swap bind ] keep ; inline
+
+: with-object ( object quot -- )
+ [ <mirror> ] dip bind ; inline
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: index ( seq obj -- i ) swap sequences:index ;
+: index-of ( obj seq -- i ) sequences:index ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
: 1st 0 at ;
: 2nd 1 at ;
: 3rd 2 at ;
--- /dev/null
+! Copyright (C) 2008 Matthew Willis.
+! See http://factorcode.org/license.txt for BSD license.
+USING: locals math.functions math namespaces
+opengl.gl accessors kernel opengl ui.gadgets
+destructors sequences ui.render colors ;
+IN: opengl.gadgets
+
+TUPLE: texture-gadget bytes format dim tex ;
+
+: 2^-ceil ( x -- y )
+ dup 2 < [ 2 * ] [ 1- log2 1+ 2^ ] if ; foldable flushable
+
+: 2^-bounds ( dim -- dim' )
+ [ 2^-ceil ] map ; foldable flushable
+
+: <texture-gadget> ( bytes format dim -- gadget )
+ texture-gadget construct-gadget
+ swap >>dim
+ swap >>format
+ swap >>bytes ;
+
+:: render ( gadget -- )
+ GL_ENABLE_BIT [
+ GL_TEXTURE_2D glEnable
+ GL_TEXTURE_2D gadget tex>> glBindTexture
+ GL_TEXTURE_2D
+ 0
+ GL_RGBA
+ gadget dim>> 2^-bounds first2
+ 0
+ gadget format>>
+ GL_UNSIGNED_BYTE
+ gadget bytes>>
+ glTexImage2D
+ init-texture
+ GL_TEXTURE_2D 0 glBindTexture
+ ] do-attribs ;
+
+:: four-corners ( dim -- )
+ [let* | w [ dim first ]
+ h [ dim second ]
+ dim' [ dim dup 2^-bounds [ /f ] 2map ]
+ w' [ dim' first ]
+ h' [ dim' second ] |
+ 0 0 glTexCoord2d 0 0 glVertex2d
+ 0 h' glTexCoord2d 0 h glVertex2d
+ w' h' glTexCoord2d w h glVertex2d
+ w' 0 glTexCoord2d w 0 glVertex2d
+ ] ;
+
+M: texture-gadget draw-gadget* ( gadget -- )
+ origin get [
+ GL_ENABLE_BIT [
+ white gl-color
+ 1.0 -1.0 glPixelZoom
+ GL_TEXTURE_2D glEnable
+ GL_TEXTURE_2D over tex>> glBindTexture
+ GL_QUADS [
+ dim>> four-corners
+ ] do-state
+ GL_TEXTURE_2D 0 glBindTexture
+ ] do-attribs
+ ] with-translation ;
+
+M: texture-gadget graft* ( gadget -- )
+ gen-texture >>tex [ render ]
+ [ f >>bytes f >>format drop ] bi ;
+
+M: texture-gadget ungraft* ( gadget -- )
+ tex>> delete-texture ;
+
+M: texture-gadget pref-dim* ( gadget -- dim ) dim>> ;
dup sprite-loc gl-translate
GL_TEXTURE_2D over sprite-texture glBindTexture
init-texture
- GL_QUADS [ dup sprite-dim2 four-sides ] do-state
- dup sprite-dim { 1 0 } v*
- swap sprite-loc v- gl-translate
+ GL_QUADS [ sprite-dim2 four-sides ] do-state
GL_TEXTURE_2D 0 glBindTexture ;
: rect-vertices ( lower-left upper-right -- )
OpenSSL_add_all_digests
OpenSSL_add_all_ciphers ;
-SYMBOL: ssl-initiazed?
+SYMBOL: ssl-initialized?
: maybe-init-ssl ( -- )
- ssl-initiazed? get-global [
+ ssl-initialized? get-global [
init-ssl
- t ssl-initiazed? set-global
+ t ssl-initialized? set-global
] unless ;
-[ f ssl-initiazed? set-global ] "openssl" add-init-hook
+[ f ssl-initialized? set-global ] "openssl" add-init-hook
TUPLE: openssl-context < secure-context aliens ;
--- /dev/null
+! Copyright (C) 2008 Matthew Willis.
+! See http://factorcode.org/license.txt for BSD license.
+!
+! pangocairo bindings, from pango/pangocairo.h
+USING: cairo.ffi alien.c-types math
+alien.syntax system combinators alien
+arrays pango pango.fonts ;
+IN: pango.cairo
+
+<< "pangocairo" {
+! { [ os winnt? ] [ "libpangocairo-1.dll" ] }
+! { [ os macosx? ] [ "libpangocairo.dylib" ] }
+ { [ os unix? ] [ "libpangocairo-1.0.so" ] }
+} cond "cdecl" add-library >>
+
+LIBRARY: pangocairo
+
+FUNCTION: PangoFontMap*
+pango_cairo_font_map_new ( ) ;
+
+FUNCTION: PangoFontMap*
+pango_cairo_font_map_new_for_font_type ( cairo_font_type_t fonttype ) ;
+
+FUNCTION: PangoFontMap*
+pango_cairo_font_map_get_default ( ) ;
+
+FUNCTION: cairo_font_type_t
+pango_cairo_font_map_get_font_type ( PangoCairoFontMap* fontmap ) ;
+
+FUNCTION: void
+pango_cairo_font_map_set_resolution ( PangoCairoFontMap* fontmap, double dpi ) ;
+
+FUNCTION: double
+pango_cairo_font_map_get_resolution ( PangoCairoFontMap* fontmap ) ;
+
+FUNCTION: PangoContext*
+pango_cairo_font_map_create_context ( PangoCairoFontMap* fontmap ) ;
+
+FUNCTION: cairo_scaled_font_t*
+pango_cairo_font_get_scaled_font ( PangoCairoFont* font ) ;
+
+! Update a Pango context for the current state of a cairo context
+FUNCTION: void
+pango_cairo_update_context ( cairo_t* cr, PangoContext* context ) ;
+
+FUNCTION: void
+pango_cairo_context_set_font_options ( PangoContext* context, cairo_font_options_t* options ) ;
+
+FUNCTION: cairo_font_options_t*
+pango_cairo_context_get_font_options ( PangoContext* context ) ;
+
+FUNCTION: void
+pango_cairo_context_set_resolution ( PangoContext* context, double dpi ) ;
+
+FUNCTION: double
+pango_cairo_context_get_resolution ( PangoContext* context ) ;
+
+! Convenience
+FUNCTION: PangoLayout*
+pango_cairo_create_layout ( cairo_t* cr ) ;
+
+FUNCTION: void
+pango_cairo_update_layout ( cairo_t* cr, PangoLayout* layout ) ;
+
+! Rendering
+FUNCTION: void
+pango_cairo_show_glyph_string ( cairo_t* cr, PangoFont* font, PangoGlyphString* glyphs ) ;
+
+FUNCTION: void
+pango_cairo_show_layout_line ( cairo_t* cr, PangoLayoutLine* line ) ;
+
+FUNCTION: void
+pango_cairo_show_layout ( cairo_t* cr, PangoLayout* layout ) ;
+
+FUNCTION: void
+pango_cairo_show_error_underline ( cairo_t* cr, double x, double y, double width, double height ) ;
+
+! Rendering to a path
+FUNCTION: void
+pango_cairo_glyph_string_path ( cairo_t* cr, PangoFont* font, PangoGlyphString* glyphs ) ;
+
+FUNCTION: void
+pango_cairo_layout_line_path ( cairo_t* cr, PangoLayoutLine* line ) ;
+
+FUNCTION: void
+pango_cairo_layout_path ( cairo_t* cr, PangoLayout* layout ) ;
+
+FUNCTION: void
+pango_cairo_error_underline_path ( cairo_t* cr, double x, double y, double width, double height ) ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Higher level words and combinators
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USING: destructors accessors namespaces kernel cairo ;
+
+TUPLE: pango-layout alien ;
+C: <pango-layout> pango-layout
+M: pango-layout dispose ( alien -- ) alien>> g_object_unref ;
+
+: layout ( -- pango-layout ) pango-layout get ;
+
+: (with-pango) ( layout quot -- )
+ >r alien>> pango-layout r> with-variable ; inline
+
+: with-pango ( quot -- )
+ cr pango_cairo_create_layout <pango-layout> swap
+ [ (with-pango) ] curry with-disposal ; inline
+
+: pango-layout-get-pixel-size ( layout -- width height )
+ 0 <int> 0 <int> [ pango_layout_get_pixel_size ] 2keep
+ [ *int ] bi@ ;
+
+: dummy-pango ( quot -- )
+ >r CAIRO_FORMAT_ARGB32 0 0 cairo_image_surface_create
+ r> [ with-pango ] curry with-cairo-from-surface ; inline
+
+: layout-size ( quot -- dim )
+ [ layout pango-layout-get-pixel-size 2array ] compose dummy-pango ; inline
+
+: layout-font ( str -- )
+ pango_font_description_from_string
+ dup zero? [ "pango: not a valid font." throw ] when
+ layout over pango_layout_set_font_description
+ pango_font_description_free ;
+
+: layout-text ( str -- )
+ layout swap -1 pango_layout_set_text ;
+
+: families ( -- families )
+ pango_cairo_font_map_get_default list-families ;
--- /dev/null
+! Copyright (C) 2008 Matthew Willis.
+! See http://factorcode.org/license.txt for BSD license.
+USING: pango.cairo cairo cairo.ffi cairo.gadgets
+alien.c-types kernel math ;
+IN: pango.cairo.gadgets
+
+: (pango-gadget) ( setup show -- gadget )
+ [ drop layout-size ]
+ [ compose [ with-pango ] curry <cairo-gadget> ] 2bi ;
+
+: <pango-gadget> ( quot -- gadget )
+ [ cr layout pango_cairo_show_layout ] (pango-gadget) ;
+
+USING: prettyprint sequences ui.gadgets.panes
+threads io.backend io.encodings.utf8 io.files ;
+: hello-pango ( -- )
+ 50 [ 6 + ] map [
+ "Sans " swap unparse append
+ [
+ cr 0 1 0.2 0.6 cairo_set_source_rgba
+ layout-font "今日は、 Pango!" layout-text
+ ] curry
+ <pango-gadget> gadget. yield
+ ] each
+ [
+ "resource:extra/pango/cairo/gadgets/gadgets.factor"
+ normalize-path utf8 file-contents layout-text
+ ] <pango-gadget> gadget. ;
+
+MAIN: hello-pango
--- /dev/null
+! Copyright (C) 2008 Matthew Willis.
+! See http://factorcode.org/license.txt for BSD license
+USING: pango alien.syntax alien.c-types
+kernel ;
+IN: pango.fonts
+
+LIBRARY: pango
+
+FUNCTION: void
+pango_font_map_list_families ( PangoFontMap* fontmap, PangoFontFamily*** families, int* n_families ) ;
+
+FUNCTION: char*
+pango_font_family_get_name ( PangoFontFamily* family ) ;
+
+FUNCTION: int
+pango_font_family_is_monospace ( PangoFontFamily* family ) ;
+
+FUNCTION: void
+pango_font_family_list_faces ( PangoFontFamily* family, PangoFontFace*** faces, int* n_faces ) ;
+
+FUNCTION: char*
+pango_font_face_get_face_name ( PangoFontFace* face ) ;
+
+FUNCTION: void
+pango_font_face_list_sizes ( PangoFontFace* face, int** sizes, int* n_sizes ) ;
+
+: list-families ( PangoFontMap* -- PangoFontFamily*-seq )
+ 0 <int> 0 <int> [ pango_font_map_list_families ] 2keep
+ *int swap *void* [ swap c-void*-array> ] [ g_free ] bi ;
+
+: list-faces ( PangoFontFamily* -- PangoFontFace*-seq )
+ 0 <int> 0 <int> [ pango_font_family_list_faces ] 2keep
+ *int swap *void* [ swap c-void*-array> ] [ g_free ] bi ;
+
+: list-sizes ( PangoFontFace* -- ints )
+ 0 <int> 0 <int> [ pango_font_face_list_sizes ] 2keep
+ *int swap *void* [ swap c-int-array> ] [ g_free ] bi ;
+
+: monospace? ( PangoFontFamily* -- ? )
+ pango_font_family_is_monospace 1 = ;
--- /dev/null
+! Copyright (C) 2008 Matthew Willis.
+! See http://factorcode.org/license.txt for BSD license
+USING: system
+alien.c-types alien.syntax alien combinators ;
+IN: pango
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Helpful functions from other parts of pango
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+<< "pango" {
+! { [ os winnt? ] [ "libpango-1.dll" ] }
+! { [ os macosx? ] [ "libpango.dylib" ] }
+ { [ os unix? ] [ "libpango-1.0.so" ] }
+} cond "cdecl" add-library >>
+
+LIBRARY: pango
+
+: PANGO_SCALE 1024 ;
+
+FUNCTION: void
+pango_layout_set_text ( PangoLayout* layout, char* text, int length ) ;
+
+FUNCTION: char*
+pango_layout_get_text ( PangoLayout* layout ) ;
+
+FUNCTION: void
+pango_layout_get_size ( PangoLayout* layout, int* width, int* height ) ;
+
+FUNCTION: PangoFontDescription*
+pango_font_description_from_string ( char* str ) ;
+
+FUNCTION: char*
+pango_font_description_to_string ( PangoFontDescription* desc ) ;
+
+FUNCTION: char*
+pango_font_description_to_filename ( PangoFontDescription* desc ) ;
+
+FUNCTION: void
+pango_layout_set_font_description ( PangoLayout* layout, PangoFontDescription* desc ) ;
+
+FUNCTION: PangoFontDescription*
+pango_layout_get_font_description ( PangoLayout* layout ) ;
+
+FUNCTION: void
+pango_layout_get_pixel_size ( PangoLayout* layout, int* width, int* height ) ;
+
+FUNCTION: void
+pango_font_description_free ( PangoFontDescription* desc ) ;
+
+! glib functions
+
+TYPEDEF: void* gpointer
+
+FUNCTION: void
+g_object_unref ( gpointer object ) ;
+
+FUNCTION: void
+g_free ( gpointer mem ) ;
"from the input string. The value consumed is the "
"result of the parse." }
{ $examples
-{ $example "USING: lazy-lists parser-combinators prettyprint ;" "\"foo\" any-char-parser parse-1 ." "102" } } ;
+{ $example "USING: lists lists.lazy parser-combinators prettyprint ;" "\"foo\" any-char-parser parse-1 ." "102" } } ;
! Copyright (C) 2005 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel lazy-lists tools.test strings math
+USING: kernel lists lists.lazy tools.test strings math
sequences parser-combinators arrays math.parser unicode.categories ;
IN: parser-combinators.tests
! Copyright (C) 2004 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: lazy-lists promises kernel sequences strings math
+USING: lists lists.lazy promises kernel sequences strings math
arrays splitting quotations combinators namespaces
unicode.case unicode.categories sequences.deep ;
IN: parser-combinators
"the input string. The numeric value of the digit "
" consumed is the result of the parse." }
{ $examples
-{ $example "USING: lazy-lists parser-combinators parser-combinators.simple prettyprint ;" "\"123\" 'digit' parse-1 ." "1" } } ;
+{ $example "USING: lists lists.lazy parser-combinators parser-combinators.simple prettyprint ;" "\"123\" 'digit' parse-1 ." "1" } } ;
HELP: 'integer'
{ $values
"the input string. The numeric value of the integer "
" consumed is the result of the parse." }
{ $examples
-{ $example "USING: lazy-lists parser-combinators parser-combinators.simple prettyprint ;" "\"123\" 'integer' parse-1 ." "123" } } ;
+{ $example "USING: lists lists.lazy parser-combinators parser-combinators.simple prettyprint ;" "\"123\" 'integer' parse-1 ." "123" } } ;
HELP: 'string'
{ $values
{ "parser" "a parser object" } }
"quotations from the input string. The string value "
" consumed is the result of the parse." }
{ $examples
-{ $example "USING: lazy-lists parser-combinators parser-combinators.simple prettyprint ;" "\"\\\"foo\\\"\" 'string' parse-1 ." "\"foo\"" } } ;
+{ $example "USING: lists lists.lazy parser-combinators parser-combinators.simple prettyprint ;" "\"\\\"foo\\\"\" 'string' parse-1 ." "\"foo\"" } } ;
HELP: 'bold'
{ $values
"'element' should be a parser that can parse the elements. The "
"result of the parser is a sequence of the parsed elements." }
{ $examples
-{ $example "USING: lazy-lists parser-combinators parser-combinators.simple prettyprint ;" "\"1,2,3,4\" 'integer' comma-list parse-1 ." "{ 1 2 3 4 }" } } ;
+{ $example "USING: lists lists.lazy parser-combinators parser-combinators.simple prettyprint ;" "\"1,2,3,4\" 'integer' comma-list parse-1 ." "{ 1 2 3 4 }" } } ;
{ $see-also 'digit' 'integer' 'string' 'bold' 'italic' comma-list } related-words
! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel strings math sequences lazy-lists words
+USING: kernel strings math sequences lists lists.lazy words
math.parser promises parser-combinators unicode.categories ;
IN: parser-combinators.simple
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: lazy-lists math math.primes ;
+USING: lists lists.lazy math math.primes ;
IN: project-euler.007
! http://projecteuler.net/index.php?section=problems&id=7
! Copyright (c) 2007 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel lazy-lists math.algebra math math.functions
+USING: arrays kernel lists lists.lazy math.algebra math math.functions
math.order math.primes math.ranges project-euler.common sequences ;
IN: project-euler.134
"QUALIFIED: math\n1 2 math:+ ! ==> 3" } } ;
HELP: QUALIFIED-WITH:
-{ $syntax "QUALIFIED-WITH: vocab prefix" }
-{ $description "Works like " { $link POSTPONE: QUALIFIED: } " but uses the specified prefix." }
+{ $syntax "QUALIFIED-WITH: vocab word-prefix" }
+{ $description "Works like " { $link POSTPONE: QUALIFIED: } " but uses " { $snippet "word-prefix" } " as prefix." }
{ $examples { $code
"QUALIFIED-WITH: math m\n1 2 m:+ ! ==> 3" } } ;
HELP: FROM:
{ $syntax "FROM: vocab => words ... ;" }
-{ $description "Imports the specified words from vocab." }
+{ $description "Imports " { $snippet "words" } " from " { $snippet "vocab" } "." }
{ $examples { $code
"FROM: math.parser => bin> hex> ; ! imports only bin> and hex>" } } ;
HELP: EXCLUDE:
{ $syntax "EXCLUDE: vocab => words ... ;" }
-{ $description "Imports everything from vocab excluding the specified words" }
+{ $description "Imports everything from " { $snippet "vocab" } " excluding " { $snippet "words" } "." }
{ $examples { $code
- "EXCLUDE: math.parser => bin> hex> ; ! imports everythin but bin> and hex>" } } ;
+ "EXCLUDE: math.parser => bin> hex> ; ! imports everything but bin> and hex>" } } ;
HELP: RENAME:
{ $syntax "RENAME: word vocab => newname " }
-{ $description "Imports word from vocab, but renamed to newname." }
+{ $description "Imports " { $snippet "word" } " from " { $snippet "vocab" } ", but renamed to " { $snippet "newname" } "." }
{ $examples { $code
"RENAME: + math => -"
"2 3 - ! => 5" } } ;
-USING: arrays combinators kernel lazy-lists math math.parser
+USING: arrays combinators kernel lists lists.lazy math math.parser
namespaces parser parser-combinators parser-combinators.simple
promises quotations sequences combinators.lib strings math.order
assocs prettyprint.backend memoize unicode.case unicode.categories ;
C: <entry> entry
+: try-parsing-timestamp ( string -- timestamp )
+ [ rfc822>timestamp ] [ drop rfc3339>timestamp ] recover ;
+
: rss1.0-entry ( tag -- entry )
- [ "title" tag-named children>string ] keep
- [ "link" tag-named children>string ] keep
- [ "description" tag-named children>string ] keep
- f "date" "http://purl.org/dc/elements/1.1/" <name>
- tag-named dup [ children>string rfc822>timestamp ] when
- <entry> ;
+ {
+ [ "title" tag-named children>string ]
+ [ "link" tag-named children>string ]
+ [ "description" tag-named children>string ]
+ [
+ f "date" "http://purl.org/dc/elements/1.1/" <name>
+ tag-named dup [ children>string try-parsing-timestamp ] when
+ ]
+ } cleave <entry> ;
: rss1.0 ( xml -- feed )
[
"channel" tag-named
- [ "title" tag-named children>string ] keep
- "link" tag-named children>string
- ] keep
- "item" tags-named [ rss1.0-entry ] map <feed> ;
+ [ "title" tag-named children>string ]
+ [ "link" tag-named children>string ] bi
+ ] [ "item" tags-named [ rss1.0-entry ] map ] bi
+ <feed> ;
: rss2.0-entry ( tag -- entry )
- [ "title" tag-named children>string ] keep
- [ "link" tag-named ] keep
- [ "guid" tag-named dupd ? children>string ] keep
- [ "description" tag-named children>string ] keep
- "pubDate" tag-named children>string rfc822>timestamp <entry> ;
+ {
+ [ "title" tag-named children>string ]
+ [ { "link" "guid" } any-tag-named children>string ]
+ [ "description" tag-named children>string ]
+ [
+ { "date" "pubDate" } any-tag-named
+ children>string try-parsing-timestamp
+ ]
+ } cleave <entry> ;
: rss2.0 ( xml -- feed )
"channel" tag-named
- [ "title" tag-named children>string ] keep
- [ "link" tag-named children>string ] keep
- "item" tags-named [ rss2.0-entry ] map <feed> ;
+ [ "title" tag-named children>string ]
+ [ "link" tag-named children>string ]
+ [ "item" tags-named [ rss2.0-entry ] map ]
+ tri <feed> ;
: atom1.0-entry ( tag -- entry )
- [ "title" tag-named children>string ] keep
- [ "link" tag-named "href" swap at ] keep
- [
- { "content" "summary" } any-tag-named
- dup tag-children [ string? not ] contains?
- [ tag-children [ write-chunk ] with-string-writer ]
- [ children>string ] if
- ] keep
- { "published" "updated" "issued" "modified" } any-tag-named
- children>string rfc3339>timestamp <entry> ;
+ {
+ [ "title" tag-named children>string ]
+ [ "link" tag-named "href" swap at ]
+ [
+ { "content" "summary" } any-tag-named
+ dup tag-children [ string? not ] contains?
+ [ tag-children [ write-chunk ] with-string-writer ]
+ [ children>string ] if
+ ]
+ [
+ { "published" "updated" "issued" "modified" }
+ any-tag-named children>string try-parsing-timestamp
+ ]
+ } cleave <entry> ;
: atom1.0 ( xml -- feed )
- [ "title" tag-named children>string ] keep
- [ "link" tag-named "href" swap at ] keep
- "entry" tags-named [ atom1.0-entry ] map <feed> ;
+ [ "title" tag-named children>string ]
+ [ "link" tag-named "href" swap at ]
+ [ "entry" tags-named [ atom1.0-entry ] map ]
+ tri <feed> ;
: xml>feed ( xml -- feed )
dup name-tag {
-USING: html kernel semantic-db tangle.html tools.test ;
+USING: kernel semantic-db tangle.html tools.test ;
IN: tangle.html.tests
[ "test" ] [ "test" >html ] unit-test
! Copyright (C) 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors html html.elements io io.streams.string kernel namespaces semantic-db sequences strings tangle.path ;
+USING: accessors html.elements io io.streams.string kernel namespaces semantic-db sequences strings tangle.path ;
IN: tangle.html
TUPLE: element attributes ;
: with-tangle ( tangle quot -- )
[ [ db>> ] [ seq>> ] bi ] dip with-db ;
-: <text-response> ( text -- response )
- "text/plain" <content> swap >>body ;
-
: node-response ( id -- response )
- load-node [ node-content <text-response> ] [ <404> ] if* ;
+ load-node [ node-content <text-content> ] [ <404> ] if* ;
: display-node ( params -- response )
[
: submit-node ( params -- response )
[
"node_content" swap at* [
- create-node id>> number>string <text-response>
+ create-node id>> number>string <text-content>
] [
drop <400>
] if
C: <path-responder> path-responder
M: path-responder call-responder* ( path responder -- response )
- drop path>file [ node-content <text-response> ] [ <404> ] if* ;
-
-: <json-response> ( obj -- response )
- "application/json" <content> swap >json >>body ;
+ drop path>file [ node-content <text-content> ] [ <404> ] if* ;
TUPLE: tangle-dispatcher < dispatcher tangle ;
<path-responder> >>default
"resource:extra/tangle/resources" <static> "resources" add-responder
<node-responder> "node" add-responder
- <action> [ all-node-ids <json-response> ] >>display "all" add-responder ;
+ <action> [ all-node-ids <json-content> ] >>display "all" add-responder ;
M: tangle-dispatcher call-responder* ( path dispatcher -- response )
dup tangle>> [
! Copyright (C) 2006, 2007 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences math math.functions tetris.board
-tetris.piece tetris.tetromino lazy-lists combinators system ;
+tetris.piece tetris.tetromino lists lists.lazy combinators system ;
IN: tetris.game
TUPLE: tetris pieces last-update update-interval rows score game-state paused? running? ;
! Copyright (C) 2006, 2007 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: kernel arrays tetris.tetromino math math.vectors
-sequences quotations lazy-lists ;
+sequences quotations lists lists.lazy ;
IN: tetris.piece
#! A piece adds state to the tetromino that is the piece's delegate. The
[ ] [ "sudoku" shake-and-bake ] unit-test\r
\r
[ t ] [\r
- cell 8 = 30 15 ? 100000 * small-enough?\r
+ cell 8 = 20 10 ? 100000 * small-enough?\r
] unit-test\r
\r
[ ] [ "hello-ui" shake-and-bake ] unit-test\r
cell 8 = 40 20 ? 100000 * small-enough?\r
] unit-test\r
\r
+[ ] [ "maze" shake-and-bake ] unit-test\r
+\r
+[ t ] [\r
+ cell 8 = 30 15 ? 100000 * small-enough?\r
+] unit-test\r
+\r
[ ] [ "bunny" shake-and-bake ] unit-test\r
\r
[ t ] [\r
: stripped-globals ( -- seq )
[
+ "callbacks" "alien.compiler" lookup ,
+
{
bootstrap.stage2:bootstrap-time
continuations:error
{
gensym
+ name>char-hook
classes:class-and-cache
classes:class-not-cache
classes:class-or-cache
vocabs:load-vocab-hook
word
} %
+
+ { } { "optimizer.math.partial" } strip-vocab-globals %
] when
strip-prettyprint? [
sequences math namespaces.private continuations.private
concurrency.messaging quotations kernel.private words
sequences.private assocs models arrays accessors
-generic generic.standard ;
+generic generic.standard definitions ;
IN: tools.walker
SYMBOL: show-walker-hook ! ( status continuation thread -- )
{ [ dup "step-into" word-prop ] [ "step-into" word-prop call ] }
{ [ dup standard-generic? ] [ effective-method (step-into-execute) ] }
{ [ dup hook-generic? ] [ effective-method (step-into-execute) ] }
+ { [ dup uses \ suspend swap member? ] [ execute break ] }
{ [ dup primitive? ] [ execute break ] }
[ word-def (step-into-quot) ]
} cond ;
SYMBOL: step-all
SYMBOL: step-into-all
SYMBOL: step-back
-SYMBOL: detach
SYMBOL: abandon
SYMBOL: call-in
{
>n ndrop >c c>
continue continue-with
- stop yield suspend sleep (spawn)
+ stop suspend (spawn)
} [
dup [ execute break ] curry
"step-into" set-word-prop
+running+ set-status ;
: walker-stopped ( -- )
- +stopped+ set-status
- [ status +stopped+ eq? ]
- [ [ drop f ] handle-synchronous ]
- [ ] while ;
+ +stopped+ set-status ;
: step-into-all-loop ( -- )
+running+ set-status
! Copyright (c) 2005 Mackenzie Straight.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel tools.test trees.splay math namespaces assocs
-sequences random ;
+sequences random sets ;
IN: trees.splay.tests
: randomize-numeric-splay-tree ( splay-tree -- )
100 [ drop 100 random swap at drop ] with each ;
: make-numeric-splay-tree ( n -- splay-tree )
- <splay> [ [ dupd set-at ] curry each ] keep ;
+ <splay> [ [ conjoin ] curry each ] keep ;
[ t ] [
100 make-numeric-splay-tree dup randomize-numeric-splay-tree
{ $description "Renders a character and outputs a pointer to the bitmap." } ;
HELP: <char-sprite>
-{ $values { "font" font } { "char" "a non-negative integer" } { "sprite" sprite } }
+{ $values { "open-font" font } { "char" "a non-negative integer" } { "sprite" sprite } }
{ $description "Renders a character to an OpenGL texture and records a display list which draws a quad with this texture. This word allocates native resources which must be freed by " { $link free-sprites } "." } ;
HELP: (draw-string)
USING: alien alien.accessors alien.c-types arrays io kernel libc
math math.vectors namespaces opengl opengl.gl prettyprint assocs
sequences io.files io.styles continuations freetype
-ui.gadgets.worlds ui.render ui.backend byte-arrays ;
+ui.gadgets.worlds ui.render ui.backend byte-arrays accessors
+locals ;
IN: ui.freetype
] bind ;
M: freetype-renderer free-fonts ( world -- )
- dup world-handle select-gl-context
- world-fonts [ nip second free-sprites ] assoc-each ;
+ [ handle>> select-gl-context ]
+ [ fonts>> [ nip second free-sprites ] assoc-each ] bi ;
: ttf-name ( font style -- name )
2array H{
#! We use FT_New_Memory_Face, not FT_New_Face, since
#! FT_New_Face only takes an ASCII path name and causes
#! problems on localized versions of Windows
- freetype -rot 0 f <void*> [
+ [ freetype ] 2dip 0 f <void*> [
FT_New_Memory_Face freetype-error
] keep *void* ;
: font-units>pixels ( n font -- n )
face-size face-size-y-scale FT_MulFix ;
-: init-ascent ( font face -- )
- dup face-y-max swap font-units>pixels swap set-font-ascent ;
+: init-ascent ( font face -- font )
+ dup face-y-max swap font-units>pixels >>ascent ; inline
-: init-descent ( font face -- )
- dup face-y-min swap font-units>pixels swap set-font-descent ;
+: init-descent ( font face -- font )
+ dup face-y-min swap font-units>pixels >>descent ; inline
-: init-font ( font -- )
- dup font-handle 2dup init-ascent dupd init-descent
- dup font-ascent over font-descent - ft-ceil
- swap set-font-height ;
+: init-font ( font -- font )
+ dup handle>> init-ascent
+ dup handle>> init-descent
+ dup [ ascent>> ] [ descent>> ] bi - ft-ceil >>height ; inline
-: <font> ( handle -- font )
- H{ } clone
- { set-font-handle set-font-widths } font construct
- dup init-font ;
+: set-char-size ( handle size -- )
+ 0 swap 6 shift dpi get-global dup FT_Set_Char_Size freetype-error ;
-: (open-font) ( font -- open-font )
- first3 >r open-face dup 0 r> 6 shift
- dpi get-global dpi get-global FT_Set_Char_Size
- freetype-error <font> ;
+: <font> ( handle -- font )
+ font new
+ H{ } clone >>widths
+ over first2 open-face >>handle
+ dup handle>> rot third set-char-size
+ init-font ;
M: freetype-renderer open-font ( font -- open-font )
- freetype drop open-fonts get [ (open-font) ] cache ;
+ freetype drop open-fonts get [ <font> ] cache ;
: load-glyph ( font char -- glyph )
>r font-handle dup r> 0 FT_Load_Char
load-glyph dup
FT_RENDER_MODE_NORMAL FT_Render_Glyph freetype-error ;
-: copy-pixel ( bit tex -- bit tex )
- 255 f pick set-alien-unsigned-1 1+
- f pick alien-unsigned-1
- f pick set-alien-unsigned-1 >r 1+ r> 1+ ;
-
-: (copy-row) ( bit tex bitend texend -- bitend texend )
- >r pick over >= [
- 2nip r>
- ] [
- >r copy-pixel r> r> (copy-row)
- ] if ;
-
-: copy-row ( bit tex width width2 -- bitend texend width width2 )
- [ pick + >r pick + r> (copy-row) ] 2keep ;
-
-: copy-bitmap ( glyph texture -- )
- over glyph-bitmap-rows >r
- over glyph-bitmap-width dup next-power-of-2 2 *
- >r >r >r glyph-bitmap-buffer alien-address r> r> r> r>
- [ copy-row ] times 2drop 2drop ;
+:: copy-pixel ( i j bitmap texture -- i j )
+ 255 j texture set-char-nth
+ i bitmap char-nth j 1 + texture set-char-nth
+ i 1 + j 2 + ; inline
+
+:: (copy-row) ( i j bitmap texture end -- )
+ i end < [
+ i j bitmap texture copy-pixel
+ bitmap texture end (copy-row)
+ ] when ; inline
+
+:: copy-row ( i j bitmap texture width width2 -- i j )
+ i j bitmap texture i width + (copy-row)
+ i width +
+ j width2 + ; inline
+
+:: copy-bitmap ( glyph texture -- )
+ [let* | bitmap [ glyph glyph-bitmap-buffer ]
+ rows [ glyph glyph-bitmap-rows ]
+ width [ glyph glyph-bitmap-width ]
+ width2 [ width next-power-of-2 2 * ] |
+ 0 0
+ rows [ bitmap texture width width2 copy-row ] times
+ 2drop
+ ] ;
: bitmap>texture ( glyph sprite -- id )
tuck sprite-size2 * 2 * [
- alien-address [ copy-bitmap ] keep <alien> gray-texture
+ [ copy-bitmap ] keep gray-texture
] with-malloc ;
: glyph-texture-loc ( glyph font -- loc )
font-ascent swap glyph-hori-bearing-y - ft-floor 2array ;
: glyph-texture-size ( glyph -- dim )
- dup glyph-bitmap-width next-power-of-2
- swap glyph-bitmap-rows next-power-of-2 2array ;
+ [ glyph-bitmap-width next-power-of-2 ]
+ [ glyph-bitmap-rows next-power-of-2 ]
+ bi 2array ;
-: <char-sprite> ( font char -- sprite )
+: <char-sprite> ( open-font char -- sprite )
over >r render-glyph dup r> glyph-texture-loc
over glyph-size pick glyph-texture-size <sprite>
[ bitmap>texture ] keep [ init-sprite ] keep ;
-: draw-char ( open-font char sprites -- )
- [ dupd <char-sprite> ] cache nip
- sprite-dlist glCallList ;
+:: char-sprite ( open-font sprites char -- sprite )
+ char sprites [ open-font swap <char-sprite> ] cache ;
+
+: draw-char ( open-font sprites char loc -- )
+ GL_MODELVIEW [
+ 0 0 glTranslated
+ char-sprite sprite-dlist glCallList
+ ] do-matrix ;
+
+: char-widths ( open-font string -- widths )
+ [ char-width ] with { } map-as ;
+
+: scan-sums ( seq -- seq' )
+ 0 [ + ] accumulate nip ;
-: (draw-string) ( open-font sprites string loc -- )
+:: (draw-string) ( open-font sprites string loc -- )
GL_TEXTURE_2D [
- [
- [ >r 2dup r> swap draw-char ] each 2drop
+ loc [
+ string open-font string char-widths scan-sums [
+ [ open-font sprites ] 2dip draw-char
+ ] 2each
] with-translation
] do-enabled ;
-: font-sprites ( open-font world -- pair )
- world-fonts [ open-font H{ } clone 2array ] cache ;
+: font-sprites ( font world -- open-font sprites )
+ world-fonts [ open-font H{ } clone 2array ] cache first2 ;
M: freetype-renderer draw-string ( font string loc -- )
- >r >r world get font-sprites first2 r> r> (draw-string) ;
+ >r >r world get font-sprites r> r> (draw-string) ;
: run-char-widths ( open-font string -- widths )
- [ char-width ] with { } map-as
- dup 0 [ + ] accumulate nip swap 2 v/n v+ ;
+ char-widths [ scan-sums ] [ 2 v/n ] bi v+ ;
M: freetype-renderer x>offset ( x open-font string -- n )
dup >r run-char-widths [ <= ] with find drop
strings threads listener classes.tuple ui.commands ui.gadgets
ui.gadgets.editors ui.gadgets.presentations ui.gadgets.worlds
ui.gestures definitions calendar concurrency.flags
-concurrency.mailboxes ui.tools.workspace accessors ;
+concurrency.mailboxes ui.tools.workspace accessors sets ;
IN: ui.tools.interactor
! If waiting is t, we're waiting for user input, and invoking
] with-output-stream* ;
: add-interactor-history ( str interactor -- )
- over empty? [ 2drop ] [ interactor-history push-new ] if ;
+ over empty? [ 2drop ] [ interactor-history adjoin ] if ;
: interactor-continue ( obj interactor -- )
mailbox>> mailbox-put ;
[ execute ] 2with each ;\r
\r
[ f f f f ] [ "hello" "hi" test-equality ] unit-test\r
-[ t f f f ] [ "hello" "h\8ello" test-equality ] unit-test\r
+[ t f f f ] [ "hello" "h\u0000e9llo" test-equality ] unit-test\r
[ t t f f ] [ "hello" "HELLO" test-equality ] unit-test\r
[ t t t f ] [ "hello" "h e l l o." test-equality ] unit-test\r
[ t t t t ] [ "hello" "\0hello\0" test-equality ] unit-test\r
--- /dev/null
+Slava Pestov
--- /dev/null
+Tools for working with URLs (uniform resource locators)
--- /dev/null
+web
+network
--- /dev/null
+IN: urls.tests
+USING: urls tools.test tuple-syntax arrays kernel assocs ;
+
+[ "hello%20world" ] [ "hello world" url-encode ] unit-test
+[ "hello world" ] [ "hello%20world" url-decode ] unit-test
+[ "~hello world" ] [ "%7ehello+world" url-decode ] unit-test
+[ f ] [ "%XX%XX%XX" url-decode ] unit-test
+[ f ] [ "%XX%XX%X" url-decode ] unit-test
+
+[ "hello world" ] [ "hello+world" url-decode ] unit-test
+[ "hello world" ] [ "hello%20world" url-decode ] unit-test
+[ " ! " ] [ "%20%21%20" url-decode ] unit-test
+[ "hello world" ] [ "hello world%" url-decode ] unit-test
+[ "hello world" ] [ "hello world%x" url-decode ] unit-test
+[ "hello%20world" ] [ "hello world" url-encode ] unit-test
+[ "%20%21%20" ] [ " ! " url-encode ] unit-test
+
+[ "\u001234hi\u002045" ] [ "\u001234hi\u002045" url-encode url-decode ] unit-test
+
+[ "a=b&a=c" ] [ { { "a" { "b" "c" } } } assoc>query ] unit-test
+
+[ H{ { "a" "b" } } ] [ "a=b" query>assoc ] unit-test
+
+[ H{ { "a" { "b" "c" } } } ] [ "a=b&a=c" query>assoc ] unit-test
+
+[ "a=3" ] [ { { "a" 3 } } assoc>query ] unit-test
+
+: urls
+ {
+ {
+ TUPLE{ url
+ protocol: "http"
+ host: "www.apple.com"
+ port: 1234
+ path: "/a/path"
+ query: H{ { "a" "b" } }
+ anchor: "foo"
+ }
+ "http://www.apple.com:1234/a/path?a=b#foo"
+ }
+ {
+ TUPLE{ url
+ protocol: "http"
+ host: "www.apple.com"
+ path: "/a/path"
+ query: H{ { "a" "b" } }
+ anchor: "foo"
+ }
+ "http://www.apple.com/a/path?a=b#foo"
+ }
+ {
+ TUPLE{ url
+ protocol: "http"
+ host: "www.apple.com"
+ port: 1234
+ path: "/another/fine/path"
+ anchor: "foo"
+ }
+ "http://www.apple.com:1234/another/fine/path#foo"
+ }
+ {
+ TUPLE{ url
+ path: "/a/relative/path"
+ anchor: "foo"
+ }
+ "/a/relative/path#foo"
+ }
+ {
+ TUPLE{ url
+ path: "/a/relative/path"
+ }
+ "/a/relative/path"
+ }
+ {
+ TUPLE{ url
+ path: "a/relative/path"
+ }
+ "a/relative/path"
+ }
+ } ;
+
+urls [
+ [ 1array ] [ [ string>url ] curry ] bi* unit-test
+] assoc-each
+
+urls [
+ swap [ 1array ] [ [ url>string ] curry ] bi* unit-test
+] assoc-each
+
+[ "b" ] [ "a" "b" url-append-path ] unit-test
+
+[ "a/b" ] [ "a/c" "b" url-append-path ] unit-test
+
+[ "a/b" ] [ "a/" "b" url-append-path ] unit-test
+
+[ "/b" ] [ "a" "/b" url-append-path ] unit-test
+
+[ "/b" ] [ "a/b/" "/b" url-append-path ] unit-test
+
+[ "/xxx/bar" ] [ "/xxx/baz" "bar" url-append-path ] unit-test
+
+[
+ TUPLE{ url
+ protocol: "http"
+ host: "www.apple.com"
+ port: 1234
+ path: "/a/path"
+ }
+] [
+ TUPLE{ url
+ protocol: "http"
+ host: "www.apple.com"
+ port: 1234
+ path: "/foo"
+ }
+
+ TUPLE{ url
+ path: "/a/path"
+ }
+
+ derive-url
+] unit-test
+
+[
+ TUPLE{ url
+ protocol: "http"
+ host: "www.apple.com"
+ port: 1234
+ path: "/a/path/relative/path"
+ query: H{ { "a" "b" } }
+ anchor: "foo"
+ }
+] [
+ TUPLE{ url
+ protocol: "http"
+ host: "www.apple.com"
+ port: 1234
+ path: "/a/path/"
+ }
+
+ TUPLE{ url
+ path: "relative/path"
+ query: H{ { "a" "b" } }
+ anchor: "foo"
+ }
+
+ derive-url
+] unit-test
+
+[
+ TUPLE{ url
+ protocol: "http"
+ host: "www.apple.com"
+ port: 1234
+ path: "/a/path/relative/path"
+ query: H{ { "a" "b" } }
+ anchor: "foo"
+ }
+] [
+ TUPLE{ url
+ protocol: "http"
+ host: "www.apple.com"
+ port: 1234
+ path: "/a/path/"
+ }
+
+ TUPLE{ url
+ path: "relative/path"
+ query: H{ { "a" "b" } }
+ anchor: "foo"
+ }
+
+ derive-url
+] unit-test
+
+[
+ TUPLE{ url
+ protocol: "http"
+ host: "www.apple.com"
+ path: "/xxx/baz"
+ }
+] [
+ TUPLE{ url
+ protocol: "http"
+ host: "www.apple.com"
+ path: "/xxx/bar"
+ }
+
+ TUPLE{ url
+ path: "baz"
+ }
+
+ derive-url
+] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel unicode.categories combinators sequences splitting
+fry namespaces assocs arrays strings mirrors
+io.encodings.string io.encodings.utf8
+math math.parser accessors namespaces.lib ;
+IN: urls
+
+: url-quotable? ( ch -- ? )
+ #! In a URL, can this character be used without
+ #! URL-encoding?
+ {
+ { [ dup letter? ] [ t ] }
+ { [ dup LETTER? ] [ t ] }
+ { [ dup digit? ] [ t ] }
+ { [ dup "/_-.:" member? ] [ t ] }
+ [ f ]
+ } cond nip ; foldable
+
+: push-utf8 ( ch -- )
+ 1string utf8 encode
+ [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ;
+
+: url-encode ( str -- str )
+ [
+ [ dup url-quotable? [ , ] [ push-utf8 ] if ] each
+ ] "" make ;
+
+: url-decode-hex ( index str -- )
+ 2dup length 2 - >= [
+ 2drop
+ ] [
+ [ 1+ dup 2 + ] dip subseq hex> [ , ] when*
+ ] if ;
+
+: url-decode-% ( index str -- index str )
+ 2dup url-decode-hex [ 3 + ] dip ;
+
+: url-decode-+-or-other ( index str ch -- index str )
+ dup CHAR: + = [ drop CHAR: \s ] when , [ 1+ ] dip ;
+
+: url-decode-iter ( index str -- )
+ 2dup length >= [
+ 2drop
+ ] [
+ 2dup nth dup CHAR: % = [
+ drop url-decode-%
+ ] [
+ url-decode-+-or-other
+ ] if url-decode-iter
+ ] if ;
+
+: url-decode ( str -- str )
+ [ 0 swap url-decode-iter ] "" make utf8 decode ;
+
+: add-query-param ( value key assoc -- )
+ [
+ at [
+ {
+ { [ dup string? ] [ swap 2array ] }
+ { [ dup array? ] [ swap suffix ] }
+ { [ dup not ] [ drop ] }
+ } cond
+ ] when*
+ ] 2keep set-at ;
+
+: query>assoc ( query -- assoc )
+ dup [
+ "&" split H{ } clone [
+ [
+ [ "=" split1 [ dup [ url-decode ] when ] bi@ swap ] dip
+ add-query-param
+ ] curry each
+ ] keep
+ ] when ;
+
+: assoc>query ( hash -- str )
+ [
+ {
+ { [ dup number? ] [ number>string 1array ] }
+ { [ dup string? ] [ 1array ] }
+ { [ dup sequence? ] [ ] }
+ } cond
+ ] assoc-map
+ [
+ [
+ [ url-encode ] dip
+ [ url-encode "=" swap 3append , ] with each
+ ] assoc-each
+ ] { } make "&" join ;
+
+TUPLE: url protocol host port path query anchor ;
+
+: query-param ( request key -- value )
+ swap query>> at ;
+
+: set-query-param ( request value key -- request )
+ pick query>> set-at ;
+
+: parse-host ( string -- host port )
+ ":" split1 [ url-decode ] [
+ dup [
+ string>number
+ dup [ "Invalid port" throw ] unless
+ ] when
+ ] bi* ;
+
+: parse-host-part ( protocol rest -- string' )
+ [ "protocol" set ] [
+ "//" ?head [ "Invalid URL" throw ] unless
+ "/" split1 [
+ parse-host [ "host" set ] [ "port" set ] bi*
+ ] [ "/" prepend ] bi*
+ ] bi* ;
+
+: string>url ( string -- url )
+ [
+ ":" split1 [ parse-host-part ] when*
+ "#" split1 [
+ "?" split1 [ query>assoc "query" set ] when*
+ url-decode "path" set
+ ] [
+ url-decode "anchor" set
+ ] bi*
+ ] url make-object ;
+
+: unparse-host-part ( protocol -- )
+ %
+ "://" %
+ "host" get url-encode %
+ "port" get [ ":" % # ] when*
+ "path" get "/" head? [ "Invalid URL" throw ] unless ;
+
+: url>string ( url -- string )
+ [
+ <mirror> [
+ "protocol" get [ unparse-host-part ] when*
+ "path" get url-encode %
+ "query" get [ "?" % assoc>query % ] when*
+ "anchor" get [ "#" % url-encode % ] when*
+ ] bind
+ ] "" make ;
+
+: url-append-path ( path1 path2 -- path )
+ {
+ { [ dup "/" head? ] [ nip ] }
+ { [ dup empty? ] [ drop ] }
+ { [ over "/" tail? ] [ append ] }
+ { [ "/" pick start not ] [ nip ] }
+ [ [ "/" last-split1 drop "/" ] dip 3append ]
+ } cond ;
+
+: derive-url ( base url -- url' )
+ [ clone dup ] dip
+ 2dup [ path>> ] bi@ url-append-path
+ [ [ <mirror> ] bi@ [ nip ] assoc-filter update ] dip
+ >>path ;
+
+: relative-url ( url -- url' )
+ clone f >>protocol f >>host f >>port ;
--- /dev/null
+IN: validators.tests
+USING: kernel sequences tools.test validators accessors
+namespaces assocs ;
+
+: with-validation ( quot -- messages )
+ [
+ init-validation
+ call
+ validation-messages get
+ named-validation-messages get >alist append
+ ] with-scope ; inline
+
+[ "" v-one-line ] must-fail
+[ "hello world" ] [ "hello world" v-one-line ] unit-test
+[ "hello\nworld" v-one-line ] must-fail
+
+[ "" v-one-word ] must-fail
+[ "hello" ] [ "hello" v-one-word ] unit-test
+[ "hello world" v-one-word ] must-fail
+
+[ "foo" v-number ] must-fail
+[ 123 ] [ "123" v-number ] unit-test
+[ 123 ] [ "123" v-integer ] unit-test
+
+[ "1.0" v-integer ] [ "must be an integer" = ] must-fail-with
+
+[ "slava@factorcode.org" ] [
+ "slava@factorcode.org" v-email
+] unit-test
+
+[ "slava+foo@factorcode.org" ] [
+ "slava+foo@factorcode.org" v-email
+] unit-test
+
+[ "slava@factorcode.o" v-email ]
+[ "invalid e-mail" = ] must-fail-with
+
+[ "sla@@factorcode.o" v-email ]
+[ "invalid e-mail" = ] must-fail-with
+
+[ "slava@factorcodeorg" v-email ]
+[ "invalid e-mail" = ] must-fail-with
+
+[ "http://www.factorcode.org" ]
+[ "http://www.factorcode.org" v-url ] unit-test
+
+[ "http:/www.factorcode.org" v-url ]
+[ "invalid URL" = ] must-fail-with
+
+[ 4561261212345467 ] [ "4561261212345467" v-credit-card ] unit-test
+
+[ 4561261212345467 ] [ "4561-2612-1234-5467" v-credit-card ] unit-test
+
+[ 0 ] [ "0000000000000000" v-credit-card ] unit-test
+
+[ "000000000" v-credit-card ] must-fail
+
+[ "0000000000000000000000000" v-credit-card ] must-fail
+
+[ "4561_2612_1234_5467" v-credit-card ] must-fail
+
+[ "4561-2621-1234-5467" v-credit-card ] must-fail
+
+
+[ 14 V{ } ] [
+ [
+ "14" "age" [ v-number 13 v-min-value 100 v-max-value ] validate
+ ] with-validation
+] unit-test
+
+[ f t ] [
+ [
+ "140" "age" [ v-number 13 v-min-value 100 v-max-value ] validate
+ ] with-validation first
+ [ first "age" = ]
+ [ second validation-error? ]
+ [ second value>> "140" = ]
+ tri and and
+] unit-test
+
+TUPLE: person name age ;
+
+person {
+ { "name" [ ] }
+ { "age" [ v-number 13 v-min-value 100 v-max-value ] }
+} define-validators
+
+[ t t ] [
+ [
+ { { "age" "" } } required-values
+ validation-failed?
+ ] with-validation first
+ [ first "age" = ]
+ [ second validation-error? ]
+ [ second message>> "required" = ]
+ tri and and
+] unit-test
+
+[ H{ { "a" 123 } } f V{ } ] [
+ [
+ H{
+ { "a" "123" }
+ { "b" "c" }
+ { "c" "d" }
+ }
+ H{
+ { "a" [ v-integer ] }
+ } validate-values
+ validation-failed?
+ ] with-validation
+] unit-test
+
+[ t "foo" ] [
+ [
+ "foo" validation-error
+ validation-failed?
+ ] with-validation first message>>
+] unit-test
--- /dev/null
+! Copyright (C) 2006, 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel continuations sequences sequences.lib math
+namespaces sets math.parser math.ranges assocs regexp fry
+unicode.categories arrays hashtables words combinators mirrors
+classes quotations xmode.catalog ;
+IN: validators
+
+: v-default ( str def -- str )
+ over empty? spin ? ;
+
+: v-required ( str -- str )
+ dup empty? [ "required" throw ] when ;
+
+: v-optional ( str quot -- str )
+ over empty? [ 2drop f ] [ call ] if ; inline
+
+: v-min-length ( str n -- str )
+ over length over < [
+ [ "must be at least " % # " characters" % ] "" make
+ throw
+ ] [
+ drop
+ ] if ;
+
+: v-max-length ( str n -- str )
+ over length over > [
+ [ "must be no more than " % # " characters" % ] "" make
+ throw
+ ] [
+ drop
+ ] if ;
+
+: v-number ( str -- n )
+ dup string>number [ ] [ "must be a number" throw ] ?if ;
+
+: v-integer ( str -- n )
+ v-number dup integer? [ "must be an integer" throw ] unless ;
+
+: v-min-value ( x n -- x )
+ 2dup < [
+ [ "must be at least " % # ] "" make throw
+ ] [
+ drop
+ ] if ;
+
+: v-max-value ( x n -- x )
+ 2dup > [
+ [ "must be no more than " % # ] "" make throw
+ ] [
+ drop
+ ] if ;
+
+: v-regexp ( str what regexp -- str )
+ >r over r> matches?
+ [ drop ] [ "invalid " prepend throw ] if ;
+
+: v-email ( str -- str )
+ #! From http://www.regular-expressions.info/email.html
+ 60 v-max-length
+ "e-mail"
+ R' [A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}'i
+ v-regexp ;
+
+: v-url ( str -- str )
+ "URL"
+ R' (ftp|http|https)://(\w+:?\w*@)?(\S+)(:[0-9]+)?(/|/([\w#!:.?+=&%@!\-/]))?'
+ v-regexp ;
+
+: v-captcha ( str -- str )
+ dup empty? [ "must remain blank" throw ] unless ;
+
+: v-one-line ( str -- str )
+ v-required
+ dup "\r\n" intersect empty?
+ [ "must be a single line" throw ] unless ;
+
+: v-one-word ( str -- str )
+ v-required
+ dup [ alpha? ] all?
+ [ "must be a single word" throw ] unless ;
+
+: v-username ( str -- str )
+ 2 v-min-length 16 v-max-length v-one-word ;
+
+: v-password ( str -- str )
+ 6 v-min-length 40 v-max-length v-one-line ;
+
+: v-mode ( str -- str )
+ dup mode-names member? [
+ "not a valid syntax mode" throw
+ ] unless ;
+
+: luhn? ( n -- ? )
+ string>digits <reversed>
+ [ odd? [ 2 * 10 /mod + ] when ] map-index
+ sum 10 mod 0 = ;
+
+: v-credit-card ( str -- n )
+ "- " diff
+ dup CHAR: 0 CHAR: 9 [a,b] diff empty? [
+ 13 v-min-length
+ 16 v-max-length
+ dup luhn? [ string>number ] [
+ "card number check failed" throw
+ ] if
+ ] [
+ "invalid credit card number format" throw
+ ] if ;
+
+SYMBOL: validation-messages
+SYMBOL: named-validation-messages
+
+: init-validation ( -- )
+ V{ } clone validation-messages set
+ H{ } clone named-validation-messages set ;
+
+: (validation-message) ( obj -- )
+ validation-messages get push ;
+
+: (validation-message-for) ( obj name -- )
+ named-validation-messages get set-at ;
+
+TUPLE: validation-message message ;
+
+C: <validation-message> validation-message
+
+: validation-message ( string -- )
+ <validation-message> (validation-message) ;
+
+: validation-message-for ( string name -- )
+ [ <validation-message> ] dip (validation-message-for) ;
+
+TUPLE: validation-error message value ;
+
+C: <validation-error> validation-error
+
+: validation-error ( message -- )
+ f <validation-error> (validation-message) ;
+
+: validation-error-for ( message value name -- )
+ [ <validation-error> ] dip (validation-message-for) ;
+
+: validation-failed? ( -- ? )
+ validation-messages get [ validation-error? ] contains?
+ named-validation-messages get [ nip validation-error? ] assoc-contains?
+ or ;
+
+: define-validators ( class validators -- )
+ >hashtable "validators" set-word-prop ;
+
+: validate ( value name quot -- result )
+ '[ drop @ ] [ -rot validation-error-for f ] recover ; inline
+
+: required-values ( assoc -- )
+ [ swap [ v-required ] validate drop ] assoc-each ;
+
+: validate-values ( assoc validators -- assoc' )
+ swap '[ [ [ dup , at ] keep ] dip validate ] assoc-map ;
-USING: math kernel accessors http.server http.server.actions
-http.server.sessions http.server.templating
-http.server.templating.fhtml locals ;
+USING: math kernel accessors html.components
+http.server http.server.actions
+http.server.sessions html.templates.chloe fry ;
IN: webapps.counter
SYMBOL: count
TUPLE: counter-app < dispatcher ;
-M: counter-app init-session*
- drop 0 count sset ;
+M: counter-app init-session* drop 0 count sset ;
-:: <counter-action> ( quot -- action )
- <action> [
- count quot schange
- "" f <standard-redirect>
- ] >>display ;
+: <counter-action> ( quot -- action )
+ <action>
+ swap '[ count , schange "" f <standard-redirect> ] >>submit ;
: counter-template ( -- template )
- "resource:extra/webapps/counter/counter.fhtml" <fhtml> ;
+ "resource:extra/webapps/counter/counter.xml" <chloe> ;
: <display-action> ( -- action )
- <action> [ counter-template serve-template ] >>display ;
+ <page-action>
+ [ count sget "counter" set-value ] >>init
+ counter-template >>template ;
: <counter-app> ( -- responder )
counter-app new-dispatcher
+++ /dev/null
-<% USING: io math.parser http.server.sessions webapps.counter ; %>
-
-<html>
- <body>
- <h1><% count sget number>string write %></h1>
-
- <a href="inc">++</a>
- <a href="dec">--</a>
- </body>
-</html>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+
+ <body>
+ <h1><t:label t:name="counter" /></h1>
+
+ <t:button t:action="$counter-app/inc">++</t:button>
+ <t:button t:action="$counter-app/dec">--</t:button>
+ </body>
+
+</t:chloe>
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences assocs io.files io.sockets
+io.server
namespaces db db.sqlite smtp
http.server
http.server.db
http.server.flows
http.server.sessions
-http.server.auth.admin
http.server.auth.login
http.server.auth.providers.db
http.server.boilerplate
-http.server.templating.chloe
+html.templates.chloe
webapps.pastebin
webapps.planet
-webapps.todo ;
+webapps.todo
+webapps.wiki
+webapps.user-admin ;
IN: webapps.factor-website
: test-db "resource:test.db" sqlite-db ;
init-annotations-table
init-blog-table
+ init-postings-table
init-todo-table
+
+ init-articles-table
+ init-revisions-table
] with-db ;
: <factor-website> ( -- responder )
- <dispatcher>
+ <dispatcher>
<todo-list> "todo" add-responder
<pastebin> "pastebin" add-responder
<planet-factor> "planet" add-responder
+ <wiki> "wiki" add-responder
<user-admin> "user-admin" add-responder
<login>
users-in-db >>users
<factor-website> main-responder set-global ;
-: start-factor-website
+: start-factor-website ( -- )
test-db start-expiring-sessions
- "planet" main-responder get responders>> at test-db start-update-task
+ test-db start-update-task
8812 httpd ;
.error { color: #a00; }
+.errors li { color: #a00; }
+
.field-label {
text-align: right;
}
}
.description {
- border: 1px dashed #ccc;
- background-color: #f5f5f5;
padding: 5px;
color: #000;
}
+.description pre {
+ border: 1px dashed #ccc;
+ background-color: #f5f5f5;
+}
+
.description p:first-child {
margin-top: 0px;
}
.description p:last-child {
margin-bottom: 0px;
}
+
+.description table, .description td {
+ border-color: #666;
+ border-style: solid;
+}
+
+.description table {
+ border-width: 0 0 1px 1px;
+ border-spacing: 0;
+ border-collapse: collapse;
+}
+
+.description td {
+ margin: 0;
+ padding: 4px;
+ border-width: 1px 1px 0 0;
+}
+
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <h2>Annotation: <t:view t:component="summary" /></h2>
-
- <table>
- <tr><th class="field-label">Author: </th><td><t:view t:component="author" /></td></tr>
- <tr><th class="field-label">Mode: </th><td><t:view t:component="mode" /></td></tr>
- <tr><th class="field-label">Date: </th><td><t:view t:component="date" /></td></tr>
- </table>
-
- <pre class="description"><t:view t:component="contents" /></pre>
-
- <t:button t:action="$pastebin/delete-annotation" t:for="aid" class="link-button link">Delete Annotation</t:button>
-
-</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <t:title>New Annotation</t:title>
-
- <t:form t:action="$pastebin/annotate" t:for="id">
-
- <table>
- <tr><th class="field-label">Summary: </th><td><t:edit t:component="summary" /></td></tr>
- <tr><th class="field-label">Author: </th><td><t:edit t:component="author" /></td></tr>
- <tr><th class="field-label">Mode: </th><td><t:edit t:component="mode" /></td></tr>
- <tr><th class="field-label big-field-label">Description:</th><td><t:edit t:component="contents" /></td></tr>
- <tr><th class="field-label">Captcha: </th><td><t:edit t:component="captcha" /></td></tr>
- <tr>
- <td></td>
- <td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.</td>
- </tr>
- </table>
-
- <input type="SUBMIT" value="Done" />
- </t:form>
-
-</t:chloe>
<t:form t:action="$pastebin/new-paste">
<table>
- <tr><th class="field-label">Summary: </th><td><t:edit t:component="summary" /></td></tr>
- <tr><th class="field-label">Author: </th><td><t:edit t:component="author" /></td></tr>
- <tr><th class="field-label">Mode: </th><td><t:edit t:component="mode" /></td></tr>
- <tr><th class="field-label big-field-label">Description: </th><td><t:edit t:component="contents" /></td></tr>
- <tr><th class="field-label">Captcha: </th><td><t:edit t:component="captcha" /></td></tr>
+ <tr><th class="field-label">Summary: </th><td><t:field t:name="summary" /></td></tr>
+ <tr><th class="field-label">Author: </th><td><t:field t:name="author" /></td></tr>
+ <tr><th class="field-label">Mode: </th><td><t:choice t:name="mode" t:choices="modes" /></td></tr>
+ <tr><th class="field-label big-field-label">Body: </th><td><t:textarea t:name="contents" t:rows="20" t:cols="60" /></td></tr>
+ <tr><th class="field-label">Captcha: </th><td><t:field t:name="captcha" /></td></tr>
<tr>
<td></td>
<td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.</td>
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <t:title>Pastebin</t:title>
-
- <table width="100%">
- <th align="left" width="50%">Summary:</th>
- <th align="left" width="100">Paste by:</th>
- <th align="left" width="200">Date:</th>
-
- <t:summary t:component="pastes" />
- </table>
-
-</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <tr>
- <td><t:a t:href="$pastebin/view-paste" t:query="id"><t:view t:component="summary" /></t:a></td>
- <td><t:view t:component="author" /></td>
- <td><t:view t:component="date" /></td>
- </tr>
-
-</t:chloe>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
- <t:title>Paste: <t:view t:component="summary" /></t:title>
+ <t:atom t:title="Paste - Atom" t:href="$pastebin/paste.atom" t:query="id" />
+
+ <t:title>Paste: <t:label t:name="summary" /></t:title>
<table>
- <tr><th class="field-label">Author: </th><td><t:view t:component="author" /></td></tr>
- <tr><th class="field-label">Mode: </th><td><t:view t:component="mode" /></td></tr>
- <tr><th class="field-label">Date: </th><td><t:view t:component="date" /></td></tr>
+ <tr><th class="field-label">Author: </th><td><t:label t:name="author" /></td></tr>
+ <tr><th class="field-label">Mode: </th><td><t:label t:name="mode" /></td></tr>
+ <tr><th class="field-label">Date: </th><td><t:label t:name="date" /></td></tr>
</table>
- <pre class="description"><t:view t:component="contents" /></pre>
+ <pre class="description"><t:code t:name="contents" t:mode="modes" /></pre>
<t:button t:action="$pastebin/delete-paste" t:for="id" class="link-button link">Delete Paste</t:button>
|
<t:a t:href="$pastebin/annotate" t:query="id">Annotate</t:a>
- <t:view t:component="annotations" />
+ <t:each-tuple t:values="annotations">
+
+ <h2>Annotation: <t:label t:name="summary" /></h2>
+
+ <table>
+ <tr><th class="field-label">Author: </th><td><t:label t:name="author" /></td></tr>
+ <tr><th class="field-label">Mode: </th><td><t:label t:name="mode" /></td></tr>
+ <tr><th class="field-label">Date: </th><td><t:label t:name="date" /></td></tr>
+ </table>
+
+ <pre class="description"><t:code t:name="contents" t:mode="mode"/></pre>
+
+ <t:button t:action="$pastebin/delete-annotation" t:for="aid" class="link-button link">Delete Annotation</t:button>
+
+ </t:each-tuple>
+
+ <t:bind-assoc t:name="new-annotation">
+
+ <h2>New Annotation</h2>
+
+ <t:form t:action="$pastebin/new-annotation" t:for="id">
+
+ <table>
+ <tr><th class="field-label">Summary: </th><td><t:field t:name="summary" /></td></tr>
+ <tr><th class="field-label">Author: </th><td><t:field t:name="author" /></td></tr>
+ <tr><th class="field-label">Mode: </th><td><t:choice t:name="mode" t:choices="modes" /></td></tr>
+ <tr><th class="field-label big-field-label">Body:</th><td><t:textarea t:name="contents" t:rows="20" t:cols="60" /></td></tr>
+ <tr><th class="field-label">Captcha: </th><td><t:field t:name="captcha" /></td></tr>
+ <tr>
+ <td></td>
+ <td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.</td>
+ </tr>
+ </table>
+
+ <input type="SUBMIT" value="Done" />
+ </t:form>
+
+ </t:bind-assoc>
+
</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:style t:include="resource:extra/webapps/pastebin/pastebin.css" />
+
+ <div class="navbar">
+
+ <t:a t:href="$pastebin/list">Pastes</t:a>
+ | <t:a t:href="$pastebin/new-paste">New Paste</t:a>
+
+ <t:if t:code="http.server.sessions:uid">
+
+ <t:if t:code="http.server.auth.login:allow-edit-profile?">
+ | <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
+ </t:if>
+
+ | <t:button t:action="$login/logout" t:flow="begin" class="link-button link">Logout</t:button>
+
+ </t:if>
+
+ </div>
+
+ <h1><t:write-title /></h1>
+
+ <t:call-next-template />
+
+</t:chloe>
+! Copyright (C) 2007, 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
USING: namespaces assocs sorting sequences kernel accessors
-hashtables sequences.lib locals db.types db.tuples db
-calendar calendar.format rss xml.writer
-xmode.catalog
+hashtables sequences.lib db.types db.tuples db combinators
+calendar calendar.format math.parser rss xml.writer
+xmode.catalog validators html.components html.templates.chloe
http.server
-http.server.crud
http.server.actions
-http.server.components
-http.server.components.code
-http.server.templating.chloe
http.server.auth
http.server.auth.login
-http.server.boilerplate
-http.server.validators
-http.server.forms ;
+http.server.boilerplate ;
IN: webapps.pastebin
-: <mode> ( id -- component )
- modes keys natural-sort <choice> ;
+! ! !
+! DOMAIN MODEL
+! ! !
-: pastebin-template ( name -- template )
- "resource:extra/webapps/pastebin/" swap ".xml" 3append <chloe> ;
-
-TUPLE: paste id summary author mode date contents annotations captcha ;
+TUPLE: entity id summary author mode date contents ;
-paste "PASTE"
+entity f
{
{ "id" "ID" INTEGER +db-assigned-id+ }
{ "summary" "SUMMARY" { VARCHAR 256 } +not-null+ }
{ "contents" "CONTENTS" TEXT +not-null+ }
} define-persistent
+TUPLE: paste < entity annotations ;
+
+\ paste "PASTES" { } define-persistent
+
: <paste> ( id -- paste )
- paste new
+ \ paste new
swap >>id ;
: pastes ( -- pastes )
f <paste> select-tuples ;
-TUPLE: annotation aid id summary author mode contents date captcha ;
+TUPLE: annotation < entity parent ;
-annotation "ANNOTATION"
+annotation "ANNOTATIONS"
{
- { "aid" "AID" INTEGER +db-assigned-id+ }
- { "id" "ID" INTEGER +not-null+ }
- { "summary" "SUMMARY" { VARCHAR 256 } +not-null+ }
- { "author" "AUTHOR" { VARCHAR 256 } +not-null+ }
- { "mode" "MODE" { VARCHAR 256 } +not-null+ }
- { "date" "DATE" DATETIME +not-null+ }
- { "contents" "CONTENTS" TEXT +not-null+ }
+ { "parent" "PARENT" INTEGER +not-null+ }
} define-persistent
-: <annotation> ( id aid -- annotation )
+: <annotation> ( parent id -- annotation )
annotation new
- swap >>aid
- swap >>id ;
+ swap >>id
+ swap >>parent ;
: fetch-annotations ( paste -- paste )
dup annotations>> [
dup id>> f <annotation> select-tuples >>annotations
] unless ;
-: <annotation-form> ( -- form )
- "annotation" <form>
- "annotation" pastebin-template >>view-template
- "id" <integer>
- hidden >>renderer
- add-field
- "aid" <integer>
- hidden >>renderer
- add-field
- "summary" <string> add-field
- "author" <string> add-field
- "mode" <mode> add-field
- "contents" "mode" <code> add-field
- "date" <date> add-field ;
-
-: <new-annotation-form> ( -- form )
- "annotation" <form>
- "new-annotation" pastebin-template >>edit-template
- "id" <integer>
- hidden >>renderer
- t >>required add-field
- "summary" <string>
- t >>required add-field
- "author" <string>
- t >>required
- add-field
- "mode" <mode>
- "factor" >>default
- t >>required
- add-field
- "contents" "mode" <code>
- t >>required add-field
- "captcha" <captcha> add-field ;
-
-: <paste-form> ( -- form )
- "paste" <form>
- "paste" pastebin-template >>view-template
- "paste-summary" pastebin-template >>summary-template
- "id" <integer>
- hidden >>renderer add-field
- "summary" <string> add-field
- "author" <string> add-field
- "mode" <mode> add-field
- "date" <date> add-field
- "contents" "mode" <code> add-field
- "annotations" <annotation-form> +plain+ <list> add-field ;
-
-: <new-paste-form> ( -- form )
- "paste" <form>
- "new-paste" pastebin-template >>edit-template
- "summary" <string>
- t >>required add-field
- "author" <string>
- t >>required add-field
- "mode" <mode>
- "factor" >>default
- t >>required
- add-field
- "contents" "mode" <code>
- t >>required add-field
- "captcha" <captcha> add-field ;
-
-: <paste-list-form> ( -- form )
- "pastebin" <form>
- "paste-list" pastebin-template >>view-template
- "pastes" <paste-form> +plain+ <list> add-field ;
-
-:: <paste-list-action> ( -- action )
- [let | form [ <paste-list-form> ] |
- <action>
- [
- blank-values
+: paste ( id -- paste )
+ <paste> select-tuple fetch-annotations ;
- pastes "pastes" set-value
+: <id-redirect> ( id next -- response )
+ swap "id" associate <standard-redirect> ;
- form view-form
- ] >>display
- ] ;
+! ! !
+! LINKS, ETC
+! ! !
-:: <annotate-action> ( form ctor next -- action )
- <action>
- { { "id" [ v-number ] } } >>get-params
+: pastebin-link ( -- url )
+ "$pastebin/list" f link>string ;
- [
- "id" get f ctor call
-
- from-tuple form set-defaults
- ] >>init
+GENERIC: entity-link ( entity -- url )
- [ form edit-form ] >>display
+M: paste entity-link
+ id>> "id" associate "$pastebin/paste" swap link>string ;
- [
- f f ctor call from-tuple
+M: annotation entity-link
+ [ parent>> "parent" associate "$pastebin/paste" swap link>string ]
+ [ id>> number>string "#" prepend ] bi
+ append ;
- form validate-form
+: pastebin-template ( name -- template )
+ "resource:extra/webapps/pastebin/" swap ".xml" 3append <chloe> ;
- values-tuple insert-tuple
+! ! !
+! PASTE LIST
+! ! !
- "id" value next <id-redirect>
- ] >>submit ;
+: <pastebin-action> ( -- action )
+ <page-action>
+ [ pastes "pastes" set-value ] >>init
+ "pastebin" pastebin-template >>template ;
-: pastebin-feed-entries ( -- entries )
- pastes <reversed> 20 short head [
- [ summary>> ]
- [ "$pastebin/view-paste" swap id>> "id" associate link>string ]
- [ date>> ] tri
- f swap <entry>
+: pastebin-feed-entries ( seq -- entries )
+ <reversed> 20 short head [
+ entry new
+ swap
+ [ summary>> >>title ]
+ [ date>> >>pub-date ]
+ [ entity-link >>link ]
+ tri
] map ;
: pastebin-feed ( -- feed )
feed new
"Factor Pastebin" >>title
- "http://paste.factorcode.org" >>link
- pastebin-feed-entries >>entries ;
+ pastebin-link >>link
+ pastes pastebin-feed-entries >>entries ;
-: <feed-action> ( -- action )
- <action>
- [
- "text/xml" <content>
- [ pastebin-feed feed>xml write-xml ] >>body
- ] >>display ;
+: <pastebin-feed-action> ( -- action )
+ <feed-action> [ pastebin-feed ] >>feed ;
-:: <view-paste-action> ( form ctor -- action )
- <action>
- { { "id" [ v-number ] } } >>get-params
+! ! !
+! PASTES
+! ! !
- [ "id" get ctor call select-tuple fetch-annotations from-tuple ] >>init
+: <paste-action> ( -- action )
+ <page-action>
+ [
+ validate-integer-id
+ "id" value paste from-tuple
+
+ "id" value
+ "new-annotation" [
+ "id" set-value
+ mode-names "modes" set-value
+ "factor" "mode" set-value
+ ] nest-values
+ ] >>init
- [ form view-form ] >>display ;
+ "paste" pastebin-template >>template ;
-:: <delete-paste-action> ( ctor next -- action )
- <action>
- { { "id" [ v-number ] } } >>post-params
+: paste-feed-entries ( paste -- entries )
+ fetch-annotations annotations>> pastebin-feed-entries ;
+: paste-feed ( paste -- feed )
+ feed new
+ swap
+ [ "Paste #" swap id>> number>string append >>title ]
+ [ entity-link >>link ]
+ [ paste-feed-entries >>entries ]
+ tri ;
+
+: <paste-feed-action> ( -- action )
+ <feed-action>
+ [ validate-integer-id ] >>init
+ [ "id" value paste annotations>> paste-feed ] >>feed ;
+
+: validate-entity ( -- )
+ {
+ { "summary" [ v-one-line ] }
+ { "author" [ v-one-line ] }
+ { "mode" [ v-mode ] }
+ { "contents" [ v-required ] }
+ { "captcha" [ v-captcha ] }
+ } validate-params ;
+
+: deposit-entity-slots ( tuple -- )
+ now >>date
+ { "summary" "author" "mode" "contents" } deposit-slots ;
+
+: <new-paste-action> ( -- action )
+ <page-action>
[
- "id" get ctor call delete-tuples
+ "factor" "mode" set-value
+ mode-names "modes" set-value
+ ] >>init
- "id" get f <annotation> delete-tuples
+ "new-paste" pastebin-template >>template
- next f <permanent-redirect>
+ [
+ validate-entity
+
+ f <paste>
+ [ deposit-entity-slots ]
+ [ insert-tuple ]
+ [ id>> "$pastebin/paste" <id-redirect> ]
+ tri
] >>submit ;
-:: <delete-annotation-action> ( ctor next -- action )
+: <delete-paste-action> ( -- action )
<action>
- { { "aid" [ v-number ] } } >>post-params
+ [ validate-integer-id ] >>validate
[
- f "aid" get ctor call select-tuple
- [ delete-tuples ] [ id>> next <id-redirect> ] bi
+ "id" value <paste> delete-tuples
+ "id" value f <annotation> delete-tuples
+ "$pastebin/list" f <permanent-redirect>
] >>submit ;
-:: <new-paste-action> ( form ctor next -- action )
- <action>
- [
- f ctor call from-tuple
-
- form set-defaults
- ] >>init
+! ! !
+! ANNOTATIONS
+! ! !
- [ form edit-form ] >>display
+: <new-annotation-action> ( -- action )
+ <page-action>
+ [
+ { { "id" [ v-integer ] } } validate-params
+ "id" value "$pastebin/paste" <id-redirect>
+ ] >>display
[
- f ctor call from-tuple
+ { { "id" [ v-integer ] } } validate-params
+ validate-entity
+ ] >>validate
- form validate-form
+ [
+ "id" value f <annotation>
+ [ deposit-entity-slots ]
+ [ insert-tuple ]
+ [
+ ! Add anchor here
+ parent>> "$pastebin/paste" <id-redirect>
+ ]
+ tri
+ ] >>submit ;
- values-tuple insert-tuple
+: <delete-annotation-action> ( -- action )
+ <action>
+ [ { { "id" [ v-number ] } } validate-params ] >>validate
- "id" value next <id-redirect>
+ [
+ f "id" value <annotation> select-tuple
+ [ delete-tuples ]
+ [ parent>> "$pastebin/paste" <id-redirect> ]
+ bi
] >>submit ;
TUPLE: pastebin < dispatcher ;
: <pastebin> ( -- responder )
pastebin new-dispatcher
- <paste-list-action> "list" add-main-responder
- <feed-action> "feed.xml" add-responder
- <paste-form> [ <paste> ] <view-paste-action> "view-paste" add-responder
- [ <paste> ] "$pastebin/list" <delete-paste-action> { can-delete-pastes? } <protected> "delete-paste" add-responder
- [ <annotation> ] "$pastebin/view-paste" <delete-annotation-action> { can-delete-pastes? } <protected> "delete-annotation" add-responder
- <paste-form> [ <paste> ] <view-paste-action> "$pastebin/view-paste" add-responder
- <new-paste-form> [ <paste> now >>date ] "$pastebin/view-paste" <new-paste-action> "new-paste" add-responder
- <new-annotation-form> [ <annotation> now >>date ] "$pastebin/view-paste" <annotate-action> "annotate" add-responder
+ <pastebin-action> "list" add-main-responder
+ <pastebin-feed-action> "list.atom" add-responder
+ <paste-action> "paste" add-responder
+ <paste-feed-action> "paste.atom" add-responder
+ <new-paste-action> "new-paste" add-responder
+ <delete-paste-action> { can-delete-pastes? } <protected> "delete-paste" add-responder
+ <new-annotation-action> "new-annotation" add-responder
+ <delete-annotation-action> { can-delete-pastes? } <protected> "delete-annotation" add-responder
<boilerplate>
- "pastebin" pastebin-template >>template ;
+ "pastebin-common" pastebin-template >>template ;
-: init-pastes-table paste ensure-table ;
+: init-pastes-table \ paste ensure-table ;
: init-annotations-table annotation ensure-table ;
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
- <t:atom t:title="Pastebin - Atom" t:href="$pastebin/feed.xml" />
-
- <t:style t:include="resource:extra/webapps/pastebin/pastebin.css" />
-
- <div class="navbar">
- <t:a t:href="$pastebin/list">Pastes</t:a>
- | <t:a t:href="$pastebin/new-paste">New Paste</t:a>
- | <t:a t:href="$pastebin/feed.xml">Atom Feed</t:a>
-
- <t:if t:code="http.server.sessions:uid">
-
- <t:if t:code="http.server.auth.login:allow-edit-profile?">
- | <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
- </t:if>
-
- | <t:button t:action="$login/logout" t:flow="begin" class="link-button link">Logout</t:button>
-
- </t:if>
-
- </div>
-
- <h1><t:write-title /></h1>
-
- <t:call-next-template />
+ <t:atom t:title="Pastebin - Atom" t:href="$pastebin/list.atom" />
+
+ <t:title>Pastebin</t:title>
+
+ <table width="100%">
+ <th align="left" width="50%">Summary:</th>
+ <th align="left" width="100">Paste by:</th>
+ <th align="left" width="200">Date:</th>
+
+ <t:each-tuple t:values="pastes">
+ <tr>
+ <td><t:a t:href="$pastebin/paste" t:query="id"><t:label t:name="summary" /></t:a></td>
+ <td><t:label t:name="author" /></td>
+ <td><t:label t:name="date" /></td>
+ </tr>
+ </t:each-tuple>
+ </table>
</t:chloe>
<t:title>Planet Factor Administration</t:title>
- <t:summary t:component="blogroll" />
+ <ul>
+ <t:each-tuple t:values="blogroll">
+ <li>
+ <t:a t:href="$planet-factor/admin/edit-blog" t:query="id">
+ <t:label t:name="name" />
+ </t:a>
+ </li>
+ </t:each-tuple>
+ </ul>
<p>
- <t:a t:href="$planet-factor/admin/edit-blog">Add Blog</t:a>
- | <t:a t:href="$planet-factor/admin/update">Update</t:a>
+ <t:a t:href="$planet-factor/admin/new-blog">Add Blog</t:a>
+ | <t:button t:action="$planet-factor/admin/update" class="link-button link">Update</t:button>
</p>
</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <t:a t:href="$planet-factor/admin/edit-blog" t:query="id"><t:view t:component="name" /></t:a>
-
-</t:chloe>
<tr>
<th class="field-label">Blog name:</th>
- <td><t:edit t:component="name" /></td>
+ <td><t:field t:name="name" /></td>
</tr>
<tr>
<th class="field-label">Home page:</th>
- <td><t:edit t:component="www-url" /></td>
+ <td><t:field t:name="www-url" /></td>
</tr>
<tr>
<th class="field-label">Feed:</th>
- <td><t:edit t:component="feed-url" /></td>
+ <td><t:field t:name="feed-url" /></td>
</tr>
</table>
</t:form>
<t:button t:action="$planet-factor/admin/delete-blog" t:for="id" class="link-button link">Delete</t:button>
+
</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:each-tuple t:values="postings">
+
+ <p class="news">
+ <strong><t:view t:component="title" /></strong> <br/>
+ <t:a value="link" t:session="none" class="more">Read More...</t:a>
+ </p>
+
+ </t:each-tuple>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Edit Blog</t:title>
+
+ <t:form t:action="$planet-factor/admin/new-blog">
+
+ <table>
+
+ <tr>
+ <th class="field-label">Blog name:</th>
+ <td><t:field t:name="name" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Home page:</th>
+ <td><t:field t:name="www-url" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Feed:</th>
+ <td><t:field t:name="feed-url" /></td>
+ </tr>
+
+ </table>
+
+ <input type="SUBMIT" value="Done" />
+
+ </t:form>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:style t:include="resource:extra/webapps/planet/planet.css" />
+
+ <div class="navbar">
+ <t:a t:href="$planet-factor/list">Front Page</t:a>
+ | <t:a t:href="$planet-factor/feed.xml">Atom Feed</t:a>
+ | <t:a t:href="$planet-factor/admin">Admin</t:a>
+
+ <t:if t:code="http.server.sessions:uid">
+ <t:if t:code="http.server.auth.login:allow-edit-profile?">
+ | <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
+ </t:if>
+
+ | <t:button t:action="$login/logout" t:flow="begin" class="link-button link">Logout</t:button>
+ </t:if>
+ </div>
+
+ <h1><t:write-title /></h1>
+
+ <t:call-next-template />
+
+</t:chloe>
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors sequences sorting locals math math.order
+USING: kernel accessors sequences sorting math math.order
calendar alarms logging concurrency.combinators namespaces
-sequences.lib db.types db.tuples db fry
+sequences.lib db.types db.tuples db fry locals hashtables
+html.components html.templates.chloe
rss xml.writer
+validators
http.server
-http.server.crud
-http.server.forms
http.server.actions
http.server.boilerplate
-http.server.templating.chloe
-http.server.components
http.server.auth.login
http.server.auth ;
IN: webapps.planet
-TUPLE: planet-factor < dispatcher postings ;
-
: planet-template ( name -- template )
"resource:extra/webapps/planet/" swap ".xml" 3append <chloe> ;
{ "feed-url" "FEEDURL" { VARCHAR 256 } +not-null+ }
} define-persistent
+! TUPLE: posting < entry id ;
+TUPLE: posting id title link description pub-date ;
+
+posting "POSTINGS"
+{
+ { "id" "ID" INTEGER +db-assigned-id+ }
+ { "title" "TITLE" { VARCHAR 256 } +not-null+ }
+ { "link" "LINK" { VARCHAR 256 } +not-null+ }
+ { "description" "DESCRIPTION" TEXT +not-null+ }
+ { "pub-date" "DATE" TIMESTAMP +not-null+ }
+} define-persistent
+
: init-blog-table blog ensure-table ;
+: init-postings-table posting ensure-table ;
+
: <blog> ( id -- todo )
blog new
swap >>id ;
: blogroll ( -- seq )
- f <blog> select-tuples [ [ name>> ] compare ] sort ;
-
-: <entry-form> ( -- form )
- "entry" <form>
- "entry" planet-template >>view-template
- "entry-summary" planet-template >>summary-template
- "title" <string> add-field
- "description" <html-text> add-field
- "pub-date" <date> add-field ;
-
-: <blog-form> ( -- form )
- "blog" <form>
- "edit-blog" planet-template >>edit-template
- "blog-admin-link" planet-template >>summary-template
- "id" <integer>
- hidden >>renderer
- add-field
- "name" <string>
- t >>required
- add-field
- "www-url" <url>
- t >>required
- add-field
- "feed-url" <url>
- t >>required
- add-field ;
-
-: <planet-factor-form> ( -- form )
- "planet-factor" <form>
- "postings" planet-template >>view-template
- "postings-summary" planet-template >>summary-template
- "postings" <entry-form> +plain+ <list> add-field
- "blogroll" "blog" <link> +unordered+ <list> add-field ;
-
-: <admin-form> ( -- form )
- "admin" <form>
- "admin" planet-template >>view-template
- "blogroll" <blog-form> +unordered+ <list> add-field ;
-
-:: <edit-blogroll-action> ( planet -- action )
- [let | form [ <admin-form> ] |
- <action>
- [
- blank-values
-
- blogroll "blogroll" set-value
-
- form view-form
- ] >>display
- ] ;
-
-:: <planet-action> ( planet -- action )
- [let | form [ <planet-factor-form> ] |
- <action>
- [
- blank-values
-
- planet postings>> "postings" set-value
- blogroll "blogroll" set-value
-
- form view-form
- ] >>display
- ] ;
-
-:: planet-feed ( planet -- feed )
+ f <blog> select-tuples
+ [ [ name>> ] compare ] sort ;
+
+: postings ( -- seq )
+ posting new select-tuples
+ [ [ pub-date>> ] compare invert-comparison ] sort ;
+
+: <edit-blogroll-action> ( -- action )
+ <page-action>
+ [ blogroll "blogroll" set-value ] >>init
+ "admin" planet-template >>template ;
+
+: <planet-action> ( -- action )
+ <page-action>
+ [
+ blogroll "blogroll" set-value
+ postings "postings" set-value
+ ] >>init
+
+ "planet" planet-template >>template ;
+
+: planet-feed ( -- feed )
feed new
"Planet Factor" >>title
"http://planet.factorcode.org" >>link
- planet postings>> 16 short head >>entries ;
+ postings >>entries ;
-:: <feed-action> ( planet -- action )
- <action>
- [
- "text/xml" <content>
- [ planet planet-feed feed>xml write-xml ] >>body
- ] >>display ;
+: <planet-feed-action> ( -- action )
+ <feed-action> [ planet-feed ] >>feed ;
-: <posting> ( name entry -- entry' )
- clone [ ": " swap 3append ] change-title ;
+:: <posting> ( entry name -- entry' )
+ posting new
+ name ": " entry title>> 3append >>title
+ entry link>> >>link
+ entry description>> >>description
+ entry pub-date>> >>pub-date ;
: fetch-feed ( url -- feed )
download-feed entries>> ;
\ fetch-feed DEBUG add-error-logging
: fetch-blogroll ( blogroll -- entries )
- dup
- [ feed-url>> fetch-feed ] parallel-map
- [ >r name>> r> [ <posting> ] with map ] 2map concat ;
+ [ [ feed-url>> fetch-feed ] parallel-map ] [ [ name>> ] map ] bi
+ [ '[ , <posting> ] map ] 2map concat ;
: sort-entries ( entries -- entries' )
- [ [ pub-date>> ] compare ] sort <reversed> ;
+ [ [ pub-date>> ] compare invert-comparison ] sort ;
+
+: update-cached-postings ( -- )
+ blogroll fetch-blogroll sort-entries 8 short head [
+ posting new delete-tuples
+ [ insert-tuple ] each
+ ] with-transaction ;
-: update-cached-postings ( planet -- )
- "webapps.planet" [
- blogroll fetch-blogroll sort-entries 8 short head
- >>postings drop
- ] with-logging ;
+: <update-action> ( -- action )
+ <action>
+ [
+ update-cached-postings
+ "" f <permanent-redirect>
+ ] >>submit ;
-:: <update-action> ( planet -- action )
+: <delete-blog-action> ( -- action )
<action>
+ [ validate-integer-id ] >>validate
+
[
- planet update-cached-postings
- "" f <temporary-redirect>
- ] >>display ;
+ "id" value <blog> delete-tuples
+ "$planet-factor/admin" f <standard-redirect>
+ ] >>submit ;
+
+: validate-blog ( -- )
+ {
+ { "name" [ v-one-line ] }
+ { "www-url" [ v-url ] }
+ { "feed-url" [ v-url ] }
+ } validate-params ;
-:: <planet-factor-admin> ( planet-factor -- responder )
- [let | blog-form [ <blog-form> ]
- blog-ctor [ [ <blog> ] ] |
- <dispatcher>
- planet-factor <edit-blogroll-action> >>default
+: <id-redirect> ( id next -- response )
+ swap "id" associate <standard-redirect> ;
- planet-factor <update-action> "update" add-responder
+: deposit-blog-slots ( blog -- )
+ { "name" "www-url" "feed-url" } deposit-slots ;
- ! Administrative CRUD
- blog-ctor "$planet-factor/admin" <delete-action> "delete-blog" add-responder
- blog-form blog-ctor "$planet-factor/admin" <edit-action> "edit-blog" add-responder
- ] ;
+: <new-blog-action> ( -- action )
+ <page-action>
+ "new-blog" planet-template >>template
+
+ [ validate-blog ] >>validate
+
+ [
+ f <blog>
+ [ deposit-blog-slots ]
+ [ insert-tuple ]
+ [ id>> "$planet-factor/admin/edit-blog" <id-redirect> ]
+ tri
+ ] >>submit ;
+
+: <edit-blog-action> ( -- action )
+ <page-action>
+ [
+ validate-integer-id
+ "id" value <blog> select-tuple from-tuple
+ ] >>init
+
+ "edit-blog" planet-template >>template
+
+ [
+ validate-integer-id
+ validate-blog
+ ] >>validate
+
+ [
+ f <blog>
+ [ deposit-blog-slots ]
+ [ update-tuple ]
+ [ id>> "$planet-factor/admin" <id-redirect> ]
+ tri
+ ] >>submit ;
+
+TUPLE: planet-factor-admin < dispatcher ;
+
+: <planet-factor-admin> ( -- responder )
+ planet-factor-admin new-dispatcher
+ <edit-blogroll-action> "blogroll" add-main-responder
+ <update-action> "update" add-responder
+ <new-blog-action> "new-blog" add-responder
+ <edit-blog-action> "edit-blog" add-responder
+ <delete-blog-action> "delete-blog" add-responder ;
SYMBOL: can-administer-planet-factor?
can-administer-planet-factor? define-capability
+TUPLE: planet-factor < dispatcher ;
+
: <planet-factor> ( -- responder )
planet-factor new-dispatcher
-
dup <planet-action> "list" add-main-responder
- dup <feed-action> "feed.xml" add-responder
-
dup <planet-factor-admin> { can-administer-planet-factor? } <protected> "admin" add-responder
+ <planet-action> "list" add-main-responder
+ <feed-action> "feed.xml" add-responder
+ <planet-factor-admin> { can-administer-planet-factor? } <protected> "admin" add-responder
<boilerplate>
- "planet" planet-template >>template ;
+ "planet-common" planet-template >>template ;
-: start-update-task ( planet db seq -- )
- '[
- , , , [
- dup filter-responder? [ responder>> ] when
- update-cached-postings
- ] with-db
- ] 10 minutes every drop ;
+: start-update-task ( db params -- )
+ '[ , , [ update-cached-postings ] with-db ] 10 minutes every drop ;
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
- <t:style t:include="resource:extra/webapps/planet/planet.css" />
+ <t:title>Planet Factor</t:title>
- <div class="navbar">
- <t:a t:href="$planet-factor/list">Front Page</t:a>
- | <t:a t:href="$planet-factor/feed.xml">Atom Feed</t:a>
- | <t:a t:href="$planet-factor/admin">Admin</t:a>
+ <table width="100%" cellpadding="10">
+ <tr>
+ <td>
- <t:if t:code="http.server.sessions:uid">
- <t:if t:code="http.server.auth.login:allow-edit-profile?">
- | <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
- </t:if>
-
- | <t:button t:action="$login/logout" t:flow="begin" class="link-button link">Logout</t:button>
- </t:if>
- </div>
+ <t:each-tuple t:values="postings">
- <h1><t:write-title /></h1>
+ <h2 class="posting-title">
+ <t:a t:value="link" t:session="none"><t:label t:name="title" /></t:a>
+ </h2>
- <t:call-next-template />
+ <p class="posting-body">
+ <t:html t:name="description" />
+ </p>
+
+ <p class="posting-date">
+ <t:a t:value="link" t:session="none"><t:label t:name="pub-date" /></t:a>
+ </p>
+
+ </t:each-tuple>
+
+ </td>
+
+ <td valign="top" width="25%" class="infobox">
+
+ <h2>Blogroll</h2>
+
+ <ul>
+ <t:each t:values="blogroll">
+ <li>
+ <t:link t:name="value"/>
+ </li>
+ </t:each>
+ </ul>
+
+ </td>
+ </tr>
+ </table>
</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <t:summary t:component="postings" />
-
-</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <t:title>Planet Factor</t:title>
-
- <table width="100%" cellpadding="10">
- <tr>
- <td> <t:view t:component="postings" /> </td>
-
- <td valign="top" width="25%" class="infobox">
- <h2>Blogroll</h2>
-
- <t:summary t:component="blogroll" />
- </td>
- </tr>
- </table>
-
-</t:chloe>
<t:form t:action="$todo-list/edit" t:for="id">
<table>
- <tr><th class="field-label">Summary: </th><td><t:edit t:component="summary" /></td></tr>
- <tr><th class="field-label">Priority: </th><td><t:edit t:component="priority" /></td></tr>
- <tr><th class="field-label big-field-label">Description:</th><td><t:edit t:component="description" /></td></tr>
+ <tr><th class="field-label">Summary: </th><td><t:field t:name="summary" /></td></tr>
+ <tr><th class="field-label">Priority: </th><td><t:field t:name="priority" /></td></tr>
+ <tr><th class="field-label big-field-label">Description:</th><td><t:textarea t:name="description" t:rows="20" t:cols="60" /></td></tr>
</table>
<input type="SUBMIT" value="Done" />
<t:title>My Todo List</t:title>
<table class="todo-list">
- <tr><th>Summary</th><th>Priority</th><th>View</th><th>Edit</th></tr>
- <t:summary t:component="list" />
+
+ <tr>
+ <th>Summary</th>
+ <th>Priority</th>
+ <th>View</th>
+ <th>Edit</th>
+ </tr>
+
+ <t:each-tuple t:values="items">
+
+ <tr>
+ <td>
+ <t:label t:name="summary" />
+ </td>
+ <td>
+ <t:label t:name="priority" />
+ </td>
+ <td>
+ <t:a t:href="$todo-list/view" t:query="id">View</t:a>
+ </td>
+ <td>
+ <t:a t:href="$todo-list/edit" t:query="id">Edit</t:a>
+ </td>
+ </tr>
+
+ </t:each-tuple>
+
</table>
</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <tr>
- <td>
- <t:view t:component="summary" />
- </td>
- <td>
- <t:view t:component="priority" />
- </td>
- <td>
- <t:a t:href="$todo-list/view" t:query="id">View</t:a>
- </td>
- <td>
- <t:a t:href="$todo-list/edit" t:query="id">Edit</t:a>
- </td>
- </tr>
-
-</t:chloe>
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel locals sequences namespaces
-db db.types db.tuples
+USING: accessors kernel sequences namespaces
+db db.types db.tuples validators hashtables
+html.components
+html.templates.chloe
http.server.sessions
-http.server.components
-http.server.components.farkup
-http.server.forms
-http.server.templating.chloe
http.server.boilerplate
-http.server.crud
http.server.auth
http.server.actions
http.server.db
: todo-template ( name -- template )
"resource:extra/webapps/todo/" swap ".xml" 3append <chloe> ;
-: <todo-form> ( -- form )
- "todo" <form>
- "view-todo" todo-template >>view-template
- "edit-todo" todo-template >>edit-template
- "todo-summary" todo-template >>summary-template
- "id" <integer>
- hidden >>renderer
- add-field
- "summary" <string>
- t >>required
- add-field
- "priority" <integer>
- t >>required
- 0 >>default
- 0 >>min-value
- 10 >>max-value
- add-field
- "description" <farkup>
- add-field ;
-
-: <todo-list-form> ( -- form )
- "todo-list" <form>
- "todo-list" todo-template >>view-template
- "list" <todo-form> +plain+ <list>
- add-field ;
+: <view-action> ( -- action )
+ <page-action>
+ [
+ validate-integer-id
+ "id" value <todo> select-tuple from-tuple
+ ] >>init
+
+ "view-todo" todo-template >>template ;
+
+: <id-redirect> ( id next -- response )
+ swap "id" associate <standard-redirect> ;
+
+: validate-todo ( -- )
+ {
+ { "summary" [ v-one-line ] }
+ { "priority" [ v-integer 0 v-min-value 10 v-max-value ] }
+ { "description" [ v-required ] }
+ } validate-params ;
+
+: <new-action> ( -- action )
+ <page-action>
+ [ 0 "priority" set-value ] >>init
+
+ "edit-todo" todo-template >>template
+
+ [ validate-todo ] >>validate
+
+ [
+ f <todo>
+ dup { "summary" "description" } deposit-slots
+ [ insert-tuple ]
+ [ id>> "$todo-list/view" <id-redirect> ]
+ bi
+ ] >>submit ;
+
+: <edit-action> ( -- action )
+ <page-action>
+ [
+ validate-integer-id
+ "id" value <todo> select-tuple from-tuple
+ ] >>init
+
+ "edit-todo" todo-template >>template
+
+ [
+ validate-integer-id
+ validate-todo
+ ] >>validate
+
+ [
+ f <todo>
+ dup { "id" "summary" "priority" "description" } deposit-slots
+ [ update-tuple ]
+ [ id>> "$todo-list/view" <id-redirect> ]
+ bi
+ ] >>submit ;
+
+: <delete-action> ( -- action )
+ <action>
+ [ validate-integer-id ] >>validate
+
+ [
+ "id" get <todo> delete-tuples
+ "$todo-list/list" f <standard-redirect>
+ ] >>submit ;
+
+: <list-action> ( -- action )
+ <page-action>
+ [ f <todo> select-tuples "items" set-value ] >>init
+ "todo-list" todo-template >>template ;
TUPLE: todo-list < dispatcher ;
-:: <todo-list> ( -- responder )
- [let | todo-form [ <todo-form> ]
- list-form [ <todo-list-form> ]
- ctor [ [ <todo> ] ] |
- todo-list new-dispatcher
- list-form ctor <list-action> "list" add-main-responder
- todo-form ctor <view-action> "view" add-responder
- todo-form ctor "$todo-list/view" <edit-action> "edit" add-responder
- ctor "$todo-list/list" <delete-action> "delete" add-responder
- <boilerplate>
- "todo" todo-template >>template
- f <protected>
- ] ;
+: <todo-list> ( -- responder )
+ todo-list new-dispatcher
+ <list-action> "list" add-main-responder
+ <view-action> "view" add-responder
+ <new-action> "new" add-responder
+ <edit-action> "edit" add-responder
+ <delete-action> "delete" add-responder
+ <boilerplate>
+ "todo" todo-template >>template
+ f <protected> ;
| <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
</t:if>
- <t:button t:action="$login/logout" t:flow="begin" class="link-button link">Logout</t:button>
+ | <t:button t:action="$login/logout" t:flow="begin" class="link-button link">Logout</t:button>
</div>
<h1><t:write-title /></h1>
<t:title>View Item</t:title>
<table>
- <tr><th class="field-label">Summary: </th><td><t:view t:component="summary" /></td></tr>
- <tr><th class="field-label">Priority: </th><td><t:view t:component="priority" /></td></tr>
+ <tr><th class="field-label">Summary: </th><td><t:label t:name="summary" /></td></tr>
+ <tr><th class="field-label">Priority: </th><td><t:label t:name="priority" /></td></tr>
</table>
<div class="description">
- <t:view t:component="description" />
+ <t:farkup t:name="description" />
</div>
<t:a t:href="$todo-list/edit" t:query="id">Edit</t:a>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Edit User</t:title>
+
+ <t:form t:action="$user-admin/edit" t:for="username">
+
+ <table>
+
+ <tr>
+ <th class="field-label">User name:</th>
+ <td><t:label t:name="username" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Real name:</th>
+ <td><t:field t:name="realname" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">New password:</th>
+ <td><t:password t:name="new-password" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Verify:</th>
+ <td><t:password t:name="verify-password" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">E-mail:</th>
+ <td><t:field t:name="email" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label big-field-label">Capabilities:</th>
+ <td><t:choice t:name="capabilities" t:choices="all-capabilities" t:multiple="true" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Profile:</th>
+ <td><t:inspector t:name="profile" /></td>
+ </tr>
+
+ </table>
+
+ <p>
+ <button type="submit" class="link-button link">Update</button>
+ <t:validation-messages />
+ </p>
+
+ </t:form>
+
+ <t:button t:action="$user-admin/delete" t:for="username" class="link-button link">Delete</t:button>
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>New User</t:title>
+
+ <t:form t:action="$user-admin/new">
+
+ <table>
+
+ <tr>
+ <th class="field-label">User name:</th>
+ <td><t:field t:name="username" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Real name:</th>
+ <td><t:field t:name="realname" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">New password:</th>
+ <td><t:password t:name="new-password" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Verify:</th>
+ <td><t:password t:name="verify-password" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">E-mail:</th>
+ <td><t:field t:name="email" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label big-field-label">Capabilities:</th>
+ <td><t:choice t:name="capabilities" t:choices="all-capabilities" t:multiple="true" /></td>
+ </tr>
+
+ </table>
+
+ <p>
+ <button type="submit" class="link-button link">Create</button>
+ <t:validation-messages />
+ </p>
+
+ </t:form>
+</t:chloe>
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences accessors namespaces combinators words
+assocs db.tuples arrays splitting strings validators
+html.elements
+html.components
+html.templates.chloe
+http.server.boilerplate
+http.server.auth.providers
+http.server.auth.providers.db
+http.server.auth.login
+http.server.auth
+http.server.sessions
+http.server.actions
+http.server ;
+IN: webapps.user-admin
+
+: admin-template ( name -- template )
+ "resource:extra/webapps/user-admin/" swap ".xml" 3append <chloe> ;
+
+: words>strings ( seq -- seq' )
+ [ [ word-vocabulary ] [ drop ":" ] [ word-name ] tri 3append ] map ;
+
+: strings>words ( seq -- seq' )
+ [ ":" split1 swap lookup ] map ;
+
+: <user-list-action> ( -- action )
+ <page-action>
+ [ f <user> select-tuples "users" set-value ] >>init
+ "user-list" admin-template >>template ;
+
+: <new-user-action> ( -- action )
+ <page-action>
+ [
+ "username" param <user> from-tuple
+ capabilities get words>strings "all-capabilities" set-value
+ ] >>init
+
+ "new-user" admin-template >>template
+
+ [
+ capabilities get words>strings "all-capabilities" set-value
+
+ {
+ { "username" [ v-username ] }
+ { "realname" [ v-one-line ] }
+ { "new-password" [ v-password ] }
+ { "verify-password" [ v-password ] }
+ { "email" [ [ v-email ] v-optional ] }
+ { "capabilities" [ ] }
+ } validate-params
+
+ same-password-twice
+
+ user new "username" value >>username select-tuple
+ [ user-exists ] when
+ ] >>validate
+
+ [
+ "username" value <user>
+ "realname" value >>realname
+ "email" value >>email
+ "new-password" value >>encoded-password
+ H{ } clone >>profile
+
+ insert-tuple
+
+ "$user-admin" f <standard-redirect>
+ ] >>submit ;
+
+: validate-username ( -- )
+ { { "username" [ v-username ] } } validate-params ;
+
+: <edit-user-action> ( -- action )
+ <page-action>
+ [
+ validate-username
+
+ "username" value <user> select-tuple
+ [ from-tuple ] [ capabilities>> words>strings "capabilities" set-value ] bi
+
+ capabilities get words>strings "all-capabilities" set-value
+ ] >>init
+
+ "edit-user" admin-template >>template
+
+ [
+ capabilities get words>strings "all-capabilities" set-value
+
+ {
+ { "username" [ v-username ] }
+ { "realname" [ v-one-line ] }
+ { "new-password" [ [ v-password ] v-optional ] }
+ { "verify-password" [ [ v-password ] v-optional ] }
+ { "email" [ [ v-email ] v-optional ] }
+ { "capabilities" [ ] }
+ } validate-params
+
+ "new-password" "verify-password"
+ [ value empty? not ] either? [
+ same-password-twice
+ ] when
+ ] >>validate
+
+ [
+ "username" value <user> select-tuple
+ "realname" value >>realname
+ "email" value >>email
+
+ "new-password" value empty? [
+ "new-password" value >>encoded-password
+ ] unless
+
+ "capabilities" value {
+ { [ dup string? ] [ 1array ] }
+ { [ dup array? ] [ ] }
+ } cond strings>words >>capabilities
+
+ update-tuple
+
+ "$user-admin" f <standard-redirect>
+ ] >>submit ;
+
+: <delete-user-action> ( -- action )
+ <action>
+ [
+ validate-username
+
+ [ <user> select-tuple 1 >>deleted update-tuple ]
+ [ logout-all-sessions ]
+ bi
+
+ "$user-admin" f <standard-redirect>
+ ] >>submit ;
+
+TUPLE: user-admin < dispatcher ;
+
+SYMBOL: can-administer-users?
+
+can-administer-users? define-capability
+
+: <user-admin> ( -- responder )
+ user-admin new-dispatcher
+ <user-list-action> "list" add-main-responder
+ <new-user-action> "new" add-responder
+ <edit-user-action> "edit" add-responder
+ <delete-user-action> "delete" add-responder
+ <boilerplate>
+ "user-admin" admin-template >>template
+ { can-administer-users? } <protected> ;
+
+: make-admin ( username -- )
+ <user>
+ select-tuple
+ [ can-administer-users? suffix ] change-capabilities
+ update-tuple ;
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <div class="navbar">
+ <t:a t:href="$user-admin">List Users</t:a>
+ | <t:a t:href="$user-admin/new">Add User</t:a>
+
+ <t:if t:code="http.server.auth.login:allow-edit-profile?">
+ | <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
+ </t:if>
+
+ | <t:button t:action="$login/logout" t:flow="begin" class="link-button link">Logout</t:button>
+ </div>
+
+ <h1><t:write-title /></h1>
+
+ <t:call-next-template />
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Users</t:title>
+
+ <ul>
+
+ <t:each-tuple t:values="users">
+ <li>
+ <t:a t:href="$user-admin/edit" t:query="username">
+ <t:label t:name="username" />
+ </t:a>
+ </li>
+ </t:each-tuple>
+
+ </ul>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>All Articles</t:title>
+
+ <ul>
+ <t:each-tuple t:values="articles">
+ <li>
+ <t:a t:href="view" t:query="title"><t:label t:name="title"/></t:a>
+ </li>
+ </t:each-tuple>
+ </ul>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Recent Changes</t:title>
+
+ <ul>
+ <t:each-tuple t:values="changes">
+ <li>
+ <t:a t:href="title" t:query="title"><t:label t:name="title" /></t:a>
+ on
+ <t:a t:href="revision" t:query="id"><t:label t:name="date" /></t:a>
+ by
+ <t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a>
+ </li>
+ </t:each-tuple>
+ </ul>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:bind-tuple t:name="old">
+ <t:title>Diff: <t:label t:name="title" /></t:title>
+ </t:bind-tuple>
+
+ <table>
+ <tr>
+ <th class="field-label">Old revision:</th>
+ <t:bind-tuple t:name="old">
+ <td>Created on <t:label t:name="date" /> by <t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a>.</td>
+ </t:bind-tuple>
+ </tr>
+ <tr>
+ <th class="field-label">New revision:</th>
+ <t:bind-tuple t:name="old">
+ <td>Created on <t:label t:name="date" /> by <t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a>.</td>
+ </t:bind-tuple>
+ </tr>
+ </table>
+
+ <t:comparison t:name="diff" />
+
+ <t:bind-tuple t:name="old">
+ <div class="navbar">
+ <t:a t:href="$wiki/view" t:query="title">Latest</t:a>
+ | <t:a t:href="$wiki/revisions" t:query="title">Revisions</t:a>
+ | <t:a t:href="$wiki/edit" t:query="title">Edit</t:a>
+ | <t:button t:action="$wiki/delete" t:for="title" class="link-button link">Delete</t:button>
+ </div>
+ </t:bind-tuple>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Edit: <t:label t:name="title" /></t:title>
+
+ <t:form t:action="$wiki/edit" t:for="title">
+
+ <p>
+ <t:textarea t:name="content" t:rows="30" t:cols="80" />
+ </p>
+
+ <p>
+ <input type="submit" value="Save" />
+ </p>
+
+ </t:form>
+
+ <t:button t:action="$wiki/delete" t:for="title" class="link-button link">Delete</t:button>
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Revisions of <t:label t:name="title" /></t:title>
+
+ <ul>
+ <t:each-tuple t:values="revisions">
+ <li>
+ <t:a t:href="revision" t:query="id"><t:label t:name="date" /></t:a>
+ by
+ <t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a>
+ </li>
+ </t:each-tuple>
+ </ul>
+
+ <h2>View Differences</h2>
+
+ <form action="diff" method="get">
+ <table>
+ <tr>
+ <th class="field-label">Old revision:</th>
+
+ <td>
+ <select name="old-id">
+ <t:each-tuple t:values="revisions">
+ <option> <t:label t:name="id" /> </option>
+ </t:each-tuple>
+ </select>
+ </td>
+ </tr>
+ <tr>
+ <th class="field-label">New revision:</th>
+
+ <td>
+ <select name="new-id">
+ <t:each-tuple t:values="revisions">
+ <option> <t:label t:name="id" /> </option>
+ </t:each-tuple>
+ </select>
+ </td>
+ </tr>
+ </table>
+
+ <input type="submit" value="View" />
+ </form>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Edits by <t:label t:name="author" /></t:title>
+
+ <ul>
+ <t:each-tuple t:values="user-edits">
+ <li>
+ <t:a t:href="view" t:query="title"><t:label t:name="title" /></t:a>
+ on
+ <t:a t:href="revision" t:query="id"><t:label t:name="date" /></t:a>
+ </li>
+ </t:each-tuple>
+ </ul>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title><t:label t:name="title" /></t:title>
+
+ <div class="description">
+ <t:farkup t:name="content" />
+ </div>
+
+ <div class="navbar">
+ <t:a t:href="$wiki/view" t:query="title">Latest</t:a>
+ | <t:a t:href="$wiki/revisions" t:query="title">Revisions</t:a>
+ | <t:a t:href="$wiki/edit" t:query="title">Edit</t:a>
+ | <t:button t:action="$wiki/delete" t:for="title" class="link-button link">Delete</t:button>
+ | This revision created on <t:label t:name="date" /> by <t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a>.
+ </div>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:style t:include="resource:extra/webapps/wiki/wiki.css" />
+
+ <div class="navbar">
+
+ <t:a t:href="$wiki">Front Page</t:a>
+ | <t:a t:href="$wiki/articles">All Articles</t:a>
+ | <t:a t:href="$wiki/changes">Recent Changes</t:a>
+
+ <t:if t:code="http.server.sessions:uid">
+
+ <t:if t:code="http.server.auth.login:allow-edit-profile?">
+ | <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
+ </t:if>
+
+ | <t:button t:action="$login/logout" t:flow="begin" class="link-button link">Logout</t:button>
+
+ </t:if>
+
+ </div>
+
+ <h1><t:write-title /></h1>
+
+ <t:call-next-template />
+
+</t:chloe>
--- /dev/null
+.comparison table, {
+ border-color: #666;
+ border-style: solid;
+}
+
+.comparison th {
+ border-width: 1px;
+ border-color: #666;
+ border-style: solid;
+}
+
+.comparison table {
+ border-width: 1px;
+ border-spacing: 0;
+ border-collapse: collapse;
+}
+
+
+.insert {
+ background-color: #9f9;
+}
+
+.delete {
+ background-color: #f99;
+}
--- /dev/null
+! Copyright (C) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel hashtables calendar
+namespaces splitting sequences sorting math.order
+html.components
+html.templates.chloe
+http.server
+http.server.actions
+http.server.auth
+http.server.auth.login
+http.server.boilerplate
+validators
+db.types db.tuples lcs farkup ;
+IN: webapps.wiki
+
+TUPLE: article title revision ;
+
+article "ARTICLES" {
+ { "title" "TITLE" { VARCHAR 256 } +not-null+ +user-assigned-id+ }
+ ! { "AUTHOR" INTEGER +not-null+ } ! uid
+ ! { "PROTECTED" BOOLEAN +not-null+ }
+ { "revision" "REVISION" INTEGER +not-null+ } ! revision id
+} define-persistent
+
+: <article> ( title -- article ) article new swap >>title ;
+
+: init-articles-table article ensure-table ;
+
+TUPLE: revision id title author date content ;
+
+revision "REVISIONS" {
+ { "id" "ID" INTEGER +db-assigned-id+ }
+ { "title" "TITLE" { VARCHAR 256 } +not-null+ } ! article id
+ { "author" "AUTHOR" { VARCHAR 256 } +not-null+ } ! uid
+ { "date" "DATE" TIMESTAMP +not-null+ }
+ { "content" "CONTENT" TEXT +not-null+ }
+} define-persistent
+
+: <revision> ( id -- revision )
+ revision new swap >>id ;
+
+: init-revisions-table revision ensure-table ;
+
+: wiki-template ( name -- template )
+ "resource:extra/webapps/wiki/" swap ".xml" 3append <chloe> ;
+
+: <title-redirect> ( title next -- response )
+ swap "title" associate <standard-redirect> ;
+
+: validate-title ( -- )
+ { { "title" [ v-one-line ] } } validate-params ;
+
+: <main-article-action> ( -- action )
+ <action>
+ [ "Front Page" "$wiki/view" <title-redirect> ] >>display ;
+
+: <view-article-action> ( -- action )
+ <action>
+ "title" >>rest-param
+
+ [
+ validate-title
+ "view?title=" relative-link-prefix set
+ ] >>init
+
+ [
+ "title" value dup <article> select-tuple [
+ revision>> <revision> select-tuple from-tuple
+ "view" wiki-template <html-content>
+ ] [
+ "$wiki/edit" <title-redirect>
+ ] ?if
+ ] >>display ;
+
+: <view-revision-action> ( -- action )
+ <page-action>
+ [
+ { { "id" [ v-integer ] } } validate-params
+ "id" value <revision>
+ select-tuple from-tuple
+ ] >>init
+
+ "view" wiki-template >>template ;
+
+: add-revision ( revision -- )
+ [ insert-tuple ]
+ [
+ dup title>> <article> select-tuple [
+ swap id>> >>revision update-tuple
+ ] [
+ [ title>> ] [ id>> ] bi article boa insert-tuple
+ ] if*
+ ] bi ;
+
+: <edit-article-action> ( -- action )
+ <page-action>
+ [
+ validate-title
+ "title" value <article> select-tuple [
+ revision>> <revision> select-tuple from-tuple
+ ] when*
+ ] >>init
+
+ "edit" wiki-template >>template
+
+ [
+ validate-title
+ { { "content" [ v-required ] } } validate-params
+
+ f <revision>
+ "title" value >>title
+ now >>date
+ logged-in-user get username>> >>author
+ "content" value >>content
+ [ add-revision ]
+ [ title>> "$wiki/view" <title-redirect> ] bi
+ ] >>submit ;
+
+: <list-revisions-action> ( -- action )
+ <page-action>
+ [
+ validate-title
+ f <revision> "title" value >>title select-tuples
+ [ [ date>> ] compare invert-comparison ] sort
+ "revisions" set-value
+ ] >>init
+
+ "revisions" wiki-template >>template ;
+
+: <list-changes-action> ( -- action )
+ <page-action>
+ [
+ f <revision> select-tuples
+ [ [ date>> ] compare invert-comparison ] sort
+ "changes" set-value
+ ] >>init
+
+ "changes" wiki-template >>template ;
+
+: <delete-action> ( -- action )
+ <action>
+ [ validate-title ] >>validate
+
+ [
+ "title" value <article> delete-tuples
+ f <revision> "title" value >>title delete-tuples
+ "" f <standard-redirect>
+ ] >>submit ;
+
+: <diff-action> ( -- action )
+ <page-action>
+ [
+ {
+ { "old-id" [ v-integer ] }
+ { "new-id" [ v-integer ] }
+ } validate-params
+
+ "old-id" "new-id"
+ [ value <revision> select-tuple ] bi@
+ [ [ "old" set-value ] [ "new" set-value ] bi* ]
+ [ [ content>> string-lines ] bi@ diff "diff" set-value ]
+ 2bi
+ ] >>init
+
+ "diff" wiki-template >>template ;
+
+: <list-articles-action> ( -- action )
+ <page-action>
+ [
+ f <article> select-tuples
+ [ [ title>> ] compare ] sort
+ "articles" set-value
+ ] >>init
+
+ "articles" wiki-template >>template ;
+
+: <user-edits-action> ( -- action )
+ <page-action>
+ [
+ { { "author" [ v-username ] } } validate-params
+ f <revision> "author" value >>author
+ select-tuples "user-edits" set-value
+ ] >>init
+
+ "user-edits" wiki-template >>template ;
+
+TUPLE: wiki < dispatcher ;
+
+: <wiki> ( -- dispatcher )
+ wiki new-dispatcher
+ <main-article-action> "" add-responder
+ <view-article-action> "view" add-responder
+ <view-revision-action> "revision" add-responder
+ <list-revisions-action> "revisions" add-responder
+ <user-edits-action> "user-edits" add-responder
+ <diff-action> "diff" add-responder
+ <list-articles-action> "articles" add-responder
+ <list-changes-action> "changes" add-responder
+ <edit-article-action> { } <protected> "edit" add-responder
+ <delete-action> { } <protected> "delete" add-responder
+ <boilerplate>
+ "wiki-common" wiki-template >>template ;
USING: xmode.loader xmode.utilities xmode.rules namespaces
strings splitting assocs sequences kernel io.files xml memoize
-words globs combinators io.encodings.utf8 ;
+words globs combinators io.encodings.utf8 sorting ;
IN: xmode.catalog
TUPLE: mode file file-name-glob first-line-glob ;
swap child-tags [ parse-mode-tag ] with each
] keep ;
-: load-catalog ( -- modes )
+MEMO: modes ( -- modes )
"resource:extra/xmode/modes/catalog"
file>xml parse-modes-tag ;
-: modes ( -- assoc )
- \ modes get-global [
- load-catalog dup \ modes set-global
- ] unless* ;
+MEMO: mode-names ( -- modes )
+ modes keys natural-sort ;
: reset-catalog ( -- )
- f \ modes set-global ;
+ \ modes reset-memoized ;
MEMO: (load-mode) ( name -- rule-sets )
modes at [
-USING: xmode.tokens xmode.marker xmode.catalog kernel html
+USING: xmode.tokens xmode.marker xmode.catalog kernel
html.elements io io.files sequences words io.encodings.utf8
-namespaces ;
+namespaces xml.entities ;
IN: xmode.code2html
: htmlize-tokens ( tokens -- )
[
dup token-str swap token-id [
- <span word-name =class span> write </span>
+ <span word-name =class span> escape-string write </span>
] [
write
] if*
: default-stylesheet ( -- )
<style>
"resource:extra/xmode/code2html/stylesheet.css"
- utf8 file-contents write
+ utf8 file-contents escape-string write
</style> ;
: htmlize-stream ( path stream -- )
<html>
<head>
default-stylesheet
- <title> dup write </title>
+ <title> dup escape-string write </title>
</head>
<body>
<pre>
! Copyright (C) 2007, 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: io.files io.encodings.utf8 namespaces http.server\r
-http.server.static http xmode.code2html kernel html sequences\r
+USING: io io.files io.encodings.utf8 namespaces http.server\r
+http.server.static http xmode.code2html kernel sequences\r
accessors fry ;\r
IN: xmode.code2html.responder\r
\r
: <sources> ( root -- responder )\r
[\r
drop\r
- "text/html" <content> swap\r
- [ "last-modified" set-header ]\r
- [\r
- '[\r
- ,\r
- dup file-name swap utf8\r
- <file-reader>\r
- [ htmlize-stream ] with-html-stream\r
- ] >>body\r
- ] bi\r
+ dup '[\r
+ , utf8 [\r
+ , file-name input-stream get htmlize-stream\r
+ ] with-file-reader\r
+ ] <html-content>\r
] <file-responder> ;\r
{
F_COMPILED *compiled = frame_code(frame);
CELL code_start = (CELL)(compiled + 1);
- CELL literal_start = code_start
- + compiled->code_length
- + compiled->reloc_length;
+ CELL literal_start = code_start + compiled->code_length;
return get(literal_start);
}
}
/* Copy all literals referenced from a code block to newspace */
-void collect_literals_step(F_COMPILED *compiled, CELL code_start,
- CELL reloc_start, CELL literals_start)
+void collect_literals_step(F_COMPILED *compiled, CELL code_start, CELL literals_start)
{
CELL scan;
CELL literal_end = literals_start + compiled->literals_length;
+ copy_handle(&compiled->relocation);
+
for(scan = literals_start; scan < literal_end; scan += CELLS)
copy_handle((CELL*)scan);
}
/* Used during compaction */
struct _F_BLOCK *forwarding;
-
- /* Alignment padding */
- CELL padding[4];
} F_BLOCK;
typedef struct {
/* compiled code */
F_HEAP code_heap;
-typedef void (*CODE_HEAP_ITERATOR)(F_COMPILED *compiled, CELL code_start,
- CELL reloc_start, CELL literals_start);
+typedef void (*CODE_HEAP_ITERATOR)(F_COMPILED *compiled, CELL code_start, CELL literals_start);
INLINE void iterate_code_heap_step(F_COMPILED *compiled, CODE_HEAP_ITERATOR iter)
{
CELL code_start = (CELL)(compiled + 1);
- CELL reloc_start = code_start + compiled->code_length;
- CELL literals_start = reloc_start + compiled->reloc_length;
+ CELL literals_start = code_start + compiled->code_length;
- iter(compiled,code_start,reloc_start,literals_start);
+ iter(compiled,code_start,literals_start);
}
INLINE F_BLOCK *compiled_to_block(F_COMPILED *compiled)
}
/* Perform all fixups on a code block */
-void relocate_code_block(F_COMPILED *relocating, CELL code_start,
- CELL reloc_start, CELL literals_start)
+void relocate_code_block(F_COMPILED *compiled, CELL code_start, CELL literals_start)
{
- if(reloc_start != literals_start)
+ if(compiled->relocation != F)
{
- F_REL *rel = (F_REL *)reloc_start;
- F_REL *rel_end = (F_REL *)literals_start;
+ F_BYTE_ARRAY *relocation = untag_object(compiled->relocation);
+
+ F_REL *rel = (F_REL *)(relocation + 1);
+ F_REL *rel_end = (F_REL *)((char *)rel + byte_array_capacity(relocation));
while(rel < rel_end)
{
}
}
- flush_icache(code_start,reloc_start - code_start);
+ flush_icache(code_start,literals_start - code_start);
}
/* Fixup labels. This is done at compile time, not image load time */
CELL type,
F_ARRAY *code,
F_ARRAY *labels,
- F_ARRAY *relocation,
+ CELL relocation,
F_ARRAY *literals)
{
CELL code_format = compiled_code_format();
CELL code_length = align8(array_capacity(code) * code_format);
- CELL rel_length = array_capacity(relocation) * sizeof(unsigned int);
CELL literals_length = array_capacity(literals) * CELLS;
+ REGISTER_ROOT(relocation);
REGISTER_UNTAGGED(code);
REGISTER_UNTAGGED(labels);
- REGISTER_UNTAGGED(relocation);
REGISTER_UNTAGGED(literals);
- CELL here = allot_code_block(sizeof(F_COMPILED) + code_length
- + rel_length + literals_length);
+ CELL here = allot_code_block(sizeof(F_COMPILED) + code_length + literals_length);
UNREGISTER_UNTAGGED(literals);
- UNREGISTER_UNTAGGED(relocation);
UNREGISTER_UNTAGGED(labels);
UNREGISTER_UNTAGGED(code);
+ UNREGISTER_ROOT(relocation);
/* compiled header */
F_COMPILED *header = (void *)here;
header->type = type;
header->code_length = code_length;
- header->reloc_length = rel_length;
header->literals_length = literals_length;
+ header->relocation = relocation;
here += sizeof(F_COMPILED);
deposit_integers(here,code,code_format);
here += code_length;
- /* relation info */
- deposit_integers(here,relocation,sizeof(unsigned int));
- here += rel_length;
-
/* literals */
deposit_objects(here,literals);
here += literals_length;
F_ARRAY *compiled_code = untag_array(data);
F_ARRAY *literals = untag_array(array_nth(compiled_code,0));
- F_ARRAY *relocation = untag_array(array_nth(compiled_code,1));
+ CELL relocation = array_nth(compiled_code,1);
F_ARRAY *labels = untag_array(array_nth(compiled_code,2));
F_ARRAY *code = untag_array(array_nth(compiled_code,3));
unsigned int offset;
} F_REL;
-void relocate_code_block(F_COMPILED *relocating, CELL code_start,
- CELL reloc_start, CELL literals_start);
+void relocate_code_block(F_COMPILED *relocating, CELL code_start, CELL literals_start);
void default_word_code(F_WORD *word, bool relocate);
CELL type,
F_ARRAY *code,
F_ARRAY *labels,
- F_ARRAY *rel,
+ CELL relocation,
F_ARRAY *literals);
CELL compiled_code_format(void);
for(i = 0; i < MAX_GEN_COUNT; i++)
{
F_GC_STATS *s = &gc_stats[i];
- GROWABLE_ADD(stats,allot_cell(s->collections));
- GROWABLE_ADD(stats,allot_cell(s->gc_time));
- GROWABLE_ADD(stats,allot_cell(s->max_gc_time));
- GROWABLE_ADD(stats,allot_cell(s->collections == 0 ? 0 : s->gc_time / s->collections));
- GROWABLE_ADD(stats,allot_cell(s->object_count));
- GROWABLE_ADD(stats,tag_bignum(long_long_to_bignum(s->bytes_copied)));
+ GROWABLE_ARRAY_ADD(stats,allot_cell(s->collections));
+ GROWABLE_ARRAY_ADD(stats,allot_cell(s->gc_time));
+ GROWABLE_ARRAY_ADD(stats,allot_cell(s->max_gc_time));
+ GROWABLE_ARRAY_ADD(stats,allot_cell(s->collections == 0 ? 0 : s->gc_time / s->collections));
+ GROWABLE_ARRAY_ADD(stats,allot_cell(s->object_count));
+ GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(s->bytes_copied)));
total_gc_time += s->gc_time;
}
- GROWABLE_ADD(stats,allot_cell(total_gc_time));
- GROWABLE_ADD(stats,tag_bignum(long_long_to_bignum(cards_scanned)));
- GROWABLE_ADD(stats,tag_bignum(long_long_to_bignum(decks_scanned)));
- GROWABLE_ADD(stats,allot_cell(code_heap_scans));
+ GROWABLE_ARRAY_ADD(stats,allot_cell(total_gc_time));
+ GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(cards_scanned)));
+ GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(decks_scanned)));
+ GROWABLE_ARRAY_ADD(stats,allot_cell(code_heap_scans));
- GROWABLE_TRIM(stats);
+ GROWABLE_ARRAY_TRIM(stats);
dpush(stats);
}
while((obj = next_object()) != F)
{
if(type_of(obj) == WORD_TYPE)
- GROWABLE_ADD(words,obj);
+ GROWABLE_ARRAY_ADD(words,obj);
}
/* End heap scan */
gc_off = false;
- GROWABLE_TRIM(words);
+ GROWABLE_ARRAY_TRIM(words);
return words;
}
CELL look_for;
-void find_code_references_step(F_COMPILED *compiled, CELL code_start,
- CELL reloc_start, CELL literals_start)
+void find_code_references_step(F_COMPILED *compiled, CELL code_start, CELL literals_start)
{
CELL scan;
CELL literal_end = literals_start + compiled->literals_length;
for(scan = literals_start; scan < literal_end; scan += CELLS)
{
CELL code_start = (CELL)(compiled + 1);
- CELL literal_start = code_start
- + compiled->code_length
- + compiled->reloc_length;
+ CELL literal_start = code_start + compiled->code_length;
CELL obj = get(literal_start);
}
}
-void fixup_code_block(F_COMPILED *relocating, CELL code_start,
- CELL reloc_start, CELL literals_start)
+void fixup_code_block(F_COMPILED *compiled, CELL code_start, CELL literals_start)
{
/* relocate literal table data */
CELL scan;
- CELL literal_end = literals_start + relocating->literals_length;
+ CELL literal_end = literals_start + compiled->literals_length;
+
+ data_fixup(&compiled->relocation);
for(scan = literals_start; scan < literal_end; scan += CELLS)
data_fixup((CELL*)scan);
- if(reloc_start != literals_start)
- relocate_code_block(relocating,code_start,reloc_start,literals_start);
+ relocate_code_block(compiled,code_start,literals_start);
}
void relocate_code()
{
CELL type; /* this is WORD_TYPE or QUOTATION_TYPE */
CELL code_length; /* # bytes */
- CELL reloc_length; /* # bytes */
CELL literals_length; /* # bytes */
+ CELL relocation; /* tagged pointer to byte-array or f */
} F_COMPILED;
/* Assembly code makes assumptions about the layout of this struct */
while((file = readdir(dir)) != NULL)
{
CELL pair = parse_dir_entry(file);
- GROWABLE_ADD(result,pair);
+ GROWABLE_ARRAY_ADD(result,pair);
}
closedir(dir);
}
UNREGISTER_ROOT(result);
- GROWABLE_TRIM(result);
+ GROWABLE_ARRAY_TRIM(result);
dpush(result);
}
while(*env)
{
CELL string = tag_object(from_char_string(*env));
- GROWABLE_ADD(result,string);
+ GROWABLE_ARRAY_ADD(result,string);
env++;
}
UNREGISTER_ROOT(result);
- GROWABLE_TRIM(result);
+ GROWABLE_ARRAY_TRIM(result);
dpush(result);
}
break;
CELL string = tag_object(from_u16_string(finger));
- GROWABLE_ADD(result,string);
+ GROWABLE_ARRAY_ADD(result,string);
finger = scan + 1;
}
FreeEnvironmentStrings(env);
UNREGISTER_ROOT(result);
- GROWABLE_TRIM(result);
+ GROWABLE_ARRAY_TRIM(result);
dpush(result);
}
CELL name = tag_object(from_u16_string(find_data.cFileName));
CELL dirp = tag_boolean(find_data.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY);
CELL pair = allot_array_2(name,dirp);
- GROWABLE_ADD(result,pair);
+ GROWABLE_ARRAY_ADD(result,pair);
}
while (FindNextFile(dir, &find_data));
FindClose(dir);
}
UNREGISTER_ROOT(result);
- GROWABLE_TRIM(result);
+ GROWABLE_ARRAY_TRIM(result);
dpush(result);
}
CELL code = array_nth(quadruple,0);
REGISTER_ROOT(code);
- CELL rel_type = allot_cell(to_fixnum(array_nth(quadruple,2))
- | (to_fixnum(array_nth(quadruple,1)) << 8));
- CELL rel_offset = array_nth(quadruple,3) * compiled_code_format();
+ F_REL rel;
+ rel.type = to_fixnum(array_nth(quadruple,2)) | (to_fixnum(array_nth(quadruple,1)) << 8);
+ rel.offset = to_fixnum(array_nth(quadruple,3)) * compiled_code_format();
- CELL relocation = allot_array_2(rel_type,rel_offset);
+ F_BYTE_ARRAY *relocation = allot_byte_array(sizeof(F_REL));
+ memcpy((void *)BREF(relocation,0),&rel,sizeof(F_REL));
UNREGISTER_ROOT(code);
UNREGISTER_ROOT(literals);
WORD_TYPE,
untag_object(code),
NULL, /* no labels */
- untag_object(relocation),
+ tag_object(relocation),
untag_object(literals));
}
#define EMIT(name,rel_argument) { \
bool rel_p; \
- F_REL rel = rel_to_emit(name,code_format,code_count, \
- rel_argument,&rel_p); \
- if(rel_p) \
- { \
- GROWABLE_ADD(relocation,allot_cell(rel.type)); \
- GROWABLE_ADD(relocation,allot_cell(rel.offset)); \
- } \
- GROWABLE_APPEND(code,code_to_emit(name)); \
+ F_REL rel = rel_to_emit(name,code_format,code_count,rel_argument,&rel_p); \
+ if(rel_p) GROWABLE_BYTE_ARRAY_APPEND(relocation,&rel,sizeof(F_REL)); \
+ GROWABLE_ARRAY_APPEND(code,code_to_emit(name)); \
}
bool jit_stack_frame_p(F_ARRAY *array)
GROWABLE_ARRAY(code);
REGISTER_ROOT(code);
- GROWABLE_ARRAY(relocation);
+ GROWABLE_BYTE_ARRAY(relocation);
REGISTER_ROOT(relocation);
GROWABLE_ARRAY(literals);
REGISTER_ROOT(literals);
- GROWABLE_ADD(literals,stack_traces_p() ? quot : F);
+ GROWABLE_ARRAY_ADD(literals,stack_traces_p() ? quot : F);
bool stack_frame = jit_stack_frame_p(untag_object(array));
current stack frame. */
word = untag_object(obj);
- GROWABLE_ADD(literals,array_nth(untag_object(array),i));
+ GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
if(i == length - 1)
{
break;
case WRAPPER_TYPE:
wrapper = untag_object(obj);
- GROWABLE_ADD(literals,wrapper->object);
+ GROWABLE_ARRAY_ADD(literals,wrapper->object);
EMIT(JIT_PUSH_LITERAL,literals_count - 1);
break;
case FIXNUM_TYPE:
if(stack_frame)
EMIT(JIT_EPILOG,0);
- GROWABLE_ADD(literals,array_nth(untag_object(array),i));
- GROWABLE_ADD(literals,array_nth(untag_object(array),i + 1));
+ GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
+ GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i + 1));
EMIT(JIT_IF_JUMP,literals_count - 2);
i += 2;
if(stack_frame)
EMIT(JIT_EPILOG,0);
- GROWABLE_ADD(literals,array_nth(untag_object(array),i));
+ GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
EMIT(JIT_DISPATCH,literals_count - 1);
i++;
break;
}
default:
- GROWABLE_ADD(literals,obj);
+ GROWABLE_ARRAY_ADD(literals,obj);
EMIT(JIT_PUSH_LITERAL,literals_count - 1);
break;
}
EMIT(JIT_RETURN,0);
}
- GROWABLE_TRIM(code);
- GROWABLE_TRIM(relocation);
- GROWABLE_TRIM(literals);
+ GROWABLE_ARRAY_TRIM(code);
+ GROWABLE_ARRAY_TRIM(literals);
+ GROWABLE_BYTE_ARRAY_TRIM(relocation);
F_COMPILED *compiled = add_compiled_block(
QUOTATION_TYPE,
untag_object(code),
NULL,
- untag_object(relocation),
+ relocation,
untag_object(literals));
set_quot_xt(untag_object(quot),compiled);
dpush(tag_object(reallot_array(array,capacity,F)));
}
-F_ARRAY *growable_add(F_ARRAY *result, CELL elt, CELL *result_count)
+F_ARRAY *growable_array_add(F_ARRAY *result, CELL elt, CELL *result_count)
{
REGISTER_ROOT(elt);
UNREGISTER_ROOT(elt);
set_array_nth(result,*result_count,elt);
- *result_count = *result_count + 1;
+ (*result_count)++;
return result;
}
-F_ARRAY *growable_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_count)
+F_ARRAY *growable_array_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_count)
{
REGISTER_UNTAGGED(elts);
write_barrier((CELL)result);
- memcpy((void*)AREF(result,*result_count),(void*)AREF(elts,0),elts_size * CELLS);
+ memcpy((void *)AREF(result,*result_count),(void *)AREF(elts,0),elts_size * CELLS);
*result_count += elts_size;
dpush(tag_object(reallot_byte_array(array,capacity)));
}
+F_BYTE_ARRAY *growable_byte_array_add(F_BYTE_ARRAY *result, CELL elt, CELL *result_count)
+{
+ if(*result_count == byte_array_capacity(result))
+ {
+ result = reallot_byte_array(result,*result_count * 2);
+ }
+
+ bput(BREF(result,*result_count),elt);
+ *result_count++;
+
+ return result;
+}
+
+F_BYTE_ARRAY *growable_byte_array_append(F_BYTE_ARRAY *result, void *elts, CELL len, CELL *result_count)
+{
+ CELL new_size = *result_count + len;
+
+ if(new_size >= byte_array_capacity(result))
+ result = reallot_byte_array(result,new_size * 2);
+
+ memcpy((void *)BREF(result,*result_count),elts,len);
+
+ *result_count = new_size;
+
+ return result;
+}
+
/* Bit arrays */
/* size is in bits */
DECLARE_PRIMITIVE(clone);
F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity, CELL fill);
+F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity);
DECLARE_PRIMITIVE(resize_array);
DECLARE_PRIMITIVE(resize_byte_array);
DECLARE_PRIMITIVE(resize_bit_array);
CELL result##_count = 0; \
CELL result = tag_object(allot_array(ARRAY_TYPE,100,F))
-F_ARRAY *growable_add(F_ARRAY *result, CELL elt, CELL *result_count);
+F_ARRAY *growable_array_add(F_ARRAY *result, CELL elt, CELL *result_count);
-#define GROWABLE_ADD(result,elt) \
- result = tag_object(growable_add(untag_object(result),elt,&result##_count))
+#define GROWABLE_ARRAY_ADD(result,elt) \
+ result = tag_object(growable_array_add(untag_object(result),elt,&result##_count))
-F_ARRAY *growable_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_count);
+F_ARRAY *growable_array_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_count);
-#define GROWABLE_APPEND(result,elts) \
- result = tag_object(growable_append(untag_object(result),elts,&result##_count))
+#define GROWABLE_ARRAY_APPEND(result,elts) \
+ result = tag_object(growable_array_append(untag_object(result),elts,&result##_count))
-#define GROWABLE_TRIM(result) \
+#define GROWABLE_ARRAY_TRIM(result) \
result = tag_object(reallot_array(untag_object(result),result##_count,F))
+
+/* Macros to simulate a byte vector in C */
+#define GROWABLE_BYTE_ARRAY(result) \
+ CELL result##_count = 0; \
+ CELL result = tag_object(allot_byte_array(100))
+
+F_ARRAY *growable_byte_array_add(F_BYTE_ARRAY *result, CELL elt, CELL *result_count);
+
+#define GROWABLE_BYTE_ARRAY_ADD(result,elt) \
+ result = tag_object(growable_byte_array_add(untag_object(result),elt,&result##_count))
+
+F_ARRAY *growable_byte_array_append(F_BYTE_ARRAY *result, void *elts, CELL len, CELL *result_count);
+
+#define GROWABLE_BYTE_ARRAY_APPEND(result,elts,len) \
+ result = tag_object(growable_byte_array_append(untag_object(result),elts,len,&result##_count))
+
+#define GROWABLE_BYTE_ARRAY_TRIM(result) \
+ result = tag_object(reallot_byte_array(untag_object(result),result##_count))
projects / factor.git / commitdiff