Merge branch 'experimental' into jamshred
Alex Chapman
commit
43ca76c518
|
|
@ -104,3 +104,17 @@ unit-test
|
||||||
2drop
|
2drop
|
||||||
] { } make
|
] { } make
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
[
|
||||||
|
H{
|
||||||
|
{ "bangers" "mash" }
|
||||||
|
{ "fries" "onion rings" }
|
||||||
|
}
|
||||||
|
] [
|
||||||
|
{ "bangers" "fries" } H{
|
||||||
|
{ "fish" "chips" }
|
||||||
|
{ "bangers" "mash" }
|
||||||
|
{ "fries" "onion rings" }
|
||||||
|
{ "nachos" "cheese" }
|
||||||
|
} extract-keys
|
||||||
|
] unit-test
|
||||||
|
|
|
||||||
|
|
@ -150,6 +150,9 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
|
||||||
: map>assoc ( seq quot exemplar -- assoc )
|
: map>assoc ( seq quot exemplar -- assoc )
|
||||||
>r [ 2array ] compose { } map-as r> assoc-like ; inline
|
>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 ;
|
M: assoc >alist [ 2array ] { } assoc>map ;
|
||||||
|
|
||||||
: value-at ( value assoc -- key/f )
|
: value-at ( value assoc -- key/f )
|
||||||
|
|
|
||||||
|
|
@ -160,3 +160,12 @@ TUPLE: flat-mx-2-1 ; INSTANCE: flat-mx-2-1 flat-mx-2
|
||||||
[ t ] [ 3 number instance? ] unit-test
|
[ t ] [ 3 number instance? ] unit-test
|
||||||
[ f ] [ 3 null instance? ] unit-test
|
[ f ] [ 3 null instance? ] unit-test
|
||||||
[ t ] [ "hi" \ hi-tag 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
|
||||||
|
|
|
||||||
|
|
@ -4,7 +4,7 @@ namespaces quotations sequences.private classes continuations
|
||||||
generic.standard effects classes.tuple classes.tuple.private
|
generic.standard effects classes.tuple classes.tuple.private
|
||||||
arrays vectors strings compiler.units accessors classes.algebra
|
arrays vectors strings compiler.units accessors classes.algebra
|
||||||
calendar prettyprint io.streams.string splitting inspector
|
calendar prettyprint io.streams.string splitting inspector
|
||||||
columns math.order ;
|
columns math.order classes.private ;
|
||||||
IN: classes.tuple.tests
|
IN: classes.tuple.tests
|
||||||
|
|
||||||
TUPLE: rect x y w h ;
|
TUPLE: rect x y w h ;
|
||||||
|
|
@ -543,6 +543,7 @@ TUPLE: another-forget-accessors-test ;
|
||||||
! Missing error check
|
! Missing error check
|
||||||
[ "IN: classes.tuple.tests USE: words TUPLE: wrong-superclass < word ;" eval ] must-fail
|
[ "IN: classes.tuple.tests USE: words TUPLE: wrong-superclass < word ;" eval ] must-fail
|
||||||
|
|
||||||
|
! Class forget messyness
|
||||||
TUPLE: subclass-forget-test ;
|
TUPLE: subclass-forget-test ;
|
||||||
|
|
||||||
TUPLE: subclass-forget-test-1 < subclass-forget-test ;
|
TUPLE: subclass-forget-test-1 < subclass-forget-test ;
|
||||||
|
|
@ -551,6 +552,14 @@ TUPLE: subclass-forget-test-3 < subclass-forget-test-2 ;
|
||||||
|
|
||||||
[ ] [ "IN: classes.tuple.tests FORGET: subclass-forget-test" eval ] unit-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-1 tuple-class? ] unit-test
|
||||||
[ f ] [ subclass-forget-test-2 tuple-class? ] unit-test
|
[ f ] [ subclass-forget-test-2 tuple-class? ] unit-test
|
||||||
[ subclass-forget-test-3 new ] must-fail
|
[ subclass-forget-test-3 new ] must-fail
|
||||||
|
|
|
||||||
|
|
@ -226,12 +226,6 @@ M: tuple-class reset-class
|
||||||
} reset-props
|
} reset-props
|
||||||
] bi ;
|
] 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-class rank-class drop 0 ;
|
||||||
|
|
||||||
M: tuple clone
|
M: tuple clone
|
||||||
|
|
|
||||||
|
|
@ -95,10 +95,10 @@ M: hashtable hashcode*
|
||||||
|
|
||||||
: (distribute-buckets) ( buckets pair keys -- )
|
: (distribute-buckets) ( buckets pair keys -- )
|
||||||
dup t eq? [
|
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
|
] each 2drop
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2008 Slava Pestov.
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: kernel continuations assocs namespaces sequences words
|
USING: kernel continuations assocs namespaces sequences words
|
||||||
vocabs definitions hashtables init ;
|
vocabs definitions hashtables init sets ;
|
||||||
IN: compiler.units
|
IN: compiler.units
|
||||||
|
|
||||||
SYMBOL: old-definitions
|
SYMBOL: old-definitions
|
||||||
|
|
@ -14,7 +14,7 @@ TUPLE: redefine-error def ;
|
||||||
{ { "Continue" t } } throw-restarts drop ;
|
{ { "Continue" t } } throw-restarts drop ;
|
||||||
|
|
||||||
: add-once ( key assoc -- )
|
: 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 -- )
|
: (remember-definition) ( definition loc assoc -- )
|
||||||
>r over set-where r> add-once ;
|
>r over set-where r> add-once ;
|
||||||
|
|
@ -83,7 +83,14 @@ SYMBOL: update-tuples-hook
|
||||||
call-recompile-hook
|
call-recompile-hook
|
||||||
call-update-tuples-hook
|
call-update-tuples-hook
|
||||||
dup [ drop compiled-crossref? ] assoc-contains? modify-code-heap
|
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 -- )
|
: with-compilation-unit ( quot -- )
|
||||||
[
|
[
|
||||||
|
|
@ -92,8 +99,11 @@ SYMBOL: update-tuples-hook
|
||||||
H{ } clone outdated-tuples set
|
H{ } clone outdated-tuples set
|
||||||
<definitions> new-definitions set
|
<definitions> new-definitions set
|
||||||
<definitions> old-definitions set
|
<definitions> old-definitions set
|
||||||
[ finish-compilation-unit ]
|
[
|
||||||
[ ] cleanup
|
finish-compilation-unit
|
||||||
|
updated-definitions
|
||||||
|
notify-definition-observers
|
||||||
|
] [ ] cleanup
|
||||||
] with-scope ; inline
|
] with-scope ; inline
|
||||||
|
|
||||||
: compile-call ( quot -- )
|
: compile-call ( quot -- )
|
||||||
|
|
|
||||||
|
|
@ -102,13 +102,13 @@ M: frame-required fixup* drop ;
|
||||||
|
|
||||||
M: integer fixup* , ;
|
M: integer fixup* , ;
|
||||||
|
|
||||||
: push-new* ( obj table -- n )
|
: adjoin* ( obj table -- n )
|
||||||
2dup swap [ eq? ] curry find drop
|
2dup swap [ eq? ] curry find drop
|
||||||
[ 2nip ] [ dup length >r push r> ] if* ;
|
[ 2nip ] [ dup length >r push r> ] if* ;
|
||||||
|
|
||||||
SYMBOL: literal-table
|
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 -- )
|
: add-dlsym-literals ( symbol dll -- )
|
||||||
>r string>symbol r> 2array literal-table get push-all ;
|
>r string>symbol r> 2array literal-table get push-all ;
|
||||||
|
|
|
||||||
|
|
@ -147,12 +147,16 @@ M: method-body forget*
|
||||||
[ implementors ] [ [ swap 2array ] curry ] bi map forget-all ;
|
[ implementors ] [ [ swap 2array ] curry ] bi map forget-all ;
|
||||||
|
|
||||||
M: class forget* ( class -- )
|
M: class forget* ( class -- )
|
||||||
{
|
[
|
||||||
|
class-usages [
|
||||||
|
drop
|
||||||
[ forget-methods ]
|
[ forget-methods ]
|
||||||
[ update-map- ]
|
[ update-map- ]
|
||||||
[ reset-class ]
|
[ reset-class ]
|
||||||
[ call-next-method ]
|
tri
|
||||||
} cleave ;
|
] assoc-each
|
||||||
|
]
|
||||||
|
[ call-next-method ] bi ;
|
||||||
|
|
||||||
M: assoc update-methods ( assoc -- )
|
M: assoc update-methods ( assoc -- )
|
||||||
implementors* [ make-generic ] each ;
|
implementors* [ make-generic ] each ;
|
||||||
|
|
|
||||||
|
|
@ -22,8 +22,7 @@ C: <predicate-dispatch-engine> predicate-dispatch-engine
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
: sort-methods ( assoc -- assoc' )
|
: sort-methods ( assoc -- assoc' )
|
||||||
[ keys sort-classes ]
|
>alist [ keys sort-classes ] keep extract-keys ;
|
||||||
[ [ dupd at ] curry ] bi { } map>assoc ;
|
|
||||||
|
|
||||||
M: predicate-dispatch-engine engine>quot
|
M: predicate-dispatch-engine engine>quot
|
||||||
methods>> clone
|
methods>> clone
|
||||||
|
|
|
||||||
|
|
@ -152,16 +152,16 @@ M: pair apply-constraint
|
||||||
M: pair constraint-satisfied?
|
M: pair constraint-satisfied?
|
||||||
first constraint-satisfied? ;
|
first constraint-satisfied? ;
|
||||||
|
|
||||||
: extract-keys ( seq assoc -- newassoc )
|
: valid-keys ( seq assoc -- newassoc )
|
||||||
[ dupd at ] curry H{ } map>assoc [ nip ] assoc-filter f assoc-like ;
|
extract-keys [ nip ] assoc-filter f assoc-like ;
|
||||||
|
|
||||||
: annotate-node ( node -- )
|
: annotate-node ( node -- )
|
||||||
#! Annotate the node with the currently-inferred set of
|
#! Annotate the node with the currently-inferred set of
|
||||||
#! value classes.
|
#! value classes.
|
||||||
dup node-values {
|
dup node-values {
|
||||||
[ value-intervals get extract-keys >>intervals ]
|
[ value-intervals get valid-keys >>intervals ]
|
||||||
[ value-classes get extract-keys >>classes ]
|
[ value-classes get valid-keys >>classes ]
|
||||||
[ value-literals get extract-keys >>literals ]
|
[ value-literals get valid-keys >>literals ]
|
||||||
[ 2drop ]
|
[ 2drop ]
|
||||||
} cleave ;
|
} cleave ;
|
||||||
|
|
||||||
|
|
@ -330,7 +330,7 @@ M: #return infer-classes-around
|
||||||
[ ] [ node-input-classes ] [ in-d>> [ value-class* ] map ] tri
|
[ ] [ node-input-classes ] [ in-d>> [ value-class* ] map ] tri
|
||||||
classes= not [
|
classes= not [
|
||||||
fixed-point? off
|
fixed-point? off
|
||||||
[ in-d>> value-classes get extract-keys ] keep
|
[ in-d>> value-classes get valid-keys ] keep
|
||||||
set-node-classes
|
set-node-classes
|
||||||
] [ drop ] if
|
] [ drop ] if
|
||||||
] [ call-next-method ] if
|
] [ call-next-method ] if
|
||||||
|
|
|
||||||
|
|
@ -460,3 +460,30 @@ must-fail-with
|
||||||
"change-combination" "parser.tests" lookup
|
"change-combination" "parser.tests" lookup
|
||||||
"methods" word-prop assoc-size
|
"methods" word-prop assoc-size
|
||||||
] unit-test
|
] 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
|
||||||
|
|
|
||||||
|
|
@ -236,7 +236,7 @@ PREDICATE: unexpected-eof < unexpected
|
||||||
ERROR: no-current-vocab ;
|
ERROR: no-current-vocab ;
|
||||||
|
|
||||||
M: no-current-vocab summary ( obj -- )
|
M: no-current-vocab summary ( obj -- )
|
||||||
drop "Current vocabulary is f, use IN:" ;
|
drop "Not in a vocabulary; IN: form required" ;
|
||||||
|
|
||||||
: current-vocab ( -- str )
|
: current-vocab ( -- str )
|
||||||
in get [ no-current-vocab ] unless* ;
|
in get [ no-current-vocab ] unless* ;
|
||||||
|
|
@ -357,10 +357,9 @@ M: staging-violation summary
|
||||||
"A parsing word cannot be used in the same file it is defined in." ;
|
"A parsing word cannot be used in the same file it is defined in." ;
|
||||||
|
|
||||||
: execute-parsing ( word -- )
|
: execute-parsing ( word -- )
|
||||||
new-definitions get [
|
[ changed-definitions get key? [ staging-violation ] when ]
|
||||||
dupd first key? [ staging-violation ] when
|
[ execute ]
|
||||||
] when*
|
bi ;
|
||||||
execute ;
|
|
||||||
|
|
||||||
: parse-step ( accum end -- accum ? )
|
: parse-step ( accum end -- accum ? )
|
||||||
scan-word {
|
scan-word {
|
||||||
|
|
|
||||||
|
|
@ -342,3 +342,5 @@ INTERSECTION: intersection-see-test sequence number ;
|
||||||
|
|
||||||
[ ] [ \ compose see ] unit-test
|
[ ] [ \ compose see ] unit-test
|
||||||
[ ] [ \ curry see ] unit-test
|
[ ] [ \ curry see ] unit-test
|
||||||
|
|
||||||
|
[ "POSTPONE: [" ] [ \ [ unparse ] unit-test
|
||||||
|
|
|
||||||
|
|
@ -191,7 +191,6 @@ $nl
|
||||||
"Other destructive words:"
|
"Other destructive words:"
|
||||||
{ $subsection move }
|
{ $subsection move }
|
||||||
{ $subsection exchange }
|
{ $subsection exchange }
|
||||||
{ $subsection push-new }
|
|
||||||
{ $subsection copy }
|
{ $subsection copy }
|
||||||
{ $subsection replace-slice }
|
{ $subsection replace-slice }
|
||||||
{ $see-also set-nth push pop "sequences-stacks" } ;
|
{ $see-also set-nth push pop "sequences-stacks" } ;
|
||||||
|
|
@ -624,22 +623,7 @@ HELP: replace-slice
|
||||||
{ $errors "Throws an error if " { $snippet "new" } " contains elements whose types are not permissible in " { $snippet "seq" } "." }
|
{ $errors "Throws an error if " { $snippet "new" } " contains elements whose types are not permissible in " { $snippet "seq" } "." }
|
||||||
{ $side-effects "seq" } ;
|
{ $side-effects "seq" } ;
|
||||||
|
|
||||||
HELP: push-new
|
{ push prefix suffix } related-words
|
||||||
{ $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
|
|
||||||
|
|
||||||
HELP: suffix
|
HELP: suffix
|
||||||
{ $values { "seq" sequence } { "elt" object } { "newseq" sequence } }
|
{ $values { "seq" sequence } { "elt" object } { "newseq" sequence } }
|
||||||
|
|
|
||||||
|
|
@ -215,12 +215,6 @@ unit-test
|
||||||
3 V{ 1 2 3 4 5 6 } clone [ delete-nth ] keep
|
3 V{ 1 2 3 4 5 6 } clone [ delete-nth ] keep
|
||||||
] unit-test
|
] 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
|
! erg's random tester found this one
|
||||||
[ SBUF" 12341234" ] [
|
[ SBUF" 12341234" ] [
|
||||||
9 <sbuf> dup "1234" swap push-all dup dup swap push-all
|
9 <sbuf> dup "1234" swap push-all dup dup swap push-all
|
||||||
|
|
|
||||||
|
|
@ -499,8 +499,6 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
|
||||||
|
|
||||||
: delete ( elt seq -- ) 0 0 rot (delete) nip set-length drop ;
|
: delete ( elt seq -- ) 0 0 rot (delete) nip set-length drop ;
|
||||||
|
|
||||||
: push-new ( elt seq -- ) [ delete ] 2keep push ;
|
|
||||||
|
|
||||||
: prefix ( seq elt -- newseq )
|
: prefix ( seq elt -- newseq )
|
||||||
over >r over length 1+ r> [
|
over >r over length 1+ r> [
|
||||||
[ 0 swap set-nth-unsafe ] keep
|
[ 0 swap set-nth-unsafe ] keep
|
||||||
|
|
@ -680,7 +678,7 @@ PRIVATE>
|
||||||
: unclip ( seq -- rest first )
|
: unclip ( seq -- rest first )
|
||||||
[ rest ] [ first ] bi ;
|
[ rest ] [ first ] bi ;
|
||||||
|
|
||||||
: unclip-last ( seq -- butfirst last )
|
: unclip-last ( seq -- butlast last )
|
||||||
[ but-last ] [ peek ] bi ;
|
[ but-last ] [ peek ] bi ;
|
||||||
|
|
||||||
: unclip-slice ( seq -- rest first )
|
: unclip-slice ( seq -- rest first )
|
||||||
|
|
|
||||||
|
|
@ -16,10 +16,28 @@ $nl
|
||||||
{ $subsection set= }
|
{ $subsection set= }
|
||||||
"A word used to implement the above:"
|
"A word used to implement the above:"
|
||||||
{ $subsection unique }
|
{ $subsection unique }
|
||||||
|
"Adding elements to sets:"
|
||||||
|
{ $subsection adjoin }
|
||||||
|
{ $subsection conjoin }
|
||||||
{ $see-also member? memq? contains? all? "assocs-sets" } ;
|
{ $see-also member? memq? contains? all? "assocs-sets" } ;
|
||||||
|
|
||||||
ABOUT: "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
|
HELP: unique
|
||||||
{ $values { "seq" "a sequence" } { "assoc" "an assoc" } }
|
{ $values { "seq" "a sequence" } { "assoc" "an assoc" } }
|
||||||
{ $description "Outputs a new assoc where the keys and values are equal." }
|
{ $description "Outputs a new assoc where the keys and values are equal." }
|
||||||
|
|
|
||||||
|
|
@ -15,3 +15,9 @@ IN: sets.tests
|
||||||
|
|
||||||
[ V{ } ] [ { } { } union ] unit-test
|
[ V{ } ] [ { } { } union ] unit-test
|
||||||
[ V{ 1 2 3 4 } ] [ { 1 2 3 } { 2 3 4 } 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
|
||||||
|
|
|
||||||
|
|
@ -3,10 +3,14 @@
|
||||||
USING: assocs hashtables kernel sequences vectors ;
|
USING: assocs hashtables kernel sequences vectors ;
|
||||||
IN: sets
|
IN: sets
|
||||||
|
|
||||||
|
: adjoin ( elt seq -- ) [ delete ] [ push ] 2bi ;
|
||||||
|
|
||||||
|
: conjoin ( elt assoc -- ) dupd set-at ;
|
||||||
|
|
||||||
: (prune) ( elt hash vec -- )
|
: (prune) ( elt hash vec -- )
|
||||||
3dup drop key?
|
3dup drop key? [ 3drop ] [
|
||||||
[ [ drop dupd set-at ] [ nip push ] [ ] 3tri ] unless
|
[ drop conjoin ] [ nip push ] 3bi
|
||||||
3drop ; inline
|
] if ; inline
|
||||||
|
|
||||||
: prune ( seq -- newseq )
|
: prune ( seq -- newseq )
|
||||||
[ ] [ length <hashtable> ] [ length <vector> ] tri
|
[ ] [ length <hashtable> ] [ length <vector> ] tri
|
||||||
|
|
@ -16,7 +20,7 @@ IN: sets
|
||||||
[ dup ] H{ } map>assoc ;
|
[ dup ] H{ } map>assoc ;
|
||||||
|
|
||||||
: (all-unique?) ( elt hash -- ? )
|
: (all-unique?) ( elt hash -- ? )
|
||||||
2dup key? [ 2drop f ] [ dupd set-at t ] if ;
|
2dup key? [ 2drop f ] [ conjoin t ] if ;
|
||||||
|
|
||||||
: all-unique? ( seq -- ? )
|
: all-unique? ( seq -- ? )
|
||||||
dup length <hashtable> [ (all-unique?) ] curry all? ;
|
dup length <hashtable> [ (all-unique?) ] curry all? ;
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,25 @@
|
||||||
USING: help.markup help.syntax sequences strings ;
|
USING: help.markup help.syntax sequences strings ;
|
||||||
IN: splitting
|
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"
|
ARTICLE: "sequences-split" "Splitting sequences"
|
||||||
"Splitting sequences at occurrences of subsequences:"
|
"Splitting sequences at occurrences of subsequences:"
|
||||||
{ $subsection ?head }
|
{ $subsection ?head }
|
||||||
|
|
@ -9,14 +28,9 @@ ARTICLE: "sequences-split" "Splitting sequences"
|
||||||
{ $subsection ?tail-slice }
|
{ $subsection ?tail-slice }
|
||||||
{ $subsection split1 }
|
{ $subsection split1 }
|
||||||
{ $subsection split }
|
{ $subsection split }
|
||||||
"Grouping elements:"
|
|
||||||
{ $subsection group }
|
|
||||||
"A virtual sequence for grouping elements:"
|
|
||||||
{ $subsection groups }
|
|
||||||
{ $subsection <groups> }
|
|
||||||
{ $subsection <sliced-groups> }
|
|
||||||
"Splitting a string into lines:"
|
"Splitting a string into lines:"
|
||||||
{ $subsection string-lines } ;
|
{ $subsection string-lines }
|
||||||
|
{ $subsection "groups-clumps" } ;
|
||||||
|
|
||||||
ABOUT: "sequences-split"
|
ABOUT: "sequences-split"
|
||||||
|
|
||||||
|
|
@ -36,19 +50,22 @@ HELP: split
|
||||||
{ $examples { $example "USING: prettyprint splitting ;" "\"hello world-how are you?\" \" -\" split ." "{ \"hello\" \"world\" \"how\" \"are\" \"you?\" }" } } ;
|
{ $examples { $example "USING: prettyprint splitting ;" "\"hello world-how are you?\" \" -\" split ." "{ \"hello\" \"world\" \"how\" \"are\" \"you?\" }" } } ;
|
||||||
|
|
||||||
HELP: groups
|
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
|
$nl
|
||||||
"New groups are created by calling " { $link <groups> } " and " { $link <sliced-groups> } "." }
|
"New groups are created by calling " { $link <groups> } " and " { $link <sliced-groups> } "." }
|
||||||
{ $see-also group } ;
|
{ $see-also group } ;
|
||||||
|
|
||||||
HELP: group
|
HELP: group
|
||||||
{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "array" "a sequence of sequences" } }
|
{ $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." }
|
{ $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." } ;
|
{ $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>
|
HELP: <groups>
|
||||||
{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "groups" 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
|
{ $examples
|
||||||
{ $example
|
{ $example
|
||||||
"USING: arrays kernel prettyprint sequences splitting ;"
|
"USING: arrays kernel prettyprint sequences splitting ;"
|
||||||
|
|
@ -58,7 +75,7 @@ HELP: <groups>
|
||||||
|
|
||||||
HELP: <sliced-groups>
|
HELP: <sliced-groups>
|
||||||
{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "groups" 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
|
{ $examples
|
||||||
{ $example
|
{ $example
|
||||||
"USING: arrays kernel prettyprint sequences splitting ;"
|
"USING: arrays kernel prettyprint sequences splitting ;"
|
||||||
|
|
@ -68,7 +85,46 @@ HELP: <sliced-groups>
|
||||||
}
|
}
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
{ 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
|
HELP: ?head
|
||||||
{ $values { "seq" "a sequence" } { "begin" "a sequence" } { "newseq" "a new sequence" } { "?" "a boolean" } }
|
{ $values { "seq" "a sequence" } { "begin" "a sequence" } { "newseq" "a new sequence" } { "?" "a boolean" } }
|
||||||
|
|
|
||||||
|
|
@ -44,7 +44,7 @@ M: sliced-groups nth group@ <slice> ;
|
||||||
|
|
||||||
TUPLE: clumps < abstract-groups ;
|
TUPLE: clumps < abstract-groups ;
|
||||||
|
|
||||||
: <clumps> ( seq n -- groups )
|
: <clumps> ( seq n -- clumps )
|
||||||
clumps construct-groups ; inline
|
clumps construct-groups ; inline
|
||||||
|
|
||||||
M: clumps length
|
M: clumps length
|
||||||
|
|
@ -58,7 +58,7 @@ M: clumps group@
|
||||||
|
|
||||||
TUPLE: sliced-clumps < groups ;
|
TUPLE: sliced-clumps < groups ;
|
||||||
|
|
||||||
: <sliced-clumps> ( seq n -- groups )
|
: <sliced-clumps> ( seq n -- clumps )
|
||||||
sliced-clumps construct-groups ; inline
|
sliced-clumps construct-groups ; inline
|
||||||
|
|
||||||
M: sliced-clumps nth group@ <slice> ;
|
M: sliced-clumps nth group@ <slice> ;
|
||||||
|
|
|
||||||
|
|
@ -100,8 +100,8 @@ IN: bootstrap.syntax
|
||||||
] define-syntax
|
] define-syntax
|
||||||
|
|
||||||
"DEFER:" [
|
"DEFER:" [
|
||||||
scan in get create
|
scan current-vocab create
|
||||||
dup old-definitions get first delete-at
|
dup old-definitions get [ delete-at ] with each
|
||||||
set-word
|
set-word
|
||||||
] define-syntax
|
] define-syntax
|
||||||
|
|
||||||
|
|
@ -189,8 +189,9 @@ IN: bootstrap.syntax
|
||||||
"MAIN:" [ scan-word in get vocab set-vocab-main ] 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
|
] define-syntax
|
||||||
|
|
||||||
"call-next-method" [
|
"call-next-method" [
|
||||||
|
|
|
||||||
|
|
@ -175,7 +175,9 @@ PRIVATE>
|
||||||
: define-symbol ( word -- )
|
: define-symbol ( word -- )
|
||||||
dup [ ] curry define-inline ;
|
dup [ ] curry define-inline ;
|
||||||
|
|
||||||
: reset-word ( word -- )
|
GENERIC: reset-word ( word -- )
|
||||||
|
|
||||||
|
M: word reset-word
|
||||||
{
|
{
|
||||||
"unannotated-def"
|
"unannotated-def"
|
||||||
"parsing" "inline" "foldable" "flushable"
|
"parsing" "inline" "foldable" "flushable"
|
||||||
|
|
|
||||||
|
|
@ -1,5 +1,5 @@
|
||||||
USING: arrays assocs kernel vectors sequences namespaces
|
USING: arrays assocs kernel vectors sequences namespaces
|
||||||
random math.parser ;
|
random math.parser math fry ;
|
||||||
IN: assocs.lib
|
IN: assocs.lib
|
||||||
|
|
||||||
: ref-at ( table key -- value ) swap at ;
|
: ref-at ( table key -- value ) swap at ;
|
||||||
|
|
@ -40,3 +40,8 @@ IN: assocs.lib
|
||||||
|
|
||||||
: set-at-unique ( value assoc -- key )
|
: set-at-unique ( value assoc -- key )
|
||||||
dup generate-key [ swap set-at ] keep ;
|
dup generate-key [ swap set-at ] keep ;
|
||||||
|
|
||||||
|
: histogram ( assoc quot -- assoc' )
|
||||||
|
H{ } clone [
|
||||||
|
swap [ change-at ] 2curry assoc-each
|
||||||
|
] keep ;
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,20 @@
|
||||||
|
USING: cairo.pango cairo cairo.ffi cairo.gadgets
|
||||||
|
alien.c-types kernel math ;
|
||||||
|
IN: cairo.pango.gadgets
|
||||||
|
|
||||||
|
: (pango-gadget) ( setup show -- gadget )
|
||||||
|
[ drop layout-size ]
|
||||||
|
[ compose [ with-pango ] curry <cached-cairo> ] 2bi ;
|
||||||
|
|
||||||
|
: <pango-gadget> ( quot -- gadget )
|
||||||
|
[ cr layout pango_cairo_show_layout ] (pango-gadget) ;
|
||||||
|
|
||||||
|
USING: prettyprint sequences ui.gadgets.panes ;
|
||||||
|
: hello-pango ( -- )
|
||||||
|
50 [ 6 + ] map [
|
||||||
|
"Sans Bold " swap unparse append
|
||||||
|
[ layout-font "Hello, Pango!" layout-text ] curry
|
||||||
|
<pango-gadget> gadget.
|
||||||
|
] each ;
|
||||||
|
|
||||||
|
MAIN: hello-pango
|
||||||
|
|
@ -0,0 +1,175 @@
|
||||||
|
! 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 ;
|
||||||
|
IN: cairo.pango
|
||||||
|
|
||||||
|
<< "pangocairo" {
|
||||||
|
! { [ os winnt? ] [ "libpangocairo-1.dll" ] }
|
||||||
|
! { [ os macosx? ] [ "libpangocairo.dylib" ] }
|
||||||
|
{ [ os unix? ] [ "libpangocairo-1.0.so" ] }
|
||||||
|
} cond "cdecl" add-library >>
|
||||||
|
|
||||||
|
LIBRARY: pangocairo
|
||||||
|
|
||||||
|
TYPEDEF: void* PangoCairoFont
|
||||||
|
TYPEDEF: void* PangoCairoFontMap
|
||||||
|
TYPEDEF: void* PangoFontMap
|
||||||
|
|
||||||
|
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 ) ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
! Helpful functions from other parts of 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 ) ;
|
||||||
|
|
||||||
|
TYPEDEF: void* PangoFontDescription
|
||||||
|
|
||||||
|
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 ) ;
|
||||||
|
|
||||||
|
TYPEDEF: void* gpointer
|
||||||
|
|
||||||
|
FUNCTION: void
|
||||||
|
g_object_unref ( gpointer object ) ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
! 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 -- width height )
|
||||||
|
[ layout pango-layout-get-pixel-size ] 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 ;
|
||||||
|
|
@ -116,11 +116,11 @@ IN: cairo.samples
|
||||||
cr cairo_fill ;
|
cr cairo_fill ;
|
||||||
|
|
||||||
: utf8 ( -- )
|
: 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
|
cairo_select_font_face
|
||||||
cr 50 cairo_set_font_size
|
cr 50 cairo_set_font_size
|
||||||
"cairo_text_extents_t" malloc-object
|
"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
|
cr over
|
||||||
[ cairo_text_extents_t-width 2 / ]
|
[ cairo_text_extents_t-width 2 / ]
|
||||||
[ cairo_text_extents_t-x_bearing ] bi +
|
[ cairo_text_extents_t-x_bearing ] bi +
|
||||||
|
|
@ -129,7 +129,7 @@ IN: cairo.samples
|
||||||
[ cairo_text_extents_t-y_bearing ] bi +
|
[ cairo_text_extents_t-y_bearing ] bi +
|
||||||
128 swap - cairo_move_to
|
128 swap - cairo_move_to
|
||||||
free
|
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 1 0.2 0.2 0.6 cairo_set_source_rgba
|
||||||
cr 6 cairo_set_line_width
|
cr 6 cairo_set_line_width
|
||||||
|
|
|
||||||
|
|
@ -50,3 +50,15 @@ IN: calendar.format.tests
|
||||||
"Sun May 04 07:00:00 2008 GMT" cookie-string>timestamp
|
"Sun May 04 07:00:00 2008 GMT" cookie-string>timestamp
|
||||||
timestamp>string
|
timestamp>string
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
[
|
||||||
|
T{ timestamp f
|
||||||
|
2008
|
||||||
|
5
|
||||||
|
26
|
||||||
|
0
|
||||||
|
37
|
||||||
|
42.12345
|
||||||
|
T{ duration f 0 0 0 -5 0 0 }
|
||||||
|
}
|
||||||
|
] [ "2008-05-26T00:37:42.12345-05:00" rfc3339>timestamp ] unit-test
|
||||||
|
|
|
||||||
|
|
@ -1,4 +1,4 @@
|
||||||
USING: math math.order math.parser kernel sequences io
|
USING: math math.order math.parser math.functions kernel sequences io
|
||||||
accessors arrays io.streams.string splitting
|
accessors arrays io.streams.string splitting
|
||||||
combinators accessors debugger
|
combinators accessors debugger
|
||||||
calendar calendar.format.macros ;
|
calendar calendar.format.macros ;
|
||||||
|
|
@ -151,11 +151,15 @@ M: timestamp year. ( timestamp -- )
|
||||||
: read-hms ( -- h m s )
|
: read-hms ( -- h m s )
|
||||||
read-00 ":" expect read-00 ":" expect read-00 ;
|
read-00 ":" expect read-00 ":" expect read-00 ;
|
||||||
|
|
||||||
|
: read-rfc3339-seconds ( s -- s' ch )
|
||||||
|
"+-Z" read-until >r
|
||||||
|
[ string>number ] [ length 10 swap ^ ] bi / + r> ;
|
||||||
|
|
||||||
: (rfc3339>timestamp) ( -- timestamp )
|
: (rfc3339>timestamp) ( -- timestamp )
|
||||||
read-ymd
|
read-ymd
|
||||||
"Tt" expect
|
"Tt" expect
|
||||||
read-hms
|
read-hms
|
||||||
read1 { { CHAR: . [ read-000 1000 / + read1 ] } [ ] } case
|
read1 { { CHAR: . [ read-rfc3339-seconds ] } [ ] } case
|
||||||
read-rfc3339-gmt-offset
|
read-rfc3339-gmt-offset
|
||||||
<timestamp> ;
|
<timestamp> ;
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -77,8 +77,21 @@ MACRO: <--&& ( quots -- )
|
||||||
[ [ 2dup ] prepend [ not ] append [ f ] ] t short-circuit
|
[ [ 2dup ] prepend [ not ] append [ f ] ] t short-circuit
|
||||||
[ 2nip ] append ;
|
[ 2nip ] append ;
|
||||||
|
|
||||||
|
! or
|
||||||
|
|
||||||
MACRO: || ( quots -- ? ) [ [ t ] ] f short-circuit ;
|
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 -- ? )
|
||||||
|
[ [ 2dup ] prepend [ t ] ] f short-circuit [ 2nip ] append ;
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
! ifte
|
! ifte
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
|
||||||
|
|
@ -127,7 +127,7 @@ M: nonthrowable execute-statement* ( statement type -- )
|
||||||
: query-map ( statement quot -- seq )
|
: query-map ( statement quot -- seq )
|
||||||
accumulator >r query-each r> { } like ; inline
|
accumulator >r query-each r> { } like ; inline
|
||||||
|
|
||||||
: with-db ( db seq quot -- )
|
: with-db ( seq class quot -- )
|
||||||
>r make-db db-open db r>
|
>r make-db db-open db r>
|
||||||
[ db get swap [ drop ] prepose with-disposal ] curry with-variable ;
|
[ db get swap [ drop ] prepose with-disposal ] curry with-variable ;
|
||||||
inline
|
inline
|
||||||
|
|
|
||||||
|
|
@ -6,16 +6,16 @@ IN: db.pools
|
||||||
|
|
||||||
TUPLE: db-pool < pool db params ;
|
TUPLE: db-pool < pool db params ;
|
||||||
|
|
||||||
: <db-pool> ( db params -- pool )
|
: <db-pool> ( params db -- pool )
|
||||||
db-pool <pool>
|
db-pool <pool>
|
||||||
swap >>params
|
swap >>db
|
||||||
swap >>db ;
|
swap >>params ;
|
||||||
|
|
||||||
: with-db-pool ( db params quot -- )
|
: with-db-pool ( db params quot -- )
|
||||||
>r <db-pool> r> with-pool ; inline
|
>r <db-pool> r> with-pool ; inline
|
||||||
|
|
||||||
M: db-pool make-connection ( pool -- )
|
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 -- )
|
: with-pooled-db ( pool quot -- )
|
||||||
[ db swap with-variable ] curry with-pooled-connection ; inline
|
[ db swap with-variable ] curry with-pooled-connection ; inline
|
||||||
|
|
|
||||||
|
|
@ -414,6 +414,25 @@ TUPLE: does-not-persist ;
|
||||||
[ class \ not-persistent = ] must-fail-with
|
[ class \ not-persistent = ] must-fail-with
|
||||||
] test-postgresql
|
] test-postgresql
|
||||||
|
|
||||||
|
|
||||||
|
TUPLE: suparclass a ;
|
||||||
|
|
||||||
|
suparclass f {
|
||||||
|
{ "id" "ID" +db-assigned-id+ }
|
||||||
|
{ "a" "A" INTEGER }
|
||||||
|
} define-persistent
|
||||||
|
|
||||||
|
TUPLE: subbclass < suparclass b ;
|
||||||
|
|
||||||
|
subbclass "SUBCLASS" {
|
||||||
|
{ "b" "B" TEXT }
|
||||||
|
} define-persistent
|
||||||
|
|
||||||
|
: test-db-inheritance ( -- )
|
||||||
|
[ ] [ subbclass ensure-table ] unit-test ;
|
||||||
|
|
||||||
|
[ test-db-inheritance ] test-sqlite
|
||||||
|
|
||||||
! Don't comment these out. These words must infer
|
! Don't comment these out. These words must infer
|
||||||
\ bind-tuple must-infer
|
\ bind-tuple must-infer
|
||||||
\ insert-tuple must-infer
|
\ insert-tuple must-infer
|
||||||
|
|
|
||||||
|
|
@ -19,7 +19,7 @@ ERROR: not-persistent ;
|
||||||
"db-table" word-prop [ not-persistent ] unless* ;
|
"db-table" word-prop [ not-persistent ] unless* ;
|
||||||
|
|
||||||
: db-columns ( class -- obj )
|
: db-columns ( class -- obj )
|
||||||
"db-columns" word-prop ;
|
superclasses [ "db-columns" word-prop ] map concat ;
|
||||||
|
|
||||||
: db-relations ( class -- obj )
|
: db-relations ( class -- obj )
|
||||||
"db-relations" word-prop ;
|
"db-relations" word-prop ;
|
||||||
|
|
|
||||||
|
|
@ -68,7 +68,7 @@ SYMBOL: NX
|
||||||
|
|
||||||
: expired? ( entry -- ? ) time>> time->ttl 0 <= ;
|
: expired? ( entry -- ? ) time>> time->ttl 0 <= ;
|
||||||
|
|
||||||
: cache-get ( query -- result )
|
: cache-get* ( query -- rrs/NX/f )
|
||||||
dup table-get ! query result
|
dup table-get ! query result
|
||||||
{
|
{
|
||||||
{ [ dup f = ] [ 2drop f ] } ! not in the cache
|
{ [ dup f = ] [ 2drop f ] } ! not in the cache
|
||||||
|
|
@ -80,6 +80,15 @@ SYMBOL: NX
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
ERROR: name-error name ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: cache-get ( query -- rrs/f )
|
||||||
|
dup cache-get* dup NX = [ drop name>> name-error ] [ nip ] if ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
: rr->entry ( rr -- entry )
|
: rr->entry ( rr -- entry )
|
||||||
[ ttl>> ttl->time ] [ rdata>> {1} >vector ] bi entry boa ;
|
[ ttl>> ttl->time ] [ rdata>> {1} >vector ] bi entry boa ;
|
||||||
|
|
||||||
|
|
@ -110,3 +119,31 @@ SYMBOL: NX
|
||||||
: cache-add-rr ( rr -- ) [ rr->query ] [ ] bi cache-add ;
|
: cache-add-rr ( rr -- ) [ rr->query ] [ ] bi cache-add ;
|
||||||
|
|
||||||
: cache-add-rrs ( rrs -- ) [ cache-add-rr ] each ;
|
: 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 ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -38,7 +38,7 @@ TUPLE: message
|
||||||
! TYPE
|
! 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 )
|
: type-table ( -- table )
|
||||||
{
|
{
|
||||||
|
|
@ -58,6 +58,7 @@ SYMBOLS: A NS MD MF CNAME SOA MB MG MR NULL WKS PTR HINFO MINFO MX TXT ;
|
||||||
{ MINFO 14 }
|
{ MINFO 14 }
|
||||||
{ MX 15 }
|
{ MX 15 }
|
||||||
{ TXT 16 }
|
{ TXT 16 }
|
||||||
|
{ AAAA 28 }
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
@ -126,6 +127,8 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
|
||||||
|
|
||||||
: ip->ba ( ip -- ba ) "." split [ string>number ] map >byte-array ;
|
: 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 ;
|
: label->ba ( label -- ba ) [ >byte-array ] [ length ] bi prefix ;
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
@ -330,6 +333,13 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
|
||||||
|
|
||||||
: get-ip ( ba i -- ip ) dup 4 + subseq >array [ number>string ] map "." join ;
|
: 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 )
|
: get-rdata ( ba i type -- rdata )
|
||||||
{
|
{
|
||||||
{ CNAME [ get-name ] }
|
{ CNAME [ get-name ] }
|
||||||
|
|
@ -338,6 +348,7 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
|
||||||
{ MX [ get-mx ] }
|
{ MX [ get-mx ] }
|
||||||
{ SOA [ get-soa ] }
|
{ SOA [ get-soa ] }
|
||||||
{ A [ get-ip ] }
|
{ A [ get-ip ] }
|
||||||
|
{ AAAA [ get-ipv6 ] }
|
||||||
}
|
}
|
||||||
case ;
|
case ;
|
||||||
|
|
||||||
|
|
@ -459,4 +470,9 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
|
||||||
|
|
||||||
: ask ( message -- message ) dns-server ask-server ;
|
: ask ( message -- message ) dns-server ask-server ;
|
||||||
|
|
||||||
: <query-message> ( query -- message ) <message> swap {1} >>question-section ;
|
: query->message ( query -- message ) <message> swap {1} >>question-section ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: message-query ( message -- query ) question-section>> 1st ;
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,185 @@
|
||||||
|
|
||||||
|
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 ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
@ -62,7 +62,7 @@ IN: dns.resolver
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
: canonical/server ( name -- name )
|
: canonical/server ( name -- name )
|
||||||
dup CNAME IN query boa <query-message> ask* answer-section>>
|
dup CNAME IN query boa query->message ask* answer-section>>
|
||||||
[ type>> CNAME = ] filter dup empty? not
|
[ type>> CNAME = ] filter dup empty? not
|
||||||
[ nip 1st rdata>> ]
|
[ nip 1st rdata>> ]
|
||||||
[ drop ]
|
[ drop ]
|
||||||
|
|
@ -70,7 +70,7 @@ IN: dns.resolver
|
||||||
|
|
||||||
: name->ip/server ( name -- ip )
|
: name->ip/server ( name -- ip )
|
||||||
canonical/server
|
canonical/server
|
||||||
dup A IN query boa <query-message> ask* answer-section>>
|
dup A IN query boa query->message ask* answer-section>>
|
||||||
[ type>> A = ] filter dup empty? not
|
[ type>> A = ] filter dup empty? not
|
||||||
[ nip random rdata>> ]
|
[ nip random rdata>> ]
|
||||||
[ 2drop f ]
|
[ 2drop f ]
|
||||||
|
|
|
||||||
|
|
@ -62,12 +62,23 @@ IN: farkup.tests
|
||||||
[ "<p>=</p><h2>foo</h2>" ] [ "===foo==" convert-farkup ] unit-test
|
[ "<p>=</p><h2>foo</h2>" ] [ "===foo==" convert-farkup ] unit-test
|
||||||
[ "<h1>foo</h1><p>=</p>" ] [ "=foo==" convert-farkup ] unit-test
|
[ "<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
|
[ "[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\"/></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><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
|
[ "<p><a href=\"lol.com\">haha</a></p>" ] [ "[[lol.com|haha]]" convert-farkup ] unit-test
|
||||||
|
|
||||||
[ ] [ "[{}]" convert-farkup drop ] 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
|
||||||
|
|
|
||||||
|
|
@ -2,10 +2,13 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: arrays io io.styles kernel memoize namespaces peg
|
USING: arrays io io.styles kernel memoize namespaces peg
|
||||||
sequences strings html.elements xml.entities xmode.code2html
|
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 ;
|
sequences.deep unicode.categories ;
|
||||||
IN: farkup
|
IN: farkup
|
||||||
|
|
||||||
|
SYMBOL: relative-link-prefix
|
||||||
|
SYMBOL: link-no-follow?
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
: delimiters ( -- string )
|
: delimiters ( -- string )
|
||||||
|
|
@ -59,25 +62,30 @@ MEMO: eq ( -- parser )
|
||||||
: render-code ( string mode -- string' )
|
: render-code ( string mode -- string' )
|
||||||
>r string-lines r>
|
>r string-lines r>
|
||||||
[
|
[
|
||||||
[
|
<pre>
|
||||||
H{ { wrap-margin f } } [
|
|
||||||
htmlize-lines
|
htmlize-lines
|
||||||
] with-nesting
|
</pre>
|
||||||
] with-html-stream
|
|
||||||
] with-string-writer ;
|
] with-string-writer ;
|
||||||
|
|
||||||
: check-url ( href -- href' )
|
: check-url ( href -- href' )
|
||||||
CHAR: : over member? [
|
CHAR: : over member? [
|
||||||
dup { "http://" "https://" "ftp://" } [ head? ] with contains?
|
dup { "http://" "https://" "ftp://" } [ head? ] with contains?
|
||||||
[ drop "/" ] unless
|
[ drop "/" ] unless
|
||||||
] when ;
|
] [
|
||||||
|
relative-link-prefix get prepend
|
||||||
|
] if ;
|
||||||
|
|
||||||
: escape-link ( href text -- href-esc text-esc )
|
: escape-link ( href text -- href-esc text-esc )
|
||||||
>r check-url escape-quoted-string r> escape-string ;
|
>r check-url escape-quoted-string r> escape-string ;
|
||||||
|
|
||||||
: make-link ( href text -- seq )
|
: make-link ( href text -- seq )
|
||||||
escape-link
|
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 )
|
: make-image-link ( href alt -- seq )
|
||||||
escape-link
|
escape-link
|
||||||
|
|
@ -102,7 +110,7 @@ MEMO: simple-link ( -- parser )
|
||||||
"[[" token hide ,
|
"[[" token hide ,
|
||||||
[ "|]" member? not ] satisfy repeat1 ,
|
[ "|]" member? not ] satisfy repeat1 ,
|
||||||
"]]" token hide ,
|
"]]" token hide ,
|
||||||
] seq* [ first f make-link ] action ;
|
] seq* [ first dup make-link ] action ;
|
||||||
|
|
||||||
MEMO: labelled-link ( -- parser )
|
MEMO: labelled-link ( -- parser )
|
||||||
[
|
[
|
||||||
|
|
@ -113,12 +121,14 @@ MEMO: labelled-link ( -- parser )
|
||||||
"]]" token hide ,
|
"]]" token hide ,
|
||||||
] seq* [ first2 make-link ] action ;
|
] 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
|
DEFER: line
|
||||||
MEMO: list-item ( -- parser )
|
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 ;
|
] seq* [ "li" surround-with-foo ] action ;
|
||||||
|
|
||||||
MEMO: list ( -- parser )
|
MEMO: list ( -- parser )
|
||||||
|
|
@ -149,6 +159,8 @@ MEMO: code ( -- parser )
|
||||||
|
|
||||||
MEMO: line ( -- parser )
|
MEMO: line ( -- parser )
|
||||||
[
|
[
|
||||||
|
nl table 2seq ,
|
||||||
|
nl list 2seq ,
|
||||||
text , strong , emphasis , link ,
|
text , strong , emphasis , link ,
|
||||||
superscript , subscript , inline-code ,
|
superscript , subscript , inline-code ,
|
||||||
escaped-char , delimiter , eq ,
|
escaped-char , delimiter , eq ,
|
||||||
|
|
|
||||||
|
|
@ -52,3 +52,13 @@ sequences ;
|
||||||
[ { 1 { 2 { 3 } } } ] [
|
[ { 1 { 2 { 3 } } } ] [
|
||||||
1 2 3 '[ , [ , [ , 1array ] call 2array ] call 2array ] call
|
1 2 3 '[ , [ , [ , 1array ] call 2array ] call 2array ] call
|
||||||
] unit-test
|
] 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
|
||||||
|
|
|
||||||
|
|
@ -46,15 +46,22 @@ DEFER: (shallow-fry)
|
||||||
shallow-fry
|
shallow-fry
|
||||||
] if* ;
|
] 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' )
|
: fry ( quot -- quot' )
|
||||||
[
|
[
|
||||||
[
|
[
|
||||||
dup callable? [
|
dup callable? [
|
||||||
[
|
[ count-inputs \ , <repetition> % ] [ fry % ] bi
|
||||||
[ { , namespaces:, @ } member? ] filter length
|
|
||||||
\ , <repetition> %
|
|
||||||
]
|
|
||||||
[ fry % ] bi
|
|
||||||
] [ namespaces:, ] if
|
] [ namespaces:, ] if
|
||||||
] each
|
] each
|
||||||
] [ ] make deep-fry ;
|
] [ ] make deep-fry ;
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,180 @@
|
||||||
|
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
|
||||||
|
|
@ -0,0 +1,224 @@
|
||||||
|
! 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 ;
|
||||||
|
|
@ -1,8 +1,5 @@
|
||||||
IN: html.elements.tests
|
IN: html.elements.tests
|
||||||
USING: tools.test html html.elements io.streams.string ;
|
USING: tools.test html.elements io.streams.string ;
|
||||||
|
|
||||||
: make-html-string
|
|
||||||
[ with-html-stream ] with-string-writer ;
|
|
||||||
|
|
||||||
[ "<a href='h&o'>" ]
|
[ "<a href='h&o'>" ]
|
||||||
[ [ <a "h&o" =href a> ] make-html-string ] unit-test
|
[ [ <a "h&o" =href a> ] with-string-writer ] unit-test
|
||||||
|
|
|
||||||
|
|
@ -57,6 +57,8 @@ SYMBOL: html
|
||||||
: print-html ( str -- )
|
: print-html ( str -- )
|
||||||
write-html "\n" write-html ;
|
write-html "\n" write-html ;
|
||||||
|
|
||||||
|
<<
|
||||||
|
|
||||||
: html-word ( name def effect -- )
|
: html-word ( name def effect -- )
|
||||||
#! Define 'word creating' word to allow
|
#! Define 'word creating' word to allow
|
||||||
#! dynamically creating words.
|
#! dynamically creating words.
|
||||||
|
|
@ -137,7 +139,6 @@ SYMBOL: html
|
||||||
dup "=" prepend swap
|
dup "=" prepend swap
|
||||||
[ write-attr ] curry attribute-effect html-word ;
|
[ write-attr ] curry attribute-effect html-word ;
|
||||||
|
|
||||||
[
|
|
||||||
! Define some closed HTML tags
|
! Define some closed HTML tags
|
||||||
[
|
[
|
||||||
"h1" "h2" "h3" "h4" "h5" "h6" "h7" "h8" "h9"
|
"h1" "h2" "h3" "h4" "h5" "h6" "h7" "h8" "h9"
|
||||||
|
|
@ -163,4 +164,21 @@ SYMBOL: html
|
||||||
"width" "selected" "onsubmit" "xmlns" "lang" "xml:lang"
|
"width" "selected" "onsubmit" "xmlns" "lang" "xml:lang"
|
||||||
"media" "title" "multiple"
|
"media" "title" "multiple"
|
||||||
] [ define-attribute-word ] each
|
] [ define-attribute-word ] each
|
||||||
] with-compilation-unit
|
|
||||||
|
>>
|
||||||
|
|
||||||
|
: 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> ;
|
||||||
|
|
|
||||||
|
|
@ -1,267 +0,0 @@
|
||||||
! 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> ;
|
|
||||||
|
|
@ -1,6 +1,7 @@
|
||||||
USING: html http io io.streams.string io.styles kernel
|
USING: html.streams html.streams.private
|
||||||
namespaces tools.test xml.writer sbufs sequences html.private ;
|
io io.streams.string io.styles kernel
|
||||||
IN: html.tests
|
namespaces tools.test xml.writer sbufs sequences inspector ;
|
||||||
|
IN: html.streams.tests
|
||||||
|
|
||||||
: make-html-string
|
: make-html-string
|
||||||
[ with-html-stream ] with-string-writer ; inline
|
[ with-html-stream ] with-string-writer ; inline
|
||||||
|
|
@ -69,3 +70,5 @@ M: funky browser-link-href
|
||||||
] [
|
] [
|
||||||
[ H{ } [ ] with-nesting nl ] make-html-string
|
[ H{ } [ ] with-nesting nl ] make-html-string
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
[ ] [ [ { 1 2 3 } describe ] with-html-stream ] unit-test
|
||||||
|
|
@ -0,0 +1,195 @@
|
||||||
|
! 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
|
||||||
|
|
@ -1,4 +0,0 @@
|
||||||
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; }
|
|
||||||
|
|
@ -0,0 +1,161 @@
|
||||||
|
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
|
||||||
|
|
@ -3,17 +3,17 @@
|
||||||
USING: accessors kernel sequences combinators kernel namespaces
|
USING: accessors kernel sequences combinators kernel namespaces
|
||||||
classes.tuple assocs splitting words arrays memoize
|
classes.tuple assocs splitting words arrays memoize
|
||||||
io io.files io.encodings.utf8 io.streams.string
|
io io.files io.encodings.utf8 io.streams.string
|
||||||
unicode.case tuple-syntax html html.elements
|
unicode.case tuple-syntax mirrors fry math
|
||||||
multiline xml xml.data xml.writer xml.utilities
|
multiline xml xml.data xml.writer xml.utilities
|
||||||
|
html.elements
|
||||||
|
html.components
|
||||||
|
html.templates
|
||||||
http.server
|
http.server
|
||||||
http.server.auth
|
http.server.auth
|
||||||
http.server.flows
|
http.server.flows
|
||||||
http.server.actions
|
http.server.actions
|
||||||
http.server.components
|
http.server.sessions ;
|
||||||
http.server.sessions
|
IN: html.templates.chloe
|
||||||
http.server.templating
|
|
||||||
http.server.boilerplate ;
|
|
||||||
IN: http.server.templating.chloe
|
|
||||||
|
|
||||||
! Chloe is Ed's favorite web designer
|
! Chloe is Ed's favorite web designer
|
||||||
|
|
||||||
|
|
@ -52,8 +52,11 @@ MEMO: chloe-name ( string -- name )
|
||||||
: optional-attr ( tag name -- value )
|
: optional-attr ( tag name -- value )
|
||||||
chloe-name swap at ;
|
chloe-name swap at ;
|
||||||
|
|
||||||
|
: process-tag-children ( tag -- )
|
||||||
|
[ process-template ] each ;
|
||||||
|
|
||||||
: children>string ( tag -- string )
|
: children>string ( tag -- string )
|
||||||
[ [ process-template ] each ] with-string-writer ;
|
[ process-tag-children ] with-string-writer ;
|
||||||
|
|
||||||
: title-tag ( tag -- )
|
: title-tag ( tag -- )
|
||||||
children>string set-title ;
|
children>string set-title ;
|
||||||
|
|
@ -89,18 +92,6 @@ MEMO: chloe-name ( string -- name )
|
||||||
atom-feed get value>> second write
|
atom-feed get value>> second write
|
||||||
] if ;
|
] 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 )
|
: parse-query-attr ( string -- assoc )
|
||||||
dup empty?
|
dup empty?
|
||||||
[ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ;
|
[ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ;
|
||||||
|
|
@ -133,9 +124,6 @@ MEMO: chloe-name ( string -- name )
|
||||||
a>
|
a>
|
||||||
] with-scope ;
|
] with-scope ;
|
||||||
|
|
||||||
: process-tag-children ( tag -- )
|
|
||||||
[ process-template ] each ;
|
|
||||||
|
|
||||||
: a-tag ( tag -- )
|
: a-tag ( tag -- )
|
||||||
[ a-start-tag ]
|
[ a-start-tag ]
|
||||||
[ process-tag-children ]
|
[ process-tag-children ]
|
||||||
|
|
@ -156,7 +144,7 @@ MEMO: chloe-name ( string -- name )
|
||||||
form>
|
form>
|
||||||
] [
|
] [
|
||||||
hidden-form-field
|
hidden-form-field
|
||||||
"for" optional-attr [ component render-edit ] when*
|
"for" optional-attr [ hidden render ] when*
|
||||||
] bi
|
] bi
|
||||||
] with-scope ;
|
] with-scope ;
|
||||||
|
|
||||||
|
|
@ -180,9 +168,9 @@ STRING: button-tag-markup
|
||||||
: button-tag ( tag -- )
|
: button-tag ( tag -- )
|
||||||
button-tag-markup string>xml delegate
|
button-tag-markup string>xml delegate
|
||||||
{
|
{
|
||||||
[ >r tag-attrs chloe-attrs-only r> add-tag-attrs ]
|
[ [ tag-attrs chloe-attrs-only ] dip add-tag-attrs ]
|
||||||
[ >r tag-attrs non-chloe-attrs-only r> "button" tag-named add-tag-attrs ]
|
[ [ tag-attrs non-chloe-attrs-only ] dip "button" tag-named add-tag-attrs ]
|
||||||
[ >r children>string 1array r> "button" tag-named set-tag-children ]
|
[ [ children>string 1array ] dip "button" tag-named set-tag-children ]
|
||||||
[ nip ]
|
[ nip ]
|
||||||
} 2cleave process-chloe-tag ;
|
} 2cleave process-chloe-tag ;
|
||||||
|
|
||||||
|
|
@ -208,30 +196,109 @@ STRING: button-tag-markup
|
||||||
: if-tag ( tag -- )
|
: if-tag ( tag -- )
|
||||||
dup if-satisfied? [ process-tag-children ] [ drop ] if ;
|
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 -- )
|
: error-message-tag ( tag -- )
|
||||||
children>string render-error ;
|
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 -- )
|
: process-chloe-tag ( tag -- )
|
||||||
dup name-tag {
|
dup name-tag {
|
||||||
{ "chloe" [ [ process-template ] each ] }
|
{ "chloe" [ process-tag-children ] }
|
||||||
|
|
||||||
|
! HTML head
|
||||||
{ "title" [ title-tag ] }
|
{ "title" [ title-tag ] }
|
||||||
{ "write-title" [ write-title-tag ] }
|
{ "write-title" [ write-title-tag ] }
|
||||||
{ "style" [ style-tag ] }
|
{ "style" [ style-tag ] }
|
||||||
{ "write-style" [ write-style-tag ] }
|
{ "write-style" [ write-style-tag ] }
|
||||||
{ "atom" [ atom-tag ] }
|
{ "atom" [ atom-tag ] }
|
||||||
{ "write-atom" [ write-atom-tag ] }
|
{ "write-atom" [ write-atom-tag ] }
|
||||||
{ "view" [ view-tag ] }
|
|
||||||
{ "edit" [ edit-tag ] }
|
! HTML elements
|
||||||
{ "summary" [ summary-tag ] }
|
|
||||||
{ "a" [ a-tag ] }
|
{ "a" [ a-tag ] }
|
||||||
{ "form" [ form-tag ] }
|
|
||||||
{ "button" [ button-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 ] }
|
{ "error-message" [ error-message-tag ] }
|
||||||
{ "validation-message" [ drop render-validation-message ] }
|
{ "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 ] }
|
{ "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 ] }
|
{ "comment" [ drop ] }
|
||||||
{ "call-next-template" [ drop call-next-template ] }
|
{ "call-next-template" [ drop call-next-template ] }
|
||||||
[ "Unknown chloe tag: " swap append throw ]
|
|
||||||
|
[ "Unknown chloe tag: " prepend throw ]
|
||||||
} case ;
|
} case ;
|
||||||
|
|
||||||
: process-tag ( tag -- )
|
: process-tag ( tag -- )
|
||||||
|
|
@ -0,0 +1,14 @@
|
||||||
|
<?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>
|
||||||
|
|
@ -0,0 +1,14 @@
|
||||||
|
<?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>
|
||||||
|
|
@ -2,7 +2,7 @@
|
||||||
|
|
||||||
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||||
|
|
||||||
<t:if t:code="http.server.templating.chloe.tests:test4-aux?">
|
<t:if t:code="html.templates.chloe.tests:test4-aux?">
|
||||||
True
|
True
|
||||||
</t:if>
|
</t:if>
|
||||||
|
|
||||||
|
|
@ -2,7 +2,7 @@
|
||||||
|
|
||||||
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||||
|
|
||||||
<t:if t:code="http.server.templating.chloe.tests:test5-aux?">
|
<t:if t:code="html.templates.chloe.tests:test5-aux?">
|
||||||
True
|
True
|
||||||
</t:if>
|
</t:if>
|
||||||
|
|
||||||
|
|
@ -2,7 +2,7 @@
|
||||||
|
|
||||||
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||||
|
|
||||||
<t:if t:var="http.server.templating.chloe.tests:test6-aux?">
|
<t:if t:var="html.templates.chloe.tests:test6-aux?">
|
||||||
True
|
True
|
||||||
</t:if>
|
</t:if>
|
||||||
|
|
||||||
|
|
@ -2,7 +2,7 @@
|
||||||
|
|
||||||
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||||
|
|
||||||
<t:if t:var="http.server.templating.chloe.tests:test7-aux?">
|
<t:if t:var="html.templates.chloe.tests:test7-aux?">
|
||||||
True
|
True
|
||||||
</t:if>
|
</t:if>
|
||||||
|
|
||||||
|
|
@ -0,0 +1,27 @@
|
||||||
|
<?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>
|
||||||
|
|
@ -0,0 +1,11 @@
|
||||||
|
<?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>
|
||||||
|
|
@ -1,10 +1,10 @@
|
||||||
USING: io io.files io.streams.string io.encodings.utf8
|
USING: io io.files io.streams.string io.encodings.utf8
|
||||||
http.server.templating http.server.templating.fhtml kernel
|
html.templates html.templates.fhtml kernel
|
||||||
tools.test sequences parser ;
|
tools.test sequences parser ;
|
||||||
IN: http.server.templating.fhtml.tests
|
IN: html.templates.fhtml.tests
|
||||||
|
|
||||||
: test-template ( path -- ? )
|
: test-template ( path -- ? )
|
||||||
"resource:extra/http/server/templating/fhtml/test/"
|
"resource:extra/html/templates/fhtml/test/"
|
||||||
prepend
|
prepend
|
||||||
[
|
[
|
||||||
".fhtml" append <fhtml> [ call-template ] with-string-writer
|
".fhtml" append <fhtml> [ call-template ] with-string-writer
|
||||||
|
|
@ -4,12 +4,10 @@
|
||||||
USING: continuations sequences kernel namespaces debugger
|
USING: continuations sequences kernel namespaces debugger
|
||||||
combinators math quotations generic strings splitting
|
combinators math quotations generic strings splitting
|
||||||
accessors assocs fry
|
accessors assocs fry
|
||||||
parser io io.files io.streams.string io.encodings.utf8 source-files
|
parser io io.files io.streams.string io.encodings.utf8
|
||||||
html html.elements
|
html.elements
|
||||||
http.server.static http.server http.server.templating ;
|
html.templates ;
|
||||||
IN: http.server.templating.fhtml
|
IN: html.templates.fhtml
|
||||||
|
|
||||||
: templating-vocab ( -- vocab-name ) "http.server.templating.fhtml" ;
|
|
||||||
|
|
||||||
! We use a custom lexer so that %> ends a token even if not
|
! We use a custom lexer so that %> ends a token even if not
|
||||||
! followed by whitespace
|
! followed by whitespace
|
||||||
|
|
@ -35,7 +33,7 @@ DEFER: <% delimiter
|
||||||
: found-<% ( accum lexer col -- accum )
|
: found-<% ( accum lexer col -- accum )
|
||||||
[
|
[
|
||||||
over line-text>>
|
over line-text>>
|
||||||
>r >r column>> r> r> subseq parsed
|
[ column>> ] 2dip subseq parsed
|
||||||
\ write-html parsed
|
\ write-html parsed
|
||||||
] 2keep 2 + >>column drop ;
|
] 2keep 2 + >>column drop ;
|
||||||
|
|
||||||
|
|
@ -62,37 +60,20 @@ DEFER: <% delimiter
|
||||||
|
|
||||||
: parse-template ( string -- quot )
|
: parse-template ( string -- quot )
|
||||||
[
|
[
|
||||||
use [ clone ] change
|
"quiet" on
|
||||||
templating-vocab use+
|
parser-notes off
|
||||||
|
"html.templates.fhtml" use+
|
||||||
string-lines parse-template-lines
|
string-lines parse-template-lines
|
||||||
] with-scope ;
|
] with-file-vocabs ;
|
||||||
|
|
||||||
: eval-template ( string -- ) parse-template call ;
|
: eval-template ( string -- )
|
||||||
|
parse-template call ;
|
||||||
: html-error. ( error -- )
|
|
||||||
<pre> error. </pre> ;
|
|
||||||
|
|
||||||
TUPLE: fhtml path ;
|
TUPLE: fhtml path ;
|
||||||
|
|
||||||
C: <fhtml> fhtml
|
C: <fhtml> fhtml
|
||||||
|
|
||||||
M: fhtml call-template* ( filename -- )
|
M: fhtml call-template* ( filename -- )
|
||||||
'[
|
'[ , path>> utf8 file-contents eval-template ] assert-depth ;
|
||||||
, 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
|
INSTANCE: fhtml template
|
||||||
|
|
@ -0,0 +1,85 @@
|
||||||
|
! 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 ;
|
||||||
|
|
@ -93,7 +93,7 @@ M: download-failed error.
|
||||||
|
|
||||||
: download-to ( url file -- )
|
: download-to ( url file -- )
|
||||||
#! Downloads the contents of a URL to a 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 -- )
|
: download ( url -- )
|
||||||
dup download-name download-to ;
|
dup download-name download-to ;
|
||||||
|
|
|
||||||
|
|
@ -237,7 +237,7 @@ test-db [
|
||||||
[ ] [
|
[ ] [
|
||||||
[
|
[
|
||||||
<dispatcher>
|
<dispatcher>
|
||||||
<action> [ "text/plain" <content> [ "Hi" write ] >>body ] >>display
|
<action> [ [ "Hi" write ] <text-content> ] >>display
|
||||||
<login>
|
<login>
|
||||||
<sessions>
|
<sessions>
|
||||||
"" add-responder
|
"" add-responder
|
||||||
|
|
|
||||||
|
|
@ -9,7 +9,9 @@ math.parser calendar calendar.format
|
||||||
io io.streams.string io.encodings.utf8 io.encodings.string
|
io io.streams.string io.encodings.utf8 io.encodings.string
|
||||||
io.sockets io.sockets.secure
|
io.sockets io.sockets.secure
|
||||||
|
|
||||||
unicode.case unicode.categories qualified ;
|
unicode.case unicode.categories qualified
|
||||||
|
|
||||||
|
html.templates ;
|
||||||
|
|
||||||
EXCLUDE: fry => , ;
|
EXCLUDE: fry => , ;
|
||||||
|
|
||||||
|
|
@ -65,14 +67,14 @@ M: https protocol>string drop "https" ;
|
||||||
2dup length 2 - >= [
|
2dup length 2 - >= [
|
||||||
2drop
|
2drop
|
||||||
] [
|
] [
|
||||||
>r 1+ dup 2 + r> subseq hex> [ , ] when*
|
[ 1+ dup 2 + ] dip subseq hex> [ , ] when*
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: url-decode-% ( index str -- index str )
|
: 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 )
|
: 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 -- )
|
: url-decode-iter ( index str -- )
|
||||||
2dup length >= [
|
2dup length >= [
|
||||||
|
|
@ -158,7 +160,7 @@ M: https protocol>string drop "https" ;
|
||||||
dup [
|
dup [
|
||||||
"&" split H{ } clone [
|
"&" split H{ } clone [
|
||||||
[
|
[
|
||||||
>r "=" split1 [ dup [ url-decode ] when ] bi@ swap r>
|
[ "=" split1 [ dup [ url-decode ] when ] bi@ swap ] dip
|
||||||
add-query-param
|
add-query-param
|
||||||
] curry each
|
] curry each
|
||||||
] keep
|
] keep
|
||||||
|
|
@ -174,7 +176,7 @@ M: https protocol>string drop "https" ;
|
||||||
] assoc-map
|
] assoc-map
|
||||||
[
|
[
|
||||||
[
|
[
|
||||||
>r url-encode r>
|
[ url-encode ] dip
|
||||||
[ url-encode "=" swap 3append , ] with each
|
[ url-encode "=" swap 3append , ] with each
|
||||||
] assoc-each
|
] assoc-each
|
||||||
] { } make "&" join ;
|
] { } make "&" join ;
|
||||||
|
|
@ -342,7 +344,7 @@ SYMBOL: max-post-request
|
||||||
dup "cookie" header [ parse-cookies >>cookies ] when* ;
|
dup "cookie" header [ parse-cookies >>cookies ] when* ;
|
||||||
|
|
||||||
: parse-content-type-attributes ( string -- attributes )
|
: 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 )
|
: parse-content-type ( content-type -- type encoding )
|
||||||
";" split1 parse-content-type-attributes "charset" swap at ;
|
";" split1 parse-content-type-attributes "charset" swap at ;
|
||||||
|
|
@ -521,18 +523,8 @@ body ;
|
||||||
over unparse-content-type "content-type" pick set-at
|
over unparse-content-type "content-type" pick set-at
|
||||||
write-header ;
|
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 )
|
: write-response-body ( response -- response )
|
||||||
dup body>> write-response-body* ;
|
dup body>> call-template ;
|
||||||
|
|
||||||
M: response write-response ( respose -- )
|
M: response write-response ( respose -- )
|
||||||
write-response-version
|
write-response-version
|
||||||
|
|
@ -547,10 +539,10 @@ M: response write-full-response ( request response -- )
|
||||||
swap method>> "HEAD" = [ write-response-body ] unless ;
|
swap method>> "HEAD" = [ write-response-body ] unless ;
|
||||||
|
|
||||||
: get-cookie ( request/response name -- cookie/f )
|
: get-cookie ( request/response name -- cookie/f )
|
||||||
>r cookies>> r> '[ , _ name>> = ] find nip ;
|
[ cookies>> ] dip '[ , _ name>> = ] find nip ;
|
||||||
|
|
||||||
: delete-cookie ( request/response name -- )
|
: 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 )
|
: put-cookie ( request/response cookie -- request/response )
|
||||||
[ name>> dupd get-cookie [ dupd delete-cookie ] when* ] keep
|
[ name>> dupd get-cookie [ dupd delete-cookie ] when* ] keep
|
||||||
|
|
|
||||||
|
|
@ -1,16 +1,10 @@
|
||||||
USING: http.server.actions http.server.validators
|
USING: kernel http.server.actions validators
|
||||||
tools.test math math.parser multiline namespaces http
|
tools.test math math.parser multiline namespaces http
|
||||||
io.streams.string http.server sequences splitting accessors ;
|
io.streams.string http.server sequences splitting accessors ;
|
||||||
IN: http.server.actions.tests
|
IN: http.server.actions.tests
|
||||||
|
|
||||||
[
|
|
||||||
"a" [ v-number ] { { "a" "123" } } validate-param
|
|
||||||
[ 123 ] [ "a" get ] unit-test
|
|
||||||
] with-scope
|
|
||||||
|
|
||||||
<action>
|
<action>
|
||||||
[ "a" get "b" get + ] >>display
|
[ "a" param "b" param [ string>number ] bi@ + ] >>display
|
||||||
{ { "a" [ v-number ] } { "b" [ v-number ] } } >>get-params
|
|
||||||
"action-1" set
|
"action-1" set
|
||||||
|
|
||||||
: lf>crlf "\n" split "\r\n" join ;
|
: lf>crlf "\n" split "\r\n" join ;
|
||||||
|
|
|
||||||
|
|
@ -1,68 +1,94 @@
|
||||||
! Copyright (C) 2008 Slava Pestov.
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors sequences kernel assocs combinators
|
USING: accessors sequences kernel assocs combinators http.server
|
||||||
http.server http.server.validators http hashtables namespaces
|
validators http hashtables namespaces fry continuations locals
|
||||||
fry continuations locals boxes xml.entities html.elements io ;
|
boxes xml.entities html.elements html.components io arrays math ;
|
||||||
IN: http.server.actions
|
IN: http.server.actions
|
||||||
|
|
||||||
SYMBOL: params
|
SYMBOL: params
|
||||||
|
|
||||||
SYMBOL: validation-message
|
SYMBOL: rest-param
|
||||||
|
|
||||||
: render-validation-message ( -- )
|
: render-validation-messages ( -- )
|
||||||
validation-message get value>> [
|
validation-messages get
|
||||||
<span "error" =class span>
|
dup empty? [ drop ] [
|
||||||
escape-string write
|
<ul "errors" =class ul>
|
||||||
</span>
|
[ <li> message>> escape-string write </li> ] each
|
||||||
] when* ;
|
</ul>
|
||||||
|
|
||||||
TUPLE: action init display submit get-params post-params ;
|
|
||||||
|
|
||||||
: <action>
|
|
||||||
action new
|
|
||||||
[ ] >>init
|
|
||||||
[ <400> ] >>display
|
|
||||||
[ <400> ] >>submit ;
|
|
||||||
|
|
||||||
:: validate-param ( name validator assoc -- )
|
|
||||||
name assoc at validator with-validator name set ; inline
|
|
||||||
|
|
||||||
: action-params ( validators -- error? )
|
|
||||||
validation-failed? off
|
|
||||||
params get '[ , validate-param ] assoc-each
|
|
||||||
validation-failed? get ;
|
|
||||||
|
|
||||||
: handle-get ( -- response )
|
|
||||||
action get get-params>> action-params [ <400> ] [
|
|
||||||
action get [ init>> call ] [ display>> call ] bi
|
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: handle-post ( -- response )
|
TUPLE: action rest-param init display validate submit ;
|
||||||
action get post-params>> action-params
|
|
||||||
[ <400> ] [ action get submit>> call ] if ;
|
: new-action ( class -- action )
|
||||||
|
new
|
||||||
|
[ ] >>init
|
||||||
|
[ <400> ] >>display
|
||||||
|
[ ] >>validate
|
||||||
|
[ <400> ] >>submit ;
|
||||||
|
|
||||||
|
: <action> ( -- action )
|
||||||
|
action new-action ;
|
||||||
|
|
||||||
|
: handle-get ( action -- response )
|
||||||
|
blank-values
|
||||||
|
[ init>> call ]
|
||||||
|
[ display>> call ]
|
||||||
|
bi ;
|
||||||
|
|
||||||
: validation-failed ( -- * )
|
: validation-failed ( -- * )
|
||||||
action get display>> call exit-with ;
|
request get method>> "POST" =
|
||||||
|
[ action get display>> call ] [ <400> ] if exit-with ;
|
||||||
|
|
||||||
: validation-failed-with ( string -- * )
|
: handle-post ( action -- response )
|
||||||
validation-message get >box
|
init-validation
|
||||||
validation-failed ;
|
blank-values
|
||||||
|
[ validate>> call ]
|
||||||
|
[ submit>> call ] bi ;
|
||||||
|
|
||||||
|
: handle-rest-param ( arg -- )
|
||||||
|
dup length 1 > action get rest-param>> not or
|
||||||
|
[ <404> exit-with ] [
|
||||||
|
action get rest-param>> associate rest-param set
|
||||||
|
] if ;
|
||||||
|
|
||||||
M: action call-responder* ( path action -- response )
|
M: action call-responder* ( path action -- response )
|
||||||
|
dup action set
|
||||||
'[
|
'[
|
||||||
, [ CHAR: / = ] right-trim empty? [
|
, dup empty? [ drop ] [ handle-rest-param ] if
|
||||||
, action set
|
|
||||||
|
init-validation
|
||||||
|
,
|
||||||
request get
|
request get
|
||||||
<box> validation-message set
|
[ request-params rest-param get assoc-union params set ]
|
||||||
[ request-params params set ]
|
[ method>> ] bi
|
||||||
[
|
{
|
||||||
method>> {
|
|
||||||
{ "GET" [ handle-get ] }
|
{ "GET" [ handle-get ] }
|
||||||
{ "HEAD" [ handle-get ] }
|
{ "HEAD" [ handle-get ] }
|
||||||
{ "POST" [ handle-post ] }
|
{ "POST" [ handle-post ] }
|
||||||
} case
|
} case
|
||||||
] bi
|
|
||||||
] [
|
|
||||||
<404>
|
|
||||||
] if
|
|
||||||
] with-exit-continuation ;
|
] with-exit-continuation ;
|
||||||
|
|
||||||
|
: param ( name -- value )
|
||||||
|
params get at ;
|
||||||
|
|
||||||
|
: check-validation ( -- )
|
||||||
|
validation-failed? [ validation-failed ] when ;
|
||||||
|
|
||||||
|
: validate-params ( validators -- )
|
||||||
|
params get swap validate-values from-assoc
|
||||||
|
check-validation ;
|
||||||
|
|
||||||
|
: validate-integer-id ( -- )
|
||||||
|
{ { "id" [ v-number ] } } validate-params ;
|
||||||
|
|
||||||
|
TUPLE: page-action < action template ;
|
||||||
|
|
||||||
|
: <page-action> ( -- page )
|
||||||
|
page-action new-action
|
||||||
|
dup '[ , template>> <html-content> ] >>display ;
|
||||||
|
|
||||||
|
TUPLE: feed-action < action feed ;
|
||||||
|
|
||||||
|
: <feed-action> ( -- feed )
|
||||||
|
feed-action new
|
||||||
|
dup '[ , feed>> call <feed-content> ] >>display ;
|
||||||
|
|
|
||||||
|
|
@ -1,179 +0,0 @@
|
||||||
! 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 ;
|
|
||||||
|
|
@ -1,9 +0,0 @@
|
||||||
<?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>
|
|
||||||
|
|
@ -1,9 +0,0 @@
|
||||||
<?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>
|
|
||||||
|
|
@ -1,6 +1,6 @@
|
||||||
! Copyright (c) 2008 Slava Pestov
|
! Copyright (c) 2008 Slava Pestov
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors assocs namespaces kernel sequences
|
USING: accessors assocs namespaces kernel sequences sets
|
||||||
http.server
|
http.server
|
||||||
http.server.sessions
|
http.server.sessions
|
||||||
http.server.auth.providers ;
|
http.server.auth.providers ;
|
||||||
|
|
@ -38,4 +38,4 @@ SYMBOL: capabilities
|
||||||
|
|
||||||
V{ } clone capabilities set-global
|
V{ } clone capabilities set-global
|
||||||
|
|
||||||
: define-capability ( word -- ) capabilities get push-new ;
|
: define-capability ( word -- ) capabilities get adjoin ;
|
||||||
|
|
|
||||||
|
|
@ -10,12 +10,12 @@
|
||||||
|
|
||||||
<tr>
|
<tr>
|
||||||
<th class="field-label">User name:</th>
|
<th class="field-label">User name:</th>
|
||||||
<td><t:view t:component="username" /></td>
|
<td><t:label t:name="username" /></td>
|
||||||
</tr>
|
</tr>
|
||||||
|
|
||||||
<tr>
|
<tr>
|
||||||
<th class="field-label">Real name:</th>
|
<th class="field-label">Real name:</th>
|
||||||
<td><t:edit t:component="realname" /></td>
|
<td><t:field t:name="realname" /></td>
|
||||||
</tr>
|
</tr>
|
||||||
|
|
||||||
<tr>
|
<tr>
|
||||||
|
|
@ -25,7 +25,7 @@
|
||||||
|
|
||||||
<tr>
|
<tr>
|
||||||
<th class="field-label">Current password:</th>
|
<th class="field-label">Current password:</th>
|
||||||
<td><t:edit t:component="password" /></td>
|
<td><t:password t:name="password" /></td>
|
||||||
</tr>
|
</tr>
|
||||||
|
|
||||||
<tr>
|
<tr>
|
||||||
|
|
@ -35,12 +35,12 @@
|
||||||
|
|
||||||
<tr>
|
<tr>
|
||||||
<th class="field-label">New password:</th>
|
<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>
|
||||||
|
|
||||||
<tr>
|
<tr>
|
||||||
<th class="field-label">Verify:</th>
|
<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>
|
<tr>
|
||||||
|
|
@ -50,7 +50,7 @@
|
||||||
|
|
||||||
<tr>
|
<tr>
|
||||||
<th class="field-label">E-mail:</th>
|
<th class="field-label">E-mail:</th>
|
||||||
<td><t:edit t:component="email" /></td>
|
<td><t:field t:name="email" /></td>
|
||||||
</tr>
|
</tr>
|
||||||
|
|
||||||
<tr>
|
<tr>
|
||||||
|
|
@ -62,7 +62,7 @@
|
||||||
|
|
||||||
<p>
|
<p>
|
||||||
<input type="submit" value="Update" />
|
<input type="submit" value="Update" />
|
||||||
<t:validation-message />
|
<t:validation-messages />
|
||||||
</p>
|
</p>
|
||||||
|
|
||||||
</t:form>
|
</t:form>
|
||||||
|
|
|
||||||
|
|
@ -2,7 +2,7 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors quotations assocs kernel splitting
|
USING: accessors quotations assocs kernel splitting
|
||||||
combinators sequences namespaces hashtables sets
|
combinators sequences namespaces hashtables sets
|
||||||
fry arrays threads locals qualified random
|
fry arrays threads qualified random validators
|
||||||
io
|
io
|
||||||
io.sockets
|
io.sockets
|
||||||
io.encodings.utf8
|
io.encodings.utf8
|
||||||
|
|
@ -12,23 +12,22 @@ continuations
|
||||||
destructors
|
destructors
|
||||||
checksums
|
checksums
|
||||||
checksums.sha2
|
checksums.sha2
|
||||||
|
validators
|
||||||
|
html.components
|
||||||
html.elements
|
html.elements
|
||||||
|
html.templates
|
||||||
|
html.templates.chloe
|
||||||
http
|
http
|
||||||
http.server
|
http.server
|
||||||
http.server.auth
|
http.server.auth
|
||||||
http.server.auth.providers
|
http.server.auth.providers
|
||||||
http.server.auth.providers.db
|
http.server.auth.providers.db
|
||||||
http.server.actions
|
http.server.actions
|
||||||
http.server.components
|
|
||||||
http.server.flows
|
http.server.flows
|
||||||
http.server.forms
|
|
||||||
http.server.sessions
|
http.server.sessions
|
||||||
http.server.boilerplate
|
http.server.boilerplate ;
|
||||||
http.server.templating
|
|
||||||
http.server.templating.chloe
|
|
||||||
http.server.validators ;
|
|
||||||
IN: http.server.auth.login
|
|
||||||
QUALIFIED: smtp
|
QUALIFIED: smtp
|
||||||
|
IN: http.server.auth.login
|
||||||
|
|
||||||
TUPLE: login < dispatcher users checksum ;
|
TUPLE: login < dispatcher users checksum ;
|
||||||
|
|
||||||
|
|
@ -65,80 +64,60 @@ M: user-saver dispose
|
||||||
3append <chloe> ;
|
3append <chloe> ;
|
||||||
|
|
||||||
! ! ! Login
|
! ! ! Login
|
||||||
|
|
||||||
: <login-form>
|
|
||||||
"login" <form>
|
|
||||||
"login" login-template >>edit-template
|
|
||||||
"username" <username>
|
|
||||||
t >>required
|
|
||||||
add-field
|
|
||||||
"password" <password>
|
|
||||||
t >>required
|
|
||||||
add-field ;
|
|
||||||
|
|
||||||
: successful-login ( user -- response )
|
: successful-login ( user -- response )
|
||||||
username>> set-uid
|
username>> set-uid "$login" end-flow ;
|
||||||
"$login" end-flow ;
|
|
||||||
|
|
||||||
: login-failed "invalid username or password" validation-failed-with ;
|
: login-failed ( -- * )
|
||||||
|
"invalid username or password" validation-error
|
||||||
|
validation-failed ;
|
||||||
|
|
||||||
:: <login-action> ( -- action )
|
: <login-action> ( -- action )
|
||||||
[let | form [ <login-form> ] |
|
|
||||||
<action>
|
<action>
|
||||||
[ blank-values ] >>init
|
[ "login" login-template <html-content> ] >>display
|
||||||
|
|
||||||
[ form edit-form ] >>display
|
|
||||||
|
|
||||||
[
|
[
|
||||||
blank-values
|
{
|
||||||
|
{ "username" [ v-required ] }
|
||||||
|
{ "password" [ v-required ] }
|
||||||
|
} validate-params
|
||||||
|
|
||||||
form validate-form
|
"password" value
|
||||||
|
"username" value check-login
|
||||||
"password" value "username" value check-login
|
|
||||||
[ successful-login ] [ login-failed ] if*
|
[ successful-login ] [ login-failed ] if*
|
||||||
] >>submit
|
] >>submit ;
|
||||||
] ;
|
|
||||||
|
|
||||||
! ! ! New user registration
|
! ! ! New user registration
|
||||||
|
|
||||||
: <register-form> ( -- form )
|
: user-exists ( -- * )
|
||||||
"register" <form>
|
"username taken" validation-error
|
||||||
"register" login-template >>edit-template
|
validation-failed ;
|
||||||
"username" <username>
|
|
||||||
t >>required
|
|
||||||
add-field
|
|
||||||
"realname" <string> add-field
|
|
||||||
"new-password" <password>
|
|
||||||
t >>required
|
|
||||||
add-field
|
|
||||||
"verify-password" <password>
|
|
||||||
t >>required
|
|
||||||
add-field
|
|
||||||
"email" <email> add-field
|
|
||||||
"captcha" <captcha> add-field ;
|
|
||||||
|
|
||||||
: password-mismatch "passwords do not match" validation-failed-with ;
|
: password-mismatch ( -- * )
|
||||||
|
"passwords do not match" validation-error
|
||||||
: user-exists "username taken" validation-failed-with ;
|
validation-failed ;
|
||||||
|
|
||||||
: same-password-twice ( -- )
|
: same-password-twice ( -- )
|
||||||
"new-password" value "verify-password" value =
|
"new-password" value "verify-password" value =
|
||||||
[ password-mismatch ] unless ;
|
[ password-mismatch ] unless ;
|
||||||
|
|
||||||
:: <register-action> ( -- action )
|
: <register-action> ( -- action )
|
||||||
[let | form [ <register-form> ] |
|
<page-action>
|
||||||
<action>
|
"register" login-template >>template
|
||||||
[ blank-values ] >>init
|
|
||||||
|
|
||||||
[ form edit-form ] >>display
|
|
||||||
|
|
||||||
[
|
[
|
||||||
blank-values
|
{
|
||||||
|
{ "username" [ v-username ] }
|
||||||
form validate-form
|
{ "realname" [ [ v-one-line ] v-optional ] }
|
||||||
|
{ "new-password" [ v-password ] }
|
||||||
|
{ "verify-password" [ v-password ] }
|
||||||
|
{ "email" [ [ v-email ] v-optional ] }
|
||||||
|
{ "captcha" [ v-captcha ] }
|
||||||
|
} validate-params
|
||||||
|
|
||||||
same-password-twice
|
same-password-twice
|
||||||
|
] >>validate
|
||||||
|
|
||||||
|
[
|
||||||
"username" value <user>
|
"username" value <user>
|
||||||
"realname" value >>realname
|
"realname" value >>realname
|
||||||
"new-password" value >>encoded-password
|
"new-password" value >>encoded-password
|
||||||
|
|
@ -147,30 +126,16 @@ M: user-saver dispose
|
||||||
|
|
||||||
users new-user [ user-exists ] unless*
|
users new-user [ user-exists ] unless*
|
||||||
|
|
||||||
successful-login
|
|
||||||
|
|
||||||
login get init-user-profile
|
login get init-user-profile
|
||||||
] >>submit
|
|
||||||
] ;
|
successful-login
|
||||||
|
] >>submit ;
|
||||||
|
|
||||||
! ! ! Editing user profile
|
! ! ! Editing user profile
|
||||||
|
|
||||||
: <edit-profile-form> ( -- form )
|
: <edit-profile-action> ( -- action )
|
||||||
"edit-profile" <form>
|
|
||||||
"edit-profile" login-template >>edit-template
|
|
||||||
"username" <username> add-field
|
|
||||||
"realname" <string> add-field
|
|
||||||
"password" <password> add-field
|
|
||||||
"new-password" <password> add-field
|
|
||||||
"verify-password" <password> add-field
|
|
||||||
"email" <email> add-field ;
|
|
||||||
|
|
||||||
:: <edit-profile-action> ( -- action )
|
|
||||||
[let | form [ <edit-profile-form> ] |
|
|
||||||
<action>
|
<action>
|
||||||
[
|
[
|
||||||
blank-values
|
|
||||||
|
|
||||||
logged-in-user get
|
logged-in-user get
|
||||||
[ username>> "username" set-value ]
|
[ username>> "username" set-value ]
|
||||||
[ realname>> "realname" set-value ]
|
[ realname>> "realname" set-value ]
|
||||||
|
|
@ -178,25 +143,33 @@ M: user-saver dispose
|
||||||
tri
|
tri
|
||||||
] >>init
|
] >>init
|
||||||
|
|
||||||
[ form edit-form ] >>display
|
[ "edit-profile" login-template <html-content> ] >>display
|
||||||
|
|
||||||
[
|
[
|
||||||
blank-values
|
|
||||||
uid "username" set-value
|
uid "username" set-value
|
||||||
|
|
||||||
form validate-form
|
{
|
||||||
|
{ "realname" [ [ v-one-line ] v-optional ] }
|
||||||
logged-in-user get
|
{ "password" [ ] }
|
||||||
|
{ "new-password" [ [ v-password ] v-optional ] }
|
||||||
|
{ "verify-password" [ [ v-password ] v-optional ] }
|
||||||
|
{ "email" [ [ v-email ] v-optional ] }
|
||||||
|
} validate-params
|
||||||
|
|
||||||
{ "password" "new-password" "verify-password" }
|
{ "password" "new-password" "verify-password" }
|
||||||
[ value empty? ] all? [
|
[ value empty? not ] contains? [
|
||||||
same-password-twice
|
|
||||||
|
|
||||||
"password" value uid check-login
|
"password" value uid check-login
|
||||||
[ login-failed ] unless
|
[ "incorrect password" validation-error ] unless
|
||||||
|
|
||||||
"new-password" value >>encoded-password
|
same-password-twice
|
||||||
] unless
|
] when
|
||||||
|
] >>validate
|
||||||
|
|
||||||
|
[
|
||||||
|
logged-in-user get
|
||||||
|
|
||||||
|
"new-password" value dup empty?
|
||||||
|
[ drop ] [ >>encoded-password ] if
|
||||||
|
|
||||||
"realname" value >>realname
|
"realname" value >>realname
|
||||||
"email" value >>email
|
"email" value >>email
|
||||||
|
|
@ -206,8 +179,7 @@ M: user-saver dispose
|
||||||
drop
|
drop
|
||||||
|
|
||||||
"$login" end-flow
|
"$login" end-flow
|
||||||
] >>submit
|
] >>submit ;
|
||||||
] ;
|
|
||||||
|
|
||||||
! ! ! Password recovery
|
! ! ! Password recovery
|
||||||
|
|
||||||
|
|
@ -250,92 +222,61 @@ SYMBOL: lost-password-from
|
||||||
'[ , password-email smtp:send-email ]
|
'[ , password-email smtp:send-email ]
|
||||||
"E-mail send thread" spawn drop ;
|
"E-mail send thread" spawn drop ;
|
||||||
|
|
||||||
: <recover-form-1> ( -- form )
|
: <recover-action-1> ( -- action )
|
||||||
"register" <form>
|
|
||||||
"recover-1" login-template >>edit-template
|
|
||||||
"username" <username>
|
|
||||||
t >>required
|
|
||||||
add-field
|
|
||||||
"email" <email>
|
|
||||||
t >>required
|
|
||||||
add-field
|
|
||||||
"captcha" <captcha> add-field ;
|
|
||||||
|
|
||||||
:: <recover-action-1> ( -- action )
|
|
||||||
[let | form [ <recover-form-1> ] |
|
|
||||||
<action>
|
<action>
|
||||||
[ blank-values ] >>init
|
[ "recover-1" login-template <html-content> ] >>display
|
||||||
|
|
||||||
[ form edit-form ] >>display
|
|
||||||
|
|
||||||
[
|
[
|
||||||
blank-values
|
{
|
||||||
|
{ "username" [ v-username ] }
|
||||||
form validate-form
|
{ "email" [ v-email ] }
|
||||||
|
{ "captcha" [ v-captcha ] }
|
||||||
|
} validate-params
|
||||||
|
] >>validate
|
||||||
|
|
||||||
|
[
|
||||||
"email" value "username" value
|
"email" value "username" value
|
||||||
users issue-ticket [
|
users issue-ticket [
|
||||||
send-password-email
|
send-password-email
|
||||||
] when*
|
] when*
|
||||||
|
|
||||||
"recover-2" login-template serve-template
|
"recover-2" login-template <html-content>
|
||||||
] >>submit
|
] >>submit ;
|
||||||
] ;
|
|
||||||
|
|
||||||
: <recover-form-3>
|
: <recover-action-3> ( -- action )
|
||||||
"new-password" <form>
|
|
||||||
"recover-3" login-template >>edit-template
|
|
||||||
"username" <username>
|
|
||||||
hidden >>renderer
|
|
||||||
t >>required
|
|
||||||
add-field
|
|
||||||
"new-password" <password>
|
|
||||||
t >>required
|
|
||||||
add-field
|
|
||||||
"verify-password" <password>
|
|
||||||
t >>required
|
|
||||||
add-field
|
|
||||||
"ticket" <string>
|
|
||||||
hidden >>renderer
|
|
||||||
t >>required
|
|
||||||
add-field ;
|
|
||||||
|
|
||||||
:: <recover-action-3> ( -- action )
|
|
||||||
[let | form [ <recover-form-3> ] |
|
|
||||||
<action>
|
<action>
|
||||||
[
|
[
|
||||||
{ "username" [ v-required ] }
|
{
|
||||||
|
{ "username" [ v-username ] }
|
||||||
{ "ticket" [ v-required ] }
|
{ "ticket" [ v-required ] }
|
||||||
] >>get-params
|
} validate-params
|
||||||
|
|
||||||
[
|
|
||||||
[
|
|
||||||
"username" [ get ] keep set
|
|
||||||
"ticket" [ get ] keep set
|
|
||||||
] H{ } make-assoc values set
|
|
||||||
] >>init
|
] >>init
|
||||||
|
|
||||||
[ <recover-form-3> edit-form ] >>display
|
[ "recover-3" login-template <html-content> ] >>display
|
||||||
|
|
||||||
[
|
[
|
||||||
blank-values
|
{
|
||||||
|
{ "username" [ v-username ] }
|
||||||
form validate-form
|
{ "ticket" [ v-required ] }
|
||||||
|
{ "new-password" [ v-password ] }
|
||||||
|
{ "verify-password" [ v-password ] }
|
||||||
|
} validate-params
|
||||||
|
|
||||||
same-password-twice
|
same-password-twice
|
||||||
|
] >>validate
|
||||||
|
|
||||||
|
[
|
||||||
"ticket" value
|
"ticket" value
|
||||||
"username" value
|
"username" value
|
||||||
users claim-ticket [
|
users claim-ticket [
|
||||||
"new-password" value >>encoded-password
|
"new-password" value >>encoded-password
|
||||||
users update-user
|
users update-user
|
||||||
|
|
||||||
"recover-4" login-template serve-template
|
"recover-4" login-template <html-content>
|
||||||
] [
|
] [
|
||||||
<400>
|
<400>
|
||||||
] if*
|
] if*
|
||||||
] >>submit
|
] >>submit ;
|
||||||
] ;
|
|
||||||
|
|
||||||
! ! ! Logout
|
! ! ! Logout
|
||||||
: <logout-action> ( -- action )
|
: <logout-action> ( -- action )
|
||||||
|
|
|
||||||
|
|
@ -10,12 +10,12 @@
|
||||||
|
|
||||||
<tr>
|
<tr>
|
||||||
<th class="field-label">User name:</th>
|
<th class="field-label">User name:</th>
|
||||||
<td><t:edit t:component="username" /></td>
|
<td><t:field t:name="username" /></td>
|
||||||
</tr>
|
</tr>
|
||||||
|
|
||||||
<tr>
|
<tr>
|
||||||
<th class="field-label">Password:</th>
|
<th class="field-label">Password:</th>
|
||||||
<td><t:edit t:component="password" /></td>
|
<td><t:password t:name="password" /></td>
|
||||||
</tr>
|
</tr>
|
||||||
|
|
||||||
</table>
|
</table>
|
||||||
|
|
@ -23,7 +23,7 @@
|
||||||
<p>
|
<p>
|
||||||
|
|
||||||
<input type="submit" value="Log in" />
|
<input type="submit" value="Log in" />
|
||||||
<t:validation-message />
|
<t:validation-messages />
|
||||||
|
|
||||||
</p>
|
</p>
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -12,17 +12,17 @@
|
||||||
|
|
||||||
<tr>
|
<tr>
|
||||||
<th class="field-label">User name:</th>
|
<th class="field-label">User name:</th>
|
||||||
<td><t:edit t:component="username" /></td>
|
<td><t:field t:name="username" /></td>
|
||||||
</tr>
|
</tr>
|
||||||
|
|
||||||
<tr>
|
<tr>
|
||||||
<th class="field-label">E-mail:</th>
|
<th class="field-label">E-mail:</th>
|
||||||
<td><t:edit t:component="email" /></td>
|
<td><t:field t:name="email" /></td>
|
||||||
</tr>
|
</tr>
|
||||||
|
|
||||||
<tr>
|
<tr>
|
||||||
<th class="field-label">Captcha:</th>
|
<th class="field-label">Captcha:</th>
|
||||||
<td><t:edit t:component="captcha" /></td>
|
<td><t:field t:name="captcha" /></td>
|
||||||
</tr>
|
</tr>
|
||||||
|
|
||||||
<tr>
|
<tr>
|
||||||
|
|
|
||||||
|
|
@ -10,17 +10,17 @@
|
||||||
|
|
||||||
<table>
|
<table>
|
||||||
|
|
||||||
<t:edit t:component="username" />
|
<t:hidden t:name="username" />
|
||||||
<t:edit t:component="ticket" />
|
<t:hidden t:name="ticket" />
|
||||||
|
|
||||||
<tr>
|
<tr>
|
||||||
<th class="field-label">Password:</th>
|
<th class="field-label">Password:</th>
|
||||||
<td><t:edit t:component="new-password" /></td>
|
<td><t:password t:name="new-password" /></td>
|
||||||
</tr>
|
</tr>
|
||||||
|
|
||||||
<tr>
|
<tr>
|
||||||
<th class="field-label">Verify password:</th>
|
<th class="field-label">Verify password:</th>
|
||||||
<td><t:edit t:component="verify-password" /></td>
|
<td><t:password t:name="verify-password" /></td>
|
||||||
</tr>
|
</tr>
|
||||||
|
|
||||||
<tr>
|
<tr>
|
||||||
|
|
@ -32,7 +32,7 @@
|
||||||
|
|
||||||
<p>
|
<p>
|
||||||
<input type="submit" value="Set password" />
|
<input type="submit" value="Set password" />
|
||||||
<t:validation-message />
|
<t:validation-messages />
|
||||||
</p>
|
</p>
|
||||||
|
|
||||||
</t:form>
|
</t:form>
|
||||||
|
|
|
||||||
|
|
@ -10,12 +10,12 @@
|
||||||
|
|
||||||
<tr>
|
<tr>
|
||||||
<th class="field-label">User name:</th>
|
<th class="field-label">User name:</th>
|
||||||
<td><t:edit t:component="username" /></td>
|
<td><t:field t:name="username" /></td>
|
||||||
</tr>
|
</tr>
|
||||||
|
|
||||||
<tr>
|
<tr>
|
||||||
<th class="field-label">Real name:</th>
|
<th class="field-label">Real name:</th>
|
||||||
<td><t:edit t:component="realname" /></td>
|
<td><t:field t:name="realname" /></td>
|
||||||
</tr>
|
</tr>
|
||||||
|
|
||||||
<tr>
|
<tr>
|
||||||
|
|
@ -25,12 +25,12 @@
|
||||||
|
|
||||||
<tr>
|
<tr>
|
||||||
<th class="field-label">Password:</th>
|
<th class="field-label">Password:</th>
|
||||||
<td><t:edit t:component="new-password" /></td>
|
<td><t:password t:name="new-password" /></td>
|
||||||
</tr>
|
</tr>
|
||||||
|
|
||||||
<tr>
|
<tr>
|
||||||
<th class="field-label">Verify:</th>
|
<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>
|
<tr>
|
||||||
|
|
@ -40,7 +40,7 @@
|
||||||
|
|
||||||
<tr>
|
<tr>
|
||||||
<th class="field-label">E-mail:</th>
|
<th class="field-label">E-mail:</th>
|
||||||
<td><t:edit t:component="email" /></td>
|
<td><t:field t:name="email" /></td>
|
||||||
</tr>
|
</tr>
|
||||||
|
|
||||||
<tr>
|
<tr>
|
||||||
|
|
@ -50,7 +50,7 @@
|
||||||
|
|
||||||
<tr>
|
<tr>
|
||||||
<th class="field-label">Captcha:</th>
|
<th class="field-label">Captcha:</th>
|
||||||
<td><t:edit t:component="captcha" /></td>
|
<td><t:field t:name="captcha" /></td>
|
||||||
</tr>
|
</tr>
|
||||||
|
|
||||||
<tr>
|
<tr>
|
||||||
|
|
@ -63,7 +63,7 @@
|
||||||
<p>
|
<p>
|
||||||
|
|
||||||
<input type="submit" value="Register" />
|
<input type="submit" value="Register" />
|
||||||
<t:validation-message />
|
<t:validation-messages />
|
||||||
|
|
||||||
</p>
|
</p>
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -15,5 +15,5 @@ M: users-in-memory get-user ( username provider -- user/f )
|
||||||
M: users-in-memory update-user ( user provider -- ) 2drop ;
|
M: users-in-memory update-user ( user provider -- ) 2drop ;
|
||||||
|
|
||||||
M: users-in-memory new-user ( user provider -- user/f )
|
M: users-in-memory new-user ( user provider -- user/f )
|
||||||
>r dup username>> r> assoc>>
|
[ dup username>> ] dip assoc>>
|
||||||
2dup key? [ 3drop f ] [ pick >r set-at r> ] if ;
|
2dup key? [ 3drop f ] [ pick [ set-at ] dip ] if ;
|
||||||
|
|
|
||||||
|
|
@ -1,73 +1,13 @@
|
||||||
! Copyright (c) 2008 Slava Pestov
|
! Copyright (c) 2008 Slava Pestov
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors kernel namespaces boxes sequences strings
|
USING: accessors kernel namespaces http.server html.templates
|
||||||
io io.streams.string arrays locals
|
locals ;
|
||||||
html.elements
|
|
||||||
http
|
|
||||||
http.server
|
|
||||||
http.server.sessions
|
|
||||||
http.server.templating ;
|
|
||||||
IN: http.server.boilerplate
|
IN: http.server.boilerplate
|
||||||
|
|
||||||
TUPLE: boilerplate < filter-responder template ;
|
TUPLE: boilerplate < filter-responder template ;
|
||||||
|
|
||||||
: <boilerplate> f boilerplate boa ;
|
: <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 -- )
|
M:: boilerplate call-responder* ( path responder -- )
|
||||||
path responder call-next-method
|
path responder call-next-method
|
||||||
dup content-type>> "text/html" = [
|
dup content-type>> "text/html" = [
|
||||||
|
|
|
||||||
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2004 Chris Double.
|
! Copyright (C) 2004 Chris Double.
|
||||||
! Copyright (C) 2006, 2008 Slava Pestov.
|
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: html http http.server io kernel math namespaces
|
USING: http http.server io kernel math namespaces
|
||||||
continuations calendar sequences assocs hashtables
|
continuations calendar sequences assocs hashtables
|
||||||
accessors arrays alarms quotations combinators fry assocs.lib ;
|
accessors arrays alarms quotations combinators fry assocs.lib ;
|
||||||
IN: http.server.callbacks
|
IN: http.server.callbacks
|
||||||
|
|
@ -90,7 +90,7 @@ SYMBOL: current-show
|
||||||
[ restore-request store-current-show ] when* ;
|
[ restore-request store-current-show ] when* ;
|
||||||
|
|
||||||
: show-final ( quot -- * )
|
: show-final ( quot -- * )
|
||||||
>r redirect-to-here store-current-show r>
|
[ redirect-to-here store-current-show ] dip
|
||||||
call exit-with ; inline
|
call exit-with ; inline
|
||||||
|
|
||||||
: resuming-callback ( responder request -- id )
|
: resuming-callback ( responder request -- id )
|
||||||
|
|
@ -111,7 +111,7 @@ M: callback-responder call-responder* ( path responder -- response )
|
||||||
] with-exit-continuation ;
|
] with-exit-continuation ;
|
||||||
|
|
||||||
: show-page ( quot -- )
|
: show-page ( quot -- )
|
||||||
>r redirect-to-here store-current-show r>
|
[ redirect-to-here store-current-show ] dip
|
||||||
[
|
[
|
||||||
[ ] t register-callback swap call exit-with
|
[ ] t register-callback swap call exit-with
|
||||||
] callcc1 restore-request ; inline
|
] callcc1 restore-request ; inline
|
||||||
|
|
|
||||||
|
|
@ -1,20 +0,0 @@
|
||||||
! 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 ;
|
|
||||||
|
|
@ -1,133 +0,0 @@
|
||||||
IN: http.server.components.tests
|
|
||||||
USING: http.server.components http.server.forms
|
|
||||||
http.server.validators namespaces tools.test kernel accessors
|
|
||||||
tuple-syntax mirrors
|
|
||||||
http http.server.actions http.server.templating.fhtml
|
|
||||||
io.streams.string io.streams.null ;
|
|
||||||
|
|
||||||
validation-failed? off
|
|
||||||
|
|
||||||
[ 3 ] [ "3" "n" <number> validate ] unit-test
|
|
||||||
|
|
||||||
[ 123 ] [
|
|
||||||
""
|
|
||||||
"n" <number>
|
|
||||||
123 >>default
|
|
||||||
validate
|
|
||||||
] unit-test
|
|
||||||
|
|
||||||
[ f ] [ validation-failed? get ] unit-test
|
|
||||||
|
|
||||||
[ t ] [ "3x" "n" <number> validate validation-error? ] unit-test
|
|
||||||
|
|
||||||
[ t ] [ validation-failed? get ] unit-test
|
|
||||||
|
|
||||||
[ "" ] [ "" "email" <email> validate ] unit-test
|
|
||||||
|
|
||||||
[ "slava@jedit.org" ] [ "slava@jedit.org" "email" <email> validate ] unit-test
|
|
||||||
|
|
||||||
[ "slava@jedit.org" ] [
|
|
||||||
"slava@jedit.org"
|
|
||||||
"email" <email>
|
|
||||||
t >>required
|
|
||||||
validate
|
|
||||||
] unit-test
|
|
||||||
|
|
||||||
[ t ] [
|
|
||||||
"a"
|
|
||||||
"email" <email>
|
|
||||||
t >>required
|
|
||||||
validate validation-error?
|
|
||||||
] unit-test
|
|
||||||
|
|
||||||
[ t ] [ "a" "email" <email> validate validation-error? ] unit-test
|
|
||||||
|
|
||||||
TUPLE: test-tuple text number more-text ;
|
|
||||||
|
|
||||||
: <test-tuple> test-tuple new ;
|
|
||||||
|
|
||||||
: <test-form> ( -- form )
|
|
||||||
"test" <form>
|
|
||||||
"resource:extra/http/server/components/test/form.fhtml" <fhtml> >>view-template
|
|
||||||
"resource:extra/http/server/components/test/form.fhtml" <fhtml> >>edit-template
|
|
||||||
"text" <string>
|
|
||||||
t >>required
|
|
||||||
add-field
|
|
||||||
"number" <number>
|
|
||||||
123 >>default
|
|
||||||
t >>required
|
|
||||||
0 >>min-value
|
|
||||||
10 >>max-value
|
|
||||||
add-field
|
|
||||||
"more-text" <text>
|
|
||||||
"hi" >>default
|
|
||||||
add-field ;
|
|
||||||
|
|
||||||
[ ] [ <test-tuple> <mirror> values set <test-form> view-form write-response-body drop ] unit-test
|
|
||||||
|
|
||||||
[ ] [ <test-tuple> <mirror> values set <test-form> edit-form write-response-body drop ] unit-test
|
|
||||||
|
|
||||||
[ TUPLE{ test-tuple number: 123 more-text: "hi" } ] [
|
|
||||||
<test-tuple> from-tuple
|
|
||||||
<test-form> set-defaults
|
|
||||||
values-tuple
|
|
||||||
] unit-test
|
|
||||||
|
|
||||||
[
|
|
||||||
H{
|
|
||||||
{ "text" "fdafsa" }
|
|
||||||
{ "number" "xxx" }
|
|
||||||
{ "more-text" "" }
|
|
||||||
} params set
|
|
||||||
|
|
||||||
H{ } clone values set
|
|
||||||
|
|
||||||
[ t ] [ <test-form> (validate-form) ] unit-test
|
|
||||||
|
|
||||||
[ "fdafsa" ] [ "text" value ] unit-test
|
|
||||||
|
|
||||||
[ t ] [ "number" value validation-error? ] unit-test
|
|
||||||
] with-scope
|
|
||||||
|
|
||||||
[
|
|
||||||
[ ] [
|
|
||||||
"n" <number>
|
|
||||||
0 >>min-value
|
|
||||||
10 >>max-value
|
|
||||||
"n" set
|
|
||||||
] unit-test
|
|
||||||
|
|
||||||
[ "123" ] [
|
|
||||||
"123" "n" get validate value>>
|
|
||||||
] unit-test
|
|
||||||
|
|
||||||
[ ] [ "i" <integer> "i" set ] unit-test
|
|
||||||
|
|
||||||
[ 3 ] [
|
|
||||||
"3" "i" get validate
|
|
||||||
] unit-test
|
|
||||||
|
|
||||||
[ t ] [
|
|
||||||
"3.9" "i" get validate validation-error?
|
|
||||||
] unit-test
|
|
||||||
|
|
||||||
H{ } clone values set
|
|
||||||
|
|
||||||
[ ] [ 3 "i" set-value ] unit-test
|
|
||||||
|
|
||||||
[ "3" ] [ [ "i" get render-view ] with-string-writer ] unit-test
|
|
||||||
|
|
||||||
[ ] [ [ "i" get render-edit ] with-null-stream ] unit-test
|
|
||||||
|
|
||||||
[ ] [ "t" <text> "t" set ] unit-test
|
|
||||||
|
|
||||||
[ ] [ "hello world" "t" set-value ] unit-test
|
|
||||||
|
|
||||||
[ ] [ [ "t" get render-edit ] with-null-stream ] unit-test
|
|
||||||
] with-scope
|
|
||||||
|
|
||||||
[ t ] [ "wake up sheeple" dup "n" <text> validate = ] unit-test
|
|
||||||
|
|
||||||
[ ] [ "password" <password> "p" set ] unit-test
|
|
||||||
|
|
||||||
[ ] [ "pub-date" <date> "d" set ] unit-test
|
|
||||||
|
|
@ -1,401 +0,0 @@
|
||||||
! 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 ;
|
|
||||||
|
|
@ -1,17 +0,0 @@
|
||||||
! Copyright (C) 2008 Slava Pestov
|
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
|
||||||
USING: splitting kernel io sequences farkup accessors
|
|
||||||
http.server.components xml.entities ;
|
|
||||||
IN: http.server.components.farkup
|
|
||||||
|
|
||||||
TUPLE: farkup-renderer < text-renderer ;
|
|
||||||
|
|
||||||
: <farkup-renderer> ( -- renderer )
|
|
||||||
farkup-renderer new-text-renderer ;
|
|
||||||
|
|
||||||
M: farkup-renderer render-view*
|
|
||||||
drop string-lines "\n" join convert-farkup write ;
|
|
||||||
|
|
||||||
: <farkup> ( id -- component )
|
|
||||||
<text>
|
|
||||||
<farkup-renderer> >>renderer ;
|
|
||||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue