Merge branch 'master' of factorcode.org:/git/factor
Eduardo Cavazos
commit
6d15c7615f
|
|
@ -104,3 +104,17 @@ unit-test
|
|||
2drop
|
||||
] { } make
|
||||
] unit-test
|
||||
|
||||
[
|
||||
H{
|
||||
{ "bangers" "mash" }
|
||||
{ "fries" "onion rings" }
|
||||
}
|
||||
] [
|
||||
{ "bangers" "fries" } H{
|
||||
{ "fish" "chips" }
|
||||
{ "bangers" "mash" }
|
||||
{ "fries" "onion rings" }
|
||||
{ "nachos" "cheese" }
|
||||
} extract-keys
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -150,6 +150,9 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
|
|||
: map>assoc ( seq quot exemplar -- assoc )
|
||||
>r [ 2array ] compose { } map-as r> assoc-like ; inline
|
||||
|
||||
: extract-keys ( seq assoc -- subassoc )
|
||||
[ [ dupd at ] curry ] keep map>assoc ;
|
||||
|
||||
M: assoc >alist [ 2array ] { } assoc>map ;
|
||||
|
||||
: value-at ( value assoc -- key/f )
|
||||
|
|
|
|||
|
|
@ -160,3 +160,12 @@ TUPLE: flat-mx-2-1 ; INSTANCE: flat-mx-2-1 flat-mx-2
|
|||
[ t ] [ 3 number instance? ] unit-test
|
||||
[ f ] [ 3 null instance? ] unit-test
|
||||
[ t ] [ "hi" \ hi-tag instance? ] unit-test
|
||||
|
||||
! Regression
|
||||
GENERIC: method-forget-test
|
||||
TUPLE: method-forget-class ;
|
||||
M: method-forget-class method-forget-test ;
|
||||
|
||||
[ f ] [ \ method-forget-test "methods" word-prop assoc-empty? ] unit-test
|
||||
[ ] [ [ \ method-forget-class forget ] with-compilation-unit ] unit-test
|
||||
[ t ] [ \ method-forget-test "methods" word-prop assoc-empty? ] unit-test
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ namespaces quotations sequences.private classes continuations
|
|||
generic.standard effects classes.tuple classes.tuple.private
|
||||
arrays vectors strings compiler.units accessors classes.algebra
|
||||
calendar prettyprint io.streams.string splitting inspector
|
||||
columns math.order ;
|
||||
columns math.order classes.private ;
|
||||
IN: classes.tuple.tests
|
||||
|
||||
TUPLE: rect x y w h ;
|
||||
|
|
@ -543,6 +543,7 @@ TUPLE: another-forget-accessors-test ;
|
|||
! Missing error check
|
||||
[ "IN: classes.tuple.tests USE: words TUPLE: wrong-superclass < word ;" eval ] must-fail
|
||||
|
||||
! Class forget messyness
|
||||
TUPLE: subclass-forget-test ;
|
||||
|
||||
TUPLE: subclass-forget-test-1 < subclass-forget-test ;
|
||||
|
|
@ -551,6 +552,14 @@ TUPLE: subclass-forget-test-3 < subclass-forget-test-2 ;
|
|||
|
||||
[ ] [ "IN: classes.tuple.tests FORGET: subclass-forget-test" eval ] unit-test
|
||||
|
||||
[ H{ { subclass-forget-test-2 subclass-forget-test-2 } } ]
|
||||
[ subclass-forget-test-2 class-usages ]
|
||||
unit-test
|
||||
|
||||
[ H{ { subclass-forget-test-3 subclass-forget-test-3 } } ]
|
||||
[ subclass-forget-test-3 class-usages ]
|
||||
unit-test
|
||||
|
||||
[ f ] [ subclass-forget-test-1 tuple-class? ] unit-test
|
||||
[ f ] [ subclass-forget-test-2 tuple-class? ] unit-test
|
||||
[ subclass-forget-test-3 new ] must-fail
|
||||
|
|
|
|||
|
|
@ -226,12 +226,6 @@ M: tuple-class reset-class
|
|||
} reset-props
|
||||
] bi ;
|
||||
|
||||
: reset-tuple-class ( class -- )
|
||||
[ [ reset-class ] [ update-map- ] bi ] each-subclass ;
|
||||
|
||||
M: tuple-class forget*
|
||||
[ reset-tuple-class ] [ call-next-method ] bi ;
|
||||
|
||||
M: tuple-class rank-class drop 0 ;
|
||||
|
||||
M: tuple clone
|
||||
|
|
|
|||
|
|
@ -95,10 +95,10 @@ M: hashtable hashcode*
|
|||
|
||||
: (distribute-buckets) ( buckets pair keys -- )
|
||||
dup t eq? [
|
||||
drop [ swap push-new ] curry each
|
||||
drop [ swap adjoin ] curry each
|
||||
] [
|
||||
[
|
||||
>r 2dup r> hashcode pick length rem rot nth push-new
|
||||
>r 2dup r> hashcode pick length rem rot nth adjoin
|
||||
] each 2drop
|
||||
] if ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel continuations assocs namespaces sequences words
|
||||
vocabs definitions hashtables init ;
|
||||
vocabs definitions hashtables init sets ;
|
||||
IN: compiler.units
|
||||
|
||||
SYMBOL: old-definitions
|
||||
|
|
@ -14,7 +14,7 @@ TUPLE: redefine-error def ;
|
|||
{ { "Continue" t } } throw-restarts drop ;
|
||||
|
||||
: add-once ( key assoc -- )
|
||||
2dup key? [ over redefine-error ] when dupd set-at ;
|
||||
2dup key? [ over redefine-error ] when conjoin ;
|
||||
|
||||
: (remember-definition) ( definition loc assoc -- )
|
||||
>r over set-where r> add-once ;
|
||||
|
|
@ -83,7 +83,14 @@ SYMBOL: update-tuples-hook
|
|||
call-recompile-hook
|
||||
call-update-tuples-hook
|
||||
dup [ drop compiled-crossref? ] assoc-contains? modify-code-heap
|
||||
updated-definitions notify-definition-observers ;
|
||||
;
|
||||
|
||||
: with-nested-compilation-unit ( quot -- )
|
||||
[
|
||||
H{ } clone changed-definitions set
|
||||
H{ } clone outdated-tuples set
|
||||
[ finish-compilation-unit ] [ ] cleanup
|
||||
] with-scope ; inline
|
||||
|
||||
: with-compilation-unit ( quot -- )
|
||||
[
|
||||
|
|
@ -92,8 +99,11 @@ SYMBOL: update-tuples-hook
|
|||
H{ } clone outdated-tuples set
|
||||
<definitions> new-definitions set
|
||||
<definitions> old-definitions set
|
||||
[ finish-compilation-unit ]
|
||||
[ ] cleanup
|
||||
[
|
||||
finish-compilation-unit
|
||||
updated-definitions
|
||||
notify-definition-observers
|
||||
] [ ] cleanup
|
||||
] with-scope ; inline
|
||||
|
||||
: compile-call ( quot -- )
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: help.markup help.syntax kernel quotations ;
|
||||
USING: help.markup help.syntax kernel quotations dlists.private ;
|
||||
IN: dlists
|
||||
|
||||
ARTICLE: "dlists" "Doubly-linked lists"
|
||||
|
|
@ -51,38 +51,52 @@ HELP: dlist-empty?
|
|||
HELP: push-front
|
||||
{ $values { "obj" "an object" } { "dlist" dlist } }
|
||||
{ $description "Push the object onto the front of the " { $link dlist } "." }
|
||||
{ $notes "This operation is O(1)." }
|
||||
{ $see-also push-back pop-front pop-front* pop-back pop-back* } ;
|
||||
{ $notes "This operation is O(1)." } ;
|
||||
|
||||
HELP: push-front*
|
||||
{ $values { "obj" "an object" } { "dlist" dlist } { "dlist-node" dlist-node } }
|
||||
{ $description "Push the object onto the front of the " { $link dlist } " and return the newly created " { $snippet "dlist-node" } "." }
|
||||
{ $notes "This operation is O(1)." } ;
|
||||
|
||||
HELP: push-back
|
||||
{ $values { "obj" "an object" } { "dlist" dlist } }
|
||||
{ $description "Push the object onto the back of the " { $link dlist } "." }
|
||||
{ $notes "This operation is O(1)." }
|
||||
{ $see-also push-front pop-front pop-front* pop-back pop-back* } ;
|
||||
{ $notes "This operation is O(1)." } ;
|
||||
|
||||
HELP: push-back*
|
||||
{ $values { "obj" "an object" } { "dlist" dlist } { "dlist-node" dlist-node } }
|
||||
{ $description "Push the object onto the back of the " { $link dlist } " and return the newly created " { $snippet "dlist-node" } "." }
|
||||
{ $notes "This operation is O(1)." } ;
|
||||
|
||||
HELP: peek-front
|
||||
{ $values { "dlist" dlist } { "obj" "an object" } }
|
||||
{ $description "Returns the object at the front of the " { $link dlist } "." } ;
|
||||
|
||||
HELP: pop-front
|
||||
{ $values { "dlist" dlist } { "obj" "an object" } }
|
||||
{ $description "Pop the object off the front of the " { $link dlist } " and return the object." }
|
||||
{ $notes "This operation is O(1)." }
|
||||
{ $see-also push-front push-back pop-front* pop-back pop-back* } ;
|
||||
{ $notes "This operation is O(1)." } ;
|
||||
|
||||
HELP: pop-front*
|
||||
{ $values { "dlist" dlist } }
|
||||
{ $description "Pop the object off the front of the " { $link dlist } "." }
|
||||
{ $notes "This operation is O(1)." }
|
||||
{ $see-also push-front push-back pop-front pop-back pop-back* } ;
|
||||
{ $notes "This operation is O(1)." } ;
|
||||
|
||||
HELP: peek-back
|
||||
{ $values { "dlist" dlist } { "obj" "an object" } }
|
||||
{ $description "Returns the object at the back of the " { $link dlist } "." } ;
|
||||
|
||||
HELP: pop-back
|
||||
{ $values { "dlist" dlist } { "obj" "an object" } }
|
||||
{ $description "Pop the object off the back of the " { $link dlist } " and return the object." }
|
||||
{ $notes "This operation is O(1)." }
|
||||
{ $see-also push-front push-back pop-front pop-front* pop-back* } ;
|
||||
{ $notes "This operation is O(1)." } ;
|
||||
|
||||
HELP: pop-back*
|
||||
{ $values { "dlist" dlist } }
|
||||
{ $description "Pop the object off the back of the " { $link dlist } "." }
|
||||
{ $notes "This operation is O(1)." }
|
||||
{ $see-also push-front push-back pop-front pop-front* pop-back } ;
|
||||
{ $notes "This operation is O(1)." } ;
|
||||
|
||||
{ push-front push-front* push-back push-back* peek-front pop-front pop-front* peek-back pop-back pop-back* } related-words
|
||||
|
||||
HELP: dlist-find
|
||||
{ $values { "dlist" { $link dlist } } { "quot" quotation } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } }
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: dlists dlists.private kernel tools.test random assocs
|
||||
sets sequences namespaces sorting debugger io prettyprint
|
||||
math ;
|
||||
math accessors classes ;
|
||||
IN: dlists.tests
|
||||
|
||||
[ t ] [ <dlist> dlist-empty? ] unit-test
|
||||
|
|
@ -65,20 +65,17 @@ IN: dlists.tests
|
|||
: assert-same-elements
|
||||
[ prune natural-sort ] bi@ assert= ;
|
||||
|
||||
: dlist-push-all [ push-front ] curry each ;
|
||||
|
||||
: dlist-delete-all [ dlist-delete drop ] curry each ;
|
||||
|
||||
: dlist>array [ [ , ] dlist-slurp ] { } make ;
|
||||
|
||||
[ ] [
|
||||
5 [ drop 30 random >fixnum ] map prune
|
||||
6 [ drop 30 random >fixnum ] map prune 2dup nl . . nl
|
||||
[
|
||||
6 [ drop 30 random >fixnum ] map prune [
|
||||
<dlist>
|
||||
[ dlist-push-all ] keep
|
||||
[ dlist-delete-all ] keep
|
||||
dlist>array
|
||||
[ push-all-front ]
|
||||
[ dlist-delete-all ]
|
||||
[ dlist>array ] tri
|
||||
] 2keep swap diff assert-same-elements
|
||||
] unit-test
|
||||
|
||||
|
|
@ -95,3 +92,13 @@ IN: dlists.tests
|
|||
|
||||
[ 1 ] [ "d" get dlist-length ] unit-test
|
||||
[ 1 ] [ "d" get dlist>array length ] unit-test
|
||||
|
||||
[ t ] [ <dlist> 4 over push-back 5 over push-back [ obj>> 4 = ] dlist-find-node drop class dlist-node = ] unit-test
|
||||
[ t ] [ <dlist> 4 over push-back 5 over push-back [ obj>> 5 = ] dlist-find-node drop class dlist-node = ] unit-test
|
||||
[ t ] [ <dlist> 4 over push-back 5 over push-back* [ = ] curry dlist-find-node drop class dlist-node = ] unit-test
|
||||
[ ] [ <dlist> 4 over push-back 5 over push-back [ drop ] dlist-each ] unit-test
|
||||
|
||||
[ <dlist> peek-front ] must-fail
|
||||
[ <dlist> peek-back ] must-fail
|
||||
[ <dlist> pop-front ] [ empty-dlist? ] must-fail-with
|
||||
[ <dlist> pop-back ] [ empty-dlist? ] must-fail-with
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2007, 2008 Mackenzie Straight, Doug Coleman,
|
||||
! Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: combinators kernel math sequences accessors ;
|
||||
USING: combinators kernel math sequences accessors inspector ;
|
||||
IN: dlists
|
||||
|
||||
TUPLE: dlist front back length ;
|
||||
|
|
@ -47,7 +47,7 @@ C: <dlist-node> dlist-node
|
|||
|
||||
: (dlist-find-node) ( dlist-node quot -- node/f ? )
|
||||
over [
|
||||
[ >r obj>> r> call ] 2keep rot
|
||||
[ call ] 2keep rot
|
||||
[ drop t ] [ >r next>> r> (dlist-find-node) ] if
|
||||
] [ 2drop f f ] if ; inline
|
||||
|
||||
|
|
@ -55,7 +55,7 @@ C: <dlist-node> dlist-node
|
|||
>r front>> r> (dlist-find-node) ; inline
|
||||
|
||||
: dlist-each-node ( dlist quot -- )
|
||||
[ t ] compose dlist-find-node 2drop ; inline
|
||||
[ f ] compose dlist-find-node 2drop ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
@ -84,11 +84,17 @@ PRIVATE>
|
|||
: push-all-back ( seq dlist -- )
|
||||
[ push-back ] curry each ;
|
||||
|
||||
ERROR: empty-dlist ;
|
||||
|
||||
M: empty-dlist summary ( dlist -- )
|
||||
drop "Emtpy dlist" ;
|
||||
|
||||
: peek-front ( dlist -- obj )
|
||||
front>> obj>> ;
|
||||
front>> [ empty-dlist ] unless* obj>> ;
|
||||
|
||||
: pop-front ( dlist -- obj )
|
||||
dup front>> [
|
||||
dup front>> [ empty-dlist ] unless*
|
||||
[
|
||||
dup next>>
|
||||
f rot (>>next)
|
||||
f over set-prev-when
|
||||
|
|
@ -96,13 +102,15 @@ PRIVATE>
|
|||
] 2keep obj>>
|
||||
swap [ normalize-back ] keep dec-length ;
|
||||
|
||||
: pop-front* ( dlist -- ) pop-front drop ;
|
||||
: pop-front* ( dlist -- )
|
||||
pop-front drop ;
|
||||
|
||||
: peek-back ( dlist -- obj )
|
||||
back>> obj>> ;
|
||||
back>> [ empty-dlist ] unless* obj>> ;
|
||||
|
||||
: pop-back ( dlist -- obj )
|
||||
dup back>> [
|
||||
dup back>> [ empty-dlist ] unless*
|
||||
[
|
||||
dup prev>>
|
||||
f rot (>>prev)
|
||||
f over set-next-when
|
||||
|
|
@ -110,9 +118,11 @@ PRIVATE>
|
|||
] 2keep obj>>
|
||||
swap [ normalize-front ] keep dec-length ;
|
||||
|
||||
: pop-back* ( dlist -- ) pop-back drop ;
|
||||
: pop-back* ( dlist -- )
|
||||
pop-back drop ;
|
||||
|
||||
: dlist-find ( dlist quot -- obj/f ? )
|
||||
[ obj>> ] prepose
|
||||
dlist-find-node [ obj>> t ] [ drop f f ] if ; inline
|
||||
|
||||
: dlist-contains? ( dlist quot -- ? )
|
||||
|
|
@ -141,6 +151,7 @@ PRIVATE>
|
|||
] if ; inline
|
||||
|
||||
: delete-node-if ( dlist quot -- obj/f )
|
||||
[ obj>> ] prepose
|
||||
delete-node-if* drop ; inline
|
||||
|
||||
: dlist-delete ( obj dlist -- obj/f )
|
||||
|
|
|
|||
|
|
@ -102,13 +102,13 @@ M: frame-required fixup* drop ;
|
|||
|
||||
M: integer fixup* , ;
|
||||
|
||||
: push-new* ( obj table -- n )
|
||||
: adjoin* ( obj table -- n )
|
||||
2dup swap [ eq? ] curry find drop
|
||||
[ 2nip ] [ dup length >r push r> ] if* ;
|
||||
|
||||
SYMBOL: literal-table
|
||||
|
||||
: add-literal ( obj -- n ) literal-table get push-new* ;
|
||||
: add-literal ( obj -- n ) literal-table get adjoin* ;
|
||||
|
||||
: add-dlsym-literals ( symbol dll -- )
|
||||
>r string>symbol r> 2array literal-table get push-all ;
|
||||
|
|
|
|||
|
|
@ -147,12 +147,16 @@ M: method-body forget*
|
|||
[ implementors ] [ [ swap 2array ] curry ] bi map forget-all ;
|
||||
|
||||
M: class forget* ( class -- )
|
||||
{
|
||||
[ forget-methods ]
|
||||
[ update-map- ]
|
||||
[ reset-class ]
|
||||
[ call-next-method ]
|
||||
} cleave ;
|
||||
[
|
||||
class-usages [
|
||||
drop
|
||||
[ forget-methods ]
|
||||
[ update-map- ]
|
||||
[ reset-class ]
|
||||
tri
|
||||
] assoc-each
|
||||
]
|
||||
[ call-next-method ] bi ;
|
||||
|
||||
M: assoc update-methods ( assoc -- )
|
||||
implementors* [ make-generic ] each ;
|
||||
|
|
|
|||
|
|
@ -22,8 +22,7 @@ C: <predicate-dispatch-engine> predicate-dispatch-engine
|
|||
} cond ;
|
||||
|
||||
: sort-methods ( assoc -- assoc' )
|
||||
[ keys sort-classes ]
|
||||
[ [ dupd at ] curry ] bi { } map>assoc ;
|
||||
>alist [ keys sort-classes ] keep extract-keys ;
|
||||
|
||||
M: predicate-dispatch-engine engine>quot
|
||||
methods>> clone
|
||||
|
|
|
|||
|
|
@ -152,16 +152,16 @@ M: pair apply-constraint
|
|||
M: pair constraint-satisfied?
|
||||
first constraint-satisfied? ;
|
||||
|
||||
: extract-keys ( seq assoc -- newassoc )
|
||||
[ dupd at ] curry H{ } map>assoc [ nip ] assoc-filter f assoc-like ;
|
||||
: valid-keys ( seq assoc -- newassoc )
|
||||
extract-keys [ nip ] assoc-filter f assoc-like ;
|
||||
|
||||
: annotate-node ( node -- )
|
||||
#! Annotate the node with the currently-inferred set of
|
||||
#! value classes.
|
||||
dup node-values {
|
||||
[ value-intervals get extract-keys >>intervals ]
|
||||
[ value-classes get extract-keys >>classes ]
|
||||
[ value-literals get extract-keys >>literals ]
|
||||
[ value-intervals get valid-keys >>intervals ]
|
||||
[ value-classes get valid-keys >>classes ]
|
||||
[ value-literals get valid-keys >>literals ]
|
||||
[ 2drop ]
|
||||
} cleave ;
|
||||
|
||||
|
|
@ -330,7 +330,7 @@ M: #return infer-classes-around
|
|||
[ ] [ node-input-classes ] [ in-d>> [ value-class* ] map ] tri
|
||||
classes= not [
|
||||
fixed-point? off
|
||||
[ in-d>> value-classes get extract-keys ] keep
|
||||
[ in-d>> value-classes get valid-keys ] keep
|
||||
set-node-classes
|
||||
] [ drop ] if
|
||||
] [ call-next-method ] if
|
||||
|
|
|
|||
|
|
@ -460,3 +460,28 @@ must-fail-with
|
|||
"change-combination" "parser.tests" lookup
|
||||
"methods" word-prop assoc-size
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
2 [
|
||||
"IN: parser.tests DEFER: twice-fails FORGET: twice-fails MIXIN: twice-fails"
|
||||
<string-reader> "twice-fails-test" parse-stream drop
|
||||
] times
|
||||
] unit-test
|
||||
|
||||
[ [ ] ] [
|
||||
"IN: parser.tests : staging-problem-test-1 1 ; : staging-problem-test-2 staging-problem-test-1 ;"
|
||||
<string-reader> "staging-problem-test" parse-stream
|
||||
] unit-test
|
||||
|
||||
[ t ] [ "staging-problem-test-1" "parser.tests" lookup >boolean ] unit-test
|
||||
|
||||
[ t ] [ "staging-problem-test-2" "parser.tests" lookup >boolean ] unit-test
|
||||
|
||||
[ [ ] ] [
|
||||
"IN: parser.tests << : staging-problem-test-1 1 ; >> : staging-problem-test-2 staging-problem-test-1 ;"
|
||||
<string-reader> "staging-problem-test" parse-stream
|
||||
] unit-test
|
||||
|
||||
[ t ] [ "staging-problem-test-1" "parser.tests" lookup >boolean ] unit-test
|
||||
|
||||
[ t ] [ "staging-problem-test-2" "parser.tests" lookup >boolean ] unit-test
|
||||
|
|
|
|||
|
|
@ -357,10 +357,9 @@ M: staging-violation summary
|
|||
"A parsing word cannot be used in the same file it is defined in." ;
|
||||
|
||||
: execute-parsing ( word -- )
|
||||
new-definitions get [
|
||||
dupd first key? [ staging-violation ] when
|
||||
] when*
|
||||
execute ;
|
||||
[ changed-definitions get key? [ staging-violation ] when ]
|
||||
[ execute ]
|
||||
bi ;
|
||||
|
||||
: parse-step ( accum end -- accum ? )
|
||||
scan-word {
|
||||
|
|
|
|||
|
|
@ -342,3 +342,5 @@ INTERSECTION: intersection-see-test sequence number ;
|
|||
|
||||
[ ] [ \ compose see ] unit-test
|
||||
[ ] [ \ curry see ] unit-test
|
||||
|
||||
[ "POSTPONE: [" ] [ \ [ unparse ] unit-test
|
||||
|
|
|
|||
|
|
@ -191,7 +191,6 @@ $nl
|
|||
"Other destructive words:"
|
||||
{ $subsection move }
|
||||
{ $subsection exchange }
|
||||
{ $subsection push-new }
|
||||
{ $subsection copy }
|
||||
{ $subsection replace-slice }
|
||||
{ $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" } "." }
|
||||
{ $side-effects "seq" } ;
|
||||
|
||||
HELP: push-new
|
||||
{ $values { "elt" object } { "seq" "a resizable mutable sequence" } }
|
||||
{ $description "Removes all elements equal to " { $snippet "elt" } ", and adds " { $snippet "elt" } " at the end of the sequence." }
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: namespaces prettyprint sequences ;"
|
||||
"V{ \"beans\" \"salsa\" \"cheese\" } \"v\" set"
|
||||
"\"nachos\" \"v\" get push-new"
|
||||
"\"salsa\" \"v\" get push-new"
|
||||
"\"v\" get ."
|
||||
"V{ \"beans\" \"cheese\" \"nachos\" \"salsa\" }"
|
||||
}
|
||||
}
|
||||
{ $side-effects "seq" } ;
|
||||
|
||||
{ push push-new prefix suffix } related-words
|
||||
{ push prefix suffix } related-words
|
||||
|
||||
HELP: suffix
|
||||
{ $values { "seq" sequence } { "elt" object } { "newseq" sequence } }
|
||||
|
|
|
|||
|
|
@ -215,12 +215,6 @@ unit-test
|
|||
3 V{ 1 2 3 4 5 6 } clone [ delete-nth ] keep
|
||||
] unit-test
|
||||
|
||||
[ V{ 1 2 3 } ]
|
||||
[ 3 V{ 1 2 } clone [ push-new ] keep ] unit-test
|
||||
|
||||
[ V{ 1 2 3 } ]
|
||||
[ 3 V{ 1 3 2 } clone [ push-new ] keep ] unit-test
|
||||
|
||||
! erg's random tester found this one
|
||||
[ SBUF" 12341234" ] [
|
||||
9 <sbuf> dup "1234" swap push-all dup dup swap push-all
|
||||
|
|
|
|||
|
|
@ -499,8 +499,6 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
|
|||
|
||||
: delete ( elt seq -- ) 0 0 rot (delete) nip set-length drop ;
|
||||
|
||||
: push-new ( elt seq -- ) [ delete ] 2keep push ;
|
||||
|
||||
: prefix ( seq elt -- newseq )
|
||||
over >r over length 1+ r> [
|
||||
[ 0 swap set-nth-unsafe ] keep
|
||||
|
|
@ -680,7 +678,7 @@ PRIVATE>
|
|||
: unclip ( seq -- rest first )
|
||||
[ rest ] [ first ] bi ;
|
||||
|
||||
: unclip-last ( seq -- butfirst last )
|
||||
: unclip-last ( seq -- butlast last )
|
||||
[ but-last ] [ peek ] bi ;
|
||||
|
||||
: unclip-slice ( seq -- rest first )
|
||||
|
|
|
|||
|
|
@ -16,10 +16,28 @@ $nl
|
|||
{ $subsection set= }
|
||||
"A word used to implement the above:"
|
||||
{ $subsection unique }
|
||||
"Adding elements to sets:"
|
||||
{ $subsection adjoin }
|
||||
{ $subsection conjoin }
|
||||
{ $see-also member? memq? contains? all? "assocs-sets" } ;
|
||||
|
||||
ABOUT: "sets"
|
||||
|
||||
HELP: adjoin
|
||||
{ $values { "elt" object } { "seq" "a resizable mutable sequence" } }
|
||||
{ $description "Removes all elements equal to " { $snippet "elt" } ", and adds " { $snippet "elt" } " at the end of the sequence." }
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: namespaces prettyprint sequences ;"
|
||||
"V{ \"beans\" \"salsa\" \"cheese\" } \"v\" set"
|
||||
"\"nachos\" \"v\" get adjoin"
|
||||
"\"salsa\" \"v\" get adjoin"
|
||||
"\"v\" get ."
|
||||
"V{ \"beans\" \"cheese\" \"nachos\" \"salsa\" }"
|
||||
}
|
||||
}
|
||||
{ $side-effects "seq" } ;
|
||||
|
||||
HELP: unique
|
||||
{ $values { "seq" "a sequence" } { "assoc" "an assoc" } }
|
||||
{ $description "Outputs a new assoc where the keys and values are equal." }
|
||||
|
|
|
|||
|
|
@ -15,3 +15,9 @@ IN: sets.tests
|
|||
|
||||
[ V{ } ] [ { } { } union ] unit-test
|
||||
[ V{ 1 2 3 4 } ] [ { 1 2 3 } { 2 3 4 } union ] unit-test
|
||||
|
||||
[ V{ 1 2 3 } ]
|
||||
[ 3 V{ 1 2 } clone [ adjoin ] keep ] unit-test
|
||||
|
||||
[ V{ 1 2 3 } ]
|
||||
[ 3 V{ 1 3 2 } clone [ adjoin ] keep ] unit-test
|
||||
|
|
|
|||
|
|
@ -3,10 +3,14 @@
|
|||
USING: assocs hashtables kernel sequences vectors ;
|
||||
IN: sets
|
||||
|
||||
: adjoin ( elt seq -- ) [ delete ] [ push ] 2bi ;
|
||||
|
||||
: conjoin ( elt assoc -- ) dupd set-at ;
|
||||
|
||||
: (prune) ( elt hash vec -- )
|
||||
3dup drop key?
|
||||
[ [ drop dupd set-at ] [ nip push ] [ ] 3tri ] unless
|
||||
3drop ; inline
|
||||
3dup drop key? [ 3drop ] [
|
||||
[ drop conjoin ] [ nip push ] 3bi
|
||||
] if ; inline
|
||||
|
||||
: prune ( seq -- newseq )
|
||||
[ ] [ length <hashtable> ] [ length <vector> ] tri
|
||||
|
|
@ -16,7 +20,7 @@ IN: sets
|
|||
[ dup ] H{ } map>assoc ;
|
||||
|
||||
: (all-unique?) ( elt hash -- ? )
|
||||
2dup key? [ 2drop f ] [ dupd set-at t ] if ;
|
||||
2dup key? [ 2drop f ] [ conjoin t ] if ;
|
||||
|
||||
: all-unique? ( seq -- ? )
|
||||
dup length <hashtable> [ (all-unique?) ] curry all? ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,25 @@
|
|||
USING: help.markup help.syntax sequences strings ;
|
||||
IN: splitting
|
||||
|
||||
ARTICLE: "groups-clumps" "Groups and clumps"
|
||||
"A virtual sequence for splitting a sequence into disjoint, fixed-length subsequences:"
|
||||
{ $subsection groups }
|
||||
{ $subsection <groups> }
|
||||
{ $subsection <sliced-groups> }
|
||||
"A virtual sequence for splitting a sequence into overlapping, fixed-length subsequences:"
|
||||
{ $subsection clumps }
|
||||
{ $subsection <clumps> }
|
||||
{ $subsection <sliced-clumps> }
|
||||
"The difference can be summarized as the following:"
|
||||
{ $list
|
||||
{ "With groups, the subsequences form the original sequence when concatenated:"
|
||||
{ $unchecked-example "dup n groups concat sequence= ." "t" }
|
||||
}
|
||||
{ "With clumps, collecting the first element of each subsequence but the last one, together with the last subseqence, yields the original sequence:"
|
||||
{ $unchecked-example "dup n clumps unclip-last >r [ first ] map r> append sequence= ." "t" }
|
||||
}
|
||||
} ;
|
||||
|
||||
ARTICLE: "sequences-split" "Splitting sequences"
|
||||
"Splitting sequences at occurrences of subsequences:"
|
||||
{ $subsection ?head }
|
||||
|
|
@ -9,14 +28,9 @@ ARTICLE: "sequences-split" "Splitting sequences"
|
|||
{ $subsection ?tail-slice }
|
||||
{ $subsection split1 }
|
||||
{ $subsection split }
|
||||
"Grouping elements:"
|
||||
{ $subsection group }
|
||||
"A virtual sequence for grouping elements:"
|
||||
{ $subsection groups }
|
||||
{ $subsection <groups> }
|
||||
{ $subsection <sliced-groups> }
|
||||
"Splitting a string into lines:"
|
||||
{ $subsection string-lines } ;
|
||||
{ $subsection string-lines }
|
||||
{ $subsection "groups-clumps" } ;
|
||||
|
||||
ABOUT: "sequences-split"
|
||||
|
||||
|
|
@ -36,19 +50,22 @@ HELP: split
|
|||
{ $examples { $example "USING: prettyprint splitting ;" "\"hello world-how are you?\" \" -\" split ." "{ \"hello\" \"world\" \"how\" \"are\" \"you?\" }" } } ;
|
||||
|
||||
HELP: groups
|
||||
{ $class-description "Instances are virtual sequences whose elements are fixed-length subsequences or slices of an underlying sequence. Groups are mutable and resizable if the underlying sequence is mutable and resizable, respectively."
|
||||
{ $class-description "Instances are virtual sequences whose elements are disjoint fixed-length subsequences of an underlying sequence. Groups are mutable and resizable if the underlying sequence is mutable and resizable, respectively."
|
||||
$nl
|
||||
"New groups are created by calling " { $link <groups> } " and " { $link <sliced-groups> } "." }
|
||||
{ $see-also group } ;
|
||||
|
||||
HELP: group
|
||||
{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "array" "a sequence of sequences" } }
|
||||
{ $description "Splits the sequence into groups of " { $snippet "n" } " elements and collects the groups into a new array." }
|
||||
{ $notes "If the sequence length is not a multiple of " { $snippet "n" } ", the final subsequence in the list will be shorter than " { $snippet "n" } " elements." } ;
|
||||
{ $description "Splits the sequence into disjoint groups of " { $snippet "n" } " elements and collects the groups into a new array." }
|
||||
{ $notes "If the sequence length is not a multiple of " { $snippet "n" } ", the final subsequence in the list will be shorter than " { $snippet "n" } " elements." }
|
||||
{ $examples
|
||||
{ $example "USING: splitting prettyprint ;" "{ 3 1 3 3 7 } 2 group ." "{ { 3 1 } { 3 3 } { 7 } }" }
|
||||
} ;
|
||||
|
||||
HELP: <groups>
|
||||
{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "groups" groups } }
|
||||
{ $description "Outputs a virtual sequence whose elements are subsequences consisting of groups of " { $snippet "n" } " elements from the underlying sequence." }
|
||||
{ $description "Outputs a virtual sequence whose elements are disjoint subsequences of " { $snippet "n" } " elements from the underlying sequence." }
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: arrays kernel prettyprint sequences splitting ;"
|
||||
|
|
@ -58,7 +75,7 @@ HELP: <groups>
|
|||
|
||||
HELP: <sliced-groups>
|
||||
{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "groups" groups } }
|
||||
{ $description "Outputs a virtual sequence whose elements are slices consisting of groups of " { $snippet "n" } " elements from the underlying sequence." }
|
||||
{ $description "Outputs a virtual sequence whose elements are overlapping subsequences of " { $snippet "n" } " elements from the underlying sequence." }
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: arrays kernel prettyprint sequences splitting ;"
|
||||
|
|
@ -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
|
||||
{ $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 ;
|
||||
|
||||
: <clumps> ( seq n -- groups )
|
||||
: <clumps> ( seq n -- clumps )
|
||||
clumps construct-groups ; inline
|
||||
|
||||
M: clumps length
|
||||
|
|
@ -58,7 +58,7 @@ M: clumps group@
|
|||
|
||||
TUPLE: sliced-clumps < groups ;
|
||||
|
||||
: <sliced-clumps> ( seq n -- groups )
|
||||
: <sliced-clumps> ( seq n -- clumps )
|
||||
sliced-clumps construct-groups ; inline
|
||||
|
||||
M: sliced-clumps nth group@ <slice> ;
|
||||
|
|
|
|||
|
|
@ -101,7 +101,7 @@ IN: bootstrap.syntax
|
|||
|
||||
"DEFER:" [
|
||||
scan in get create
|
||||
dup old-definitions get first delete-at
|
||||
dup old-definitions get [ delete-at ] with each
|
||||
set-word
|
||||
] define-syntax
|
||||
|
||||
|
|
@ -189,8 +189,9 @@ IN: bootstrap.syntax
|
|||
"MAIN:" [ scan-word in get vocab set-vocab-main ] define-syntax
|
||||
|
||||
"<<" [
|
||||
[ \ >> parse-until >quotation ] with-compilation-unit
|
||||
call
|
||||
[
|
||||
\ >> parse-until >quotation
|
||||
] with-nested-compilation-unit call
|
||||
] define-syntax
|
||||
|
||||
"call-next-method" [
|
||||
|
|
|
|||
|
|
@ -175,7 +175,9 @@ PRIVATE>
|
|||
: define-symbol ( word -- )
|
||||
dup [ ] curry define-inline ;
|
||||
|
||||
: reset-word ( word -- )
|
||||
GENERIC: reset-word ( word -- )
|
||||
|
||||
M: word reset-word
|
||||
{
|
||||
"unannotated-def"
|
||||
"parsing" "inline" "foldable" "flushable"
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: arrays assocs kernel vectors sequences namespaces
|
||||
random math.parser ;
|
||||
random math.parser math fry ;
|
||||
IN: assocs.lib
|
||||
|
||||
: ref-at ( table key -- value ) swap at ;
|
||||
|
|
@ -40,3 +40,8 @@ IN: assocs.lib
|
|||
|
||||
: set-at-unique ( value assoc -- key )
|
||||
dup generate-key [ swap set-at ] keep ;
|
||||
|
||||
: histogram ( assoc quot -- assoc' )
|
||||
H{ } clone [
|
||||
swap [ change-at ] 2curry assoc-each
|
||||
] keep ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
: utf8 ( -- )
|
||||
cr "Serif" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_NORMAL
|
||||
cr "Sans" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_NORMAL
|
||||
cairo_select_font_face
|
||||
cr 50 cairo_set_font_size
|
||||
"cairo_text_extents_t" malloc-object
|
||||
cr B{ 230 151 165 230 156 172 232 170 158 } pick cairo_text_extents
|
||||
cr "日本語" pick cairo_text_extents
|
||||
cr over
|
||||
[ cairo_text_extents_t-width 2 / ]
|
||||
[ cairo_text_extents_t-x_bearing ] bi +
|
||||
|
|
@ -129,7 +129,7 @@ IN: cairo.samples
|
|||
[ cairo_text_extents_t-y_bearing ] bi +
|
||||
128 swap - cairo_move_to
|
||||
free
|
||||
cr B{ 230 151 165 230 156 172 232 170 158 } cairo_show_text
|
||||
cr "日本語" cairo_show_text
|
||||
|
||||
cr 1 0.2 0.2 0.6 cairo_set_source_rgba
|
||||
cr 6 cairo_set_line_width
|
||||
|
|
|
|||
|
|
@ -50,3 +50,15 @@ IN: calendar.format.tests
|
|||
"Sun May 04 07:00:00 2008 GMT" cookie-string>timestamp
|
||||
timestamp>string
|
||||
] 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
|
||||
combinators accessors debugger
|
||||
calendar calendar.format.macros ;
|
||||
|
|
@ -151,11 +151,15 @@ M: timestamp year. ( timestamp -- )
|
|||
: read-hms ( -- h m s )
|
||||
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 )
|
||||
read-ymd
|
||||
"Tt" expect
|
||||
read-hms
|
||||
read1 { { CHAR: . [ read-000 1000 / + read1 ] } [ ] } case
|
||||
read1 { { CHAR: . [ read-rfc3339-seconds ] } [ ] } case
|
||||
read-rfc3339-gmt-offset
|
||||
<timestamp> ;
|
||||
|
||||
|
|
|
|||
|
|
@ -27,3 +27,15 @@ circular strings ;
|
|||
! This no longer fails
|
||||
! [ "test" <circular> 5 swap nth ] must-fail
|
||||
! [ "foo" <circular> CHAR: b 3 rot set-nth ] must-fail
|
||||
|
||||
[ { } ] [ 3 <growing-circular> >array ] unit-test
|
||||
[ { 1 2 } ] [
|
||||
3 <growing-circular>
|
||||
[ 1 swap push-growing-circular ] keep
|
||||
[ 2 swap push-growing-circular ] keep >array
|
||||
] unit-test
|
||||
[ { 3 4 5 } ] [
|
||||
3 <growing-circular> dup { 1 2 3 4 5 } [
|
||||
swap push-growing-circular
|
||||
] with each >array
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -19,10 +19,6 @@ M: circular length seq>> length ;
|
|||
|
||||
M: circular virtual@ circular-wrap seq>> ;
|
||||
|
||||
M: circular nth virtual@ nth ;
|
||||
|
||||
M: circular set-nth virtual@ set-nth ;
|
||||
|
||||
M: circular virtual-seq seq>> ;
|
||||
|
||||
: change-circular-start ( n circular -- )
|
||||
|
|
@ -36,3 +32,20 @@ M: circular virtual-seq seq>> ;
|
|||
0 <string> <circular> ;
|
||||
|
||||
INSTANCE: circular virtual-sequence
|
||||
|
||||
TUPLE: growing-circular < circular length ;
|
||||
|
||||
M: growing-circular length length>> ;
|
||||
|
||||
: full? ( circular -- ? )
|
||||
[ length ] [ seq>> length ] bi = ;
|
||||
|
||||
: set-peek ( elt seq -- )
|
||||
[ length 1- ] keep set-nth ;
|
||||
|
||||
: push-growing-circular ( elt circular -- )
|
||||
dup full? [ push-circular ]
|
||||
[ [ 1+ ] change-length set-peek ] if ;
|
||||
|
||||
: <growing-circular> ( capacity -- growing-circular )
|
||||
{ } new-sequence 0 0 growing-circular boa ;
|
||||
|
|
|
|||
|
|
@ -127,7 +127,7 @@ M: nonthrowable execute-statement* ( statement type -- )
|
|||
: query-map ( statement quot -- seq )
|
||||
accumulator >r query-each r> { } like ; inline
|
||||
|
||||
: with-db ( db seq quot -- )
|
||||
: with-db ( seq class quot -- )
|
||||
>r make-db db-open db r>
|
||||
[ db get swap [ drop ] prepose with-disposal ] curry with-variable ;
|
||||
inline
|
||||
|
|
|
|||
|
|
@ -6,16 +6,16 @@ IN: db.pools
|
|||
|
||||
TUPLE: db-pool < pool db params ;
|
||||
|
||||
: <db-pool> ( db params -- pool )
|
||||
: <db-pool> ( params db -- pool )
|
||||
db-pool <pool>
|
||||
swap >>params
|
||||
swap >>db ;
|
||||
swap >>db
|
||||
swap >>params ;
|
||||
|
||||
: with-db-pool ( db params quot -- )
|
||||
>r <db-pool> r> with-pool ; inline
|
||||
|
||||
M: db-pool make-connection ( pool -- )
|
||||
[ db>> ] [ params>> ] bi make-db db-open ;
|
||||
[ params>> ] [ db>> ] bi make-db db-open ;
|
||||
|
||||
: with-pooled-db ( pool quot -- )
|
||||
[ db swap with-variable ] curry with-pooled-connection ; inline
|
||||
|
|
|
|||
|
|
@ -414,6 +414,25 @@ TUPLE: does-not-persist ;
|
|||
[ class \ not-persistent = ] must-fail-with
|
||||
] 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
|
||||
\ bind-tuple must-infer
|
||||
\ insert-tuple must-infer
|
||||
|
|
|
|||
|
|
@ -19,7 +19,7 @@ ERROR: not-persistent ;
|
|||
"db-table" word-prop [ not-persistent ] unless* ;
|
||||
|
||||
: db-columns ( class -- obj )
|
||||
"db-columns" word-prop ;
|
||||
superclasses [ "db-columns" word-prop ] map concat ;
|
||||
|
||||
: db-relations ( class -- obj )
|
||||
"db-relations" word-prop ;
|
||||
|
|
|
|||
|
|
@ -36,17 +36,17 @@ IN: farkup.tests
|
|||
[ "<p>|a</p>" ]
|
||||
[ "|a" convert-farkup ] unit-test
|
||||
|
||||
[ "<p>|a|</p>" ]
|
||||
[ "<table><tr><td>a</td></tr></table>" ]
|
||||
[ "|a|" convert-farkup ] unit-test
|
||||
|
||||
[ "<table><tr><td>a</td><td>b</td></tr></table>" ]
|
||||
[ "a|b" convert-farkup ] unit-test
|
||||
[ "|a|b|" convert-farkup ] unit-test
|
||||
|
||||
[ "<table><tr><td>a</td><td>b</td></tr></table>\n<table><tr><td>c</td><td>d</td></tr></table>" ]
|
||||
[ "a|b\nc|d" convert-farkup ] unit-test
|
||||
[ "<table><tr><td>a</td><td>b</td></tr><tr><td>c</td><td>d</td></tr></table>" ]
|
||||
[ "|a|b|\n|c|d|" convert-farkup ] unit-test
|
||||
|
||||
[ "<table><tr><td>a</td><td>b</td></tr></table>\n<table><tr><td>c</td><td>d</td></tr></table>\n" ]
|
||||
[ "a|b\nc|d\n" convert-farkup ] unit-test
|
||||
[ "<table><tr><td>a</td><td>b</td></tr><tr><td>c</td><td>d</td></tr></table>" ]
|
||||
[ "|a|b|\n|c|d|\n" convert-farkup ] unit-test
|
||||
|
||||
[ "<p><strong>foo</strong>\n</p><h1>aheading</h1>\n<p>adfasd</p>" ]
|
||||
[ "*foo*\n=aheading=\nadfasd" convert-farkup ] unit-test
|
||||
|
|
@ -62,12 +62,23 @@ IN: farkup.tests
|
|||
[ "<p>=</p><h2>foo</h2>" ] [ "===foo==" convert-farkup ] unit-test
|
||||
[ "<h1>foo</h1><p>=</p>" ] [ "=foo==" convert-farkup ] unit-test
|
||||
|
||||
[ "<div style='white-space: pre; font-family: monospace; '><span class='KEYWORD3'>int</span> <span class='FUNCTION'>main</span><span class='OPERATOR'>(</span><span class='OPERATOR'>)</span><br/></div>" ]
|
||||
[ "<pre><span class='KEYWORD3'>int</span> <span class='FUNCTION'>main</span><span class='OPERATOR'>(</span><span class='OPERATOR'>)</span>\n</pre>" ]
|
||||
[ "[c{int main()}]" convert-farkup ] unit-test
|
||||
|
||||
[ "<p><img src=\"lol.jpg\"/></p>" ] [ "[[image:lol.jpg]]" convert-farkup ] unit-test
|
||||
[ "<p><img src=\"lol.jpg\" alt=\"teh lol\"/></p>" ] [ "[[image:lol.jpg|teh lol]]" convert-farkup ] unit-test
|
||||
[ "<p><a href=\"lol.com\"></a></p>" ] [ "[[lol.com]]" convert-farkup ] unit-test
|
||||
[ "<p><a href=\"lol.com\">lol.com</a></p>" ] [ "[[lol.com]]" convert-farkup ] unit-test
|
||||
[ "<p><a href=\"lol.com\">haha</a></p>" ] [ "[[lol.com|haha]]" convert-farkup ] unit-test
|
||||
|
||||
[ ] [ "[{}]" convert-farkup drop ] unit-test
|
||||
|
||||
[
|
||||
"<p>Feature comparison:\n<table><tr><td>a</td><td>Factor</td><td>Java</td><td>Lisp</td></tr><tr><td>Coolness</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Badass</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Enterprise</td><td>Yes</td><td>Yes</td><td>No</td></tr><tr><td>Kosher</td><td>Yes</td><td>No</td><td>Yes</td></tr></table></p>"
|
||||
] [ "Feature comparison:\n|a|Factor|Java|Lisp|\n|Coolness|Yes|No|No|\n|Badass|Yes|No|No|\n|Enterprise|Yes|Yes|No|\n|Kosher|Yes|No|Yes|\n" convert-farkup ] unit-test
|
||||
|
||||
[
|
||||
"<p>Feature comparison:\n\n<table><tr><td>a</td><td>Factor</td><td>Java</td><td>Lisp</td></tr><tr><td>Coolness</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Badass</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Enterprise</td><td>Yes</td><td>Yes</td><td>No</td></tr><tr><td>Kosher</td><td>Yes</td><td>No</td><td>Yes</td></tr></table></p>"
|
||||
] [ "Feature comparison:\n\n|a|Factor|Java|Lisp|\n|Coolness|Yes|No|No|\n|Badass|Yes|No|No|\n|Enterprise|Yes|Yes|No|\n|Kosher|Yes|No|Yes|\n" convert-farkup ] unit-test
|
||||
|
||||
[ "<p>a-b</p>" ] [ "a-b" convert-farkup ] unit-test
|
||||
[ "<ul><li>a-b</li></ul>" ] [ "-a-b" convert-farkup ] unit-test
|
||||
|
|
|
|||
|
|
@ -2,10 +2,13 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays io io.styles kernel memoize namespaces peg
|
||||
sequences strings html.elements xml.entities xmode.code2html
|
||||
splitting io.streams.string html peg.parsers html.elements
|
||||
splitting io.streams.string peg.parsers
|
||||
sequences.deep unicode.categories ;
|
||||
IN: farkup
|
||||
|
||||
SYMBOL: relative-link-prefix
|
||||
SYMBOL: link-no-follow?
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: delimiters ( -- string )
|
||||
|
|
@ -59,25 +62,30 @@ MEMO: eq ( -- parser )
|
|||
: render-code ( string mode -- string' )
|
||||
>r string-lines r>
|
||||
[
|
||||
[
|
||||
H{ { wrap-margin f } } [
|
||||
htmlize-lines
|
||||
] with-nesting
|
||||
] with-html-stream
|
||||
<pre>
|
||||
htmlize-lines
|
||||
</pre>
|
||||
] with-string-writer ;
|
||||
|
||||
: check-url ( href -- href' )
|
||||
CHAR: : over member? [
|
||||
dup { "http://" "https://" "ftp://" } [ head? ] with contains?
|
||||
[ drop "/" ] unless
|
||||
] when ;
|
||||
] [
|
||||
relative-link-prefix get prepend
|
||||
] if ;
|
||||
|
||||
: escape-link ( href text -- href-esc text-esc )
|
||||
>r check-url escape-quoted-string r> escape-string ;
|
||||
|
||||
: make-link ( href text -- seq )
|
||||
escape-link
|
||||
[ "<a href=\"" , >r , r> "\">" , [ , ] when* "</a>" , ] { } make ;
|
||||
[
|
||||
"<a" ,
|
||||
" href=\"" , >r , r>
|
||||
link-no-follow? get [ " nofollow=\"true\"" , ] when
|
||||
"\">" , , "</a>" ,
|
||||
] { } make ;
|
||||
|
||||
: make-image-link ( href alt -- seq )
|
||||
escape-link
|
||||
|
|
@ -102,7 +110,7 @@ MEMO: simple-link ( -- parser )
|
|||
"[[" token hide ,
|
||||
[ "|]" member? not ] satisfy repeat1 ,
|
||||
"]]" token hide ,
|
||||
] seq* [ first f make-link ] action ;
|
||||
] seq* [ first dup make-link ] action ;
|
||||
|
||||
MEMO: labelled-link ( -- parser )
|
||||
[
|
||||
|
|
@ -113,12 +121,14 @@ MEMO: labelled-link ( -- parser )
|
|||
"]]" token hide ,
|
||||
] seq* [ first2 make-link ] action ;
|
||||
|
||||
MEMO: link ( -- parser ) [ image-link , simple-link , labelled-link , ] choice* ;
|
||||
MEMO: link ( -- parser )
|
||||
[ image-link , simple-link , labelled-link , ] choice* ;
|
||||
|
||||
DEFER: line
|
||||
MEMO: list-item ( -- parser )
|
||||
[
|
||||
"-" token hide , line ,
|
||||
"-" token hide , ! text ,
|
||||
[ "\r\n" member? not ] satisfy repeat1 [ >string escape-string ] action ,
|
||||
] seq* [ "li" surround-with-foo ] action ;
|
||||
|
||||
MEMO: list ( -- parser )
|
||||
|
|
@ -129,12 +139,14 @@ MEMO: table-column ( -- parser )
|
|||
text [ "td" surround-with-foo ] action ;
|
||||
|
||||
MEMO: table-row ( -- parser )
|
||||
[
|
||||
table-column "|" token hide list-of-many ,
|
||||
] seq* [ "tr" surround-with-foo ] action ;
|
||||
"|" token hide
|
||||
table-column "|" token hide list-of
|
||||
"|" token hide nl hide optional 4seq
|
||||
[ "tr" surround-with-foo ] action ;
|
||||
|
||||
MEMO: table ( -- parser )
|
||||
table-row repeat1 [ "table" surround-with-foo ] action ;
|
||||
table-row repeat1
|
||||
[ "table" surround-with-foo ] action ;
|
||||
|
||||
MEMO: code ( -- parser )
|
||||
[
|
||||
|
|
@ -147,6 +159,8 @@ MEMO: code ( -- parser )
|
|||
|
||||
MEMO: line ( -- parser )
|
||||
[
|
||||
nl table 2seq ,
|
||||
nl list 2seq ,
|
||||
text , strong , emphasis , link ,
|
||||
superscript , subscript , inline-code ,
|
||||
escaped-char , delimiter , eq ,
|
||||
|
|
|
|||
|
|
@ -52,3 +52,13 @@ sequences ;
|
|||
[ { 1 { 2 { 3 } } } ] [
|
||||
1 2 3 '[ , [ , [ , 1array ] call 2array ] call 2array ] call
|
||||
] unit-test
|
||||
|
||||
{ 1 1 } [ '[ [ [ , ] ] ] ] must-infer-as
|
||||
|
||||
[ { { { 3 } } } ] [
|
||||
3 '[ [ [ , 1array ] call 1array ] call 1array ] call
|
||||
] unit-test
|
||||
|
||||
[ { { { 3 } } } ] [
|
||||
3 '[ [ [ , 1array ] call 1array ] call 1array ] call
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -46,15 +46,22 @@ DEFER: (shallow-fry)
|
|||
shallow-fry
|
||||
] if* ;
|
||||
|
||||
: fry-specifier? ( obj -- ? ) { , namespaces:, @ } member? ;
|
||||
|
||||
: count-inputs ( quot -- n )
|
||||
[
|
||||
{
|
||||
{ [ dup callable? ] [ count-inputs ] }
|
||||
{ [ dup fry-specifier? ] [ drop 1 ] }
|
||||
[ drop 0 ]
|
||||
} cond
|
||||
] map sum ;
|
||||
|
||||
: fry ( quot -- quot' )
|
||||
[
|
||||
[
|
||||
dup callable? [
|
||||
[
|
||||
[ { , namespaces:, @ } member? ] filter length
|
||||
\ , <repetition> %
|
||||
]
|
||||
[ fry % ] bi
|
||||
[ count-inputs \ , <repetition> % ] [ fry % ] bi
|
||||
] [ namespaces:, ] if
|
||||
] each
|
||||
] [ ] make deep-fry ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,180 @@
|
|||
IN: html.components.tests
|
||||
USING: tools.test kernel io.streams.string
|
||||
io.streams.null accessors inspector html.streams
|
||||
html.components ;
|
||||
|
||||
[ ] [ 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
|
||||
USING: tools.test html html.elements io.streams.string ;
|
||||
|
||||
: make-html-string
|
||||
[ with-html-stream ] with-string-writer ;
|
||||
USING: tools.test html.elements io.streams.string ;
|
||||
|
||||
[ "<a href='h&o'>" ]
|
||||
[ [ <a "h&o" =href a> ] make-html-string ] unit-test
|
||||
[ [ <a "h&o" =href a> ] with-string-writer ] unit-test
|
||||
|
|
|
|||
|
|
@ -57,6 +57,8 @@ SYMBOL: html
|
|||
: print-html ( str -- )
|
||||
write-html "\n" write-html ;
|
||||
|
||||
<<
|
||||
|
||||
: html-word ( name def effect -- )
|
||||
#! Define 'word creating' word to allow
|
||||
#! dynamically creating words.
|
||||
|
|
@ -137,30 +139,46 @@ SYMBOL: html
|
|||
dup "=" prepend swap
|
||||
[ 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"
|
||||
"ol" "li" "form" "a" "p" "html" "head" "body" "title"
|
||||
"b" "i" "ul" "table" "tbody" "tr" "td" "th" "pre" "textarea"
|
||||
"script" "div" "span" "select" "option" "style" "input"
|
||||
] [ define-closed-html-word ] each
|
||||
"h1" "h2" "h3" "h4" "h5" "h6" "h7" "h8" "h9"
|
||||
"ol" "li" "form" "a" "p" "html" "head" "body" "title"
|
||||
"b" "i" "ul" "table" "tbody" "tr" "td" "th" "pre" "textarea"
|
||||
"script" "div" "span" "select" "option" "style" "input"
|
||||
] [ define-closed-html-word ] each
|
||||
|
||||
! Define some open HTML tags
|
||||
[
|
||||
"input"
|
||||
"br"
|
||||
"link"
|
||||
"img"
|
||||
] [ define-open-html-word ] each
|
||||
! Define some open HTML tags
|
||||
[
|
||||
"input"
|
||||
"br"
|
||||
"link"
|
||||
"img"
|
||||
] [ define-open-html-word ] each
|
||||
|
||||
! Define some attributes
|
||||
[
|
||||
"method" "action" "type" "value" "name"
|
||||
"size" "href" "class" "border" "rows" "cols"
|
||||
"id" "onclick" "style" "valign" "accesskey"
|
||||
"src" "language" "colspan" "onchange" "rel"
|
||||
"width" "selected" "onsubmit" "xmlns" "lang" "xml:lang"
|
||||
"media" "title" "multiple"
|
||||
] [ define-attribute-word ] each
|
||||
] with-compilation-unit
|
||||
! Define some attributes
|
||||
[
|
||||
"method" "action" "type" "value" "name"
|
||||
"size" "href" "class" "border" "rows" "cols"
|
||||
"id" "onclick" "style" "valign" "accesskey"
|
||||
"src" "language" "colspan" "onchange" "rel"
|
||||
"width" "selected" "onsubmit" "xmlns" "lang" "xml:lang"
|
||||
"media" "title" "multiple"
|
||||
] [ define-attribute-word ] each
|
||||
|
||||
>>
|
||||
|
||||
: 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
|
||||
namespaces tools.test xml.writer sbufs sequences html.private ;
|
||||
IN: html.tests
|
||||
USING: html.streams html.streams.private
|
||||
io io.streams.string io.styles kernel
|
||||
namespaces tools.test xml.writer sbufs sequences inspector ;
|
||||
IN: html.streams.tests
|
||||
|
||||
: make-html-string
|
||||
[ with-html-stream ] with-string-writer ; inline
|
||||
|
|
@ -69,3 +70,5 @@ M: funky browser-link-href
|
|||
] [
|
||||
[ H{ } [ ] with-nesting nl ] make-html-string
|
||||
] 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
|
||||
classes.tuple assocs splitting words arrays memoize
|
||||
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
|
||||
html.elements
|
||||
html.components
|
||||
html.templates
|
||||
http.server
|
||||
http.server.auth
|
||||
http.server.flows
|
||||
http.server.actions
|
||||
http.server.components
|
||||
http.server.sessions
|
||||
http.server.templating
|
||||
http.server.boilerplate ;
|
||||
IN: http.server.templating.chloe
|
||||
http.server.sessions ;
|
||||
IN: html.templates.chloe
|
||||
|
||||
! Chloe is Ed's favorite web designer
|
||||
|
||||
|
|
@ -52,8 +52,11 @@ MEMO: chloe-name ( string -- name )
|
|||
: optional-attr ( tag name -- value )
|
||||
chloe-name swap at ;
|
||||
|
||||
: process-tag-children ( tag -- )
|
||||
[ process-template ] each ;
|
||||
|
||||
: children>string ( tag -- string )
|
||||
[ [ process-template ] each ] with-string-writer ;
|
||||
[ process-tag-children ] with-string-writer ;
|
||||
|
||||
: title-tag ( tag -- )
|
||||
children>string set-title ;
|
||||
|
|
@ -89,18 +92,6 @@ MEMO: chloe-name ( string -- name )
|
|||
atom-feed get value>> second write
|
||||
] if ;
|
||||
|
||||
: component-attr ( tag -- name )
|
||||
"component" required-attr ;
|
||||
|
||||
: view-tag ( tag -- )
|
||||
component-attr component render-view ;
|
||||
|
||||
: edit-tag ( tag -- )
|
||||
component-attr component render-edit ;
|
||||
|
||||
: summary-tag ( tag -- )
|
||||
component-attr component render-summary ;
|
||||
|
||||
: parse-query-attr ( string -- assoc )
|
||||
dup empty?
|
||||
[ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ;
|
||||
|
|
@ -133,9 +124,6 @@ MEMO: chloe-name ( string -- name )
|
|||
a>
|
||||
] with-scope ;
|
||||
|
||||
: process-tag-children ( tag -- )
|
||||
[ process-template ] each ;
|
||||
|
||||
: a-tag ( tag -- )
|
||||
[ a-start-tag ]
|
||||
[ process-tag-children ]
|
||||
|
|
@ -156,7 +144,7 @@ MEMO: chloe-name ( string -- name )
|
|||
form>
|
||||
] [
|
||||
hidden-form-field
|
||||
"for" optional-attr [ component render-edit ] when*
|
||||
"for" optional-attr [ hidden render ] when*
|
||||
] bi
|
||||
] with-scope ;
|
||||
|
||||
|
|
@ -180,9 +168,9 @@ STRING: button-tag-markup
|
|||
: button-tag ( tag -- )
|
||||
button-tag-markup string>xml delegate
|
||||
{
|
||||
[ >r tag-attrs chloe-attrs-only r> add-tag-attrs ]
|
||||
[ >r tag-attrs non-chloe-attrs-only r> "button" tag-named add-tag-attrs ]
|
||||
[ >r children>string 1array r> "button" tag-named set-tag-children ]
|
||||
[ [ tag-attrs chloe-attrs-only ] dip add-tag-attrs ]
|
||||
[ [ tag-attrs non-chloe-attrs-only ] dip "button" tag-named add-tag-attrs ]
|
||||
[ [ children>string 1array ] dip "button" tag-named set-tag-children ]
|
||||
[ nip ]
|
||||
} 2cleave process-chloe-tag ;
|
||||
|
||||
|
|
@ -208,30 +196,109 @@ STRING: button-tag-markup
|
|||
: if-tag ( tag -- )
|
||||
dup if-satisfied? [ process-tag-children ] [ drop ] if ;
|
||||
|
||||
: even-tag ( tag -- )
|
||||
"index" value even? [ process-tag-children ] [ drop ] if ;
|
||||
|
||||
: odd-tag ( tag -- )
|
||||
"index" value odd? [ process-tag-children ] [ drop ] if ;
|
||||
|
||||
: (each-tag) ( tag quot -- )
|
||||
[
|
||||
[ "values" required-attr value ] keep
|
||||
'[ , process-tag-children ]
|
||||
] dip call ; inline
|
||||
|
||||
: each-tag ( tag -- )
|
||||
[ with-each-value ] (each-tag) ;
|
||||
|
||||
: each-tuple-tag ( tag -- )
|
||||
[ with-each-tuple ] (each-tag) ;
|
||||
|
||||
: each-assoc-tag ( tag -- )
|
||||
[ with-each-assoc ] (each-tag) ;
|
||||
|
||||
: (bind-tag) ( tag quot -- )
|
||||
[
|
||||
[ "name" required-attr value ] keep
|
||||
'[ , process-tag-children ]
|
||||
] dip call ; inline
|
||||
|
||||
: bind-tuple-tag ( tag -- )
|
||||
[ with-tuple-values ] (bind-tag) ;
|
||||
|
||||
: bind-assoc-tag ( tag -- )
|
||||
[ with-assoc-values ] (bind-tag) ;
|
||||
|
||||
: error-message-tag ( tag -- )
|
||||
children>string render-error ;
|
||||
|
||||
: validation-messages-tag ( tag -- )
|
||||
drop render-validation-messages ;
|
||||
|
||||
: singleton-component-tag ( tag class -- )
|
||||
[ "name" required-attr ] dip render ;
|
||||
|
||||
: attrs>slots ( tag tuple -- )
|
||||
[ attrs>> ] [ <mirror> ] bi*
|
||||
'[
|
||||
swap tag>> dup "name" =
|
||||
[ 2drop ] [ , set-at ] if
|
||||
] assoc-each ;
|
||||
|
||||
: tuple-component-tag ( tag class -- )
|
||||
[ drop "name" required-attr ]
|
||||
[ new [ attrs>slots ] keep ]
|
||||
2bi render ;
|
||||
|
||||
: process-chloe-tag ( tag -- )
|
||||
dup name-tag {
|
||||
{ "chloe" [ [ process-template ] each ] }
|
||||
{ "chloe" [ process-tag-children ] }
|
||||
|
||||
! HTML head
|
||||
{ "title" [ title-tag ] }
|
||||
{ "write-title" [ write-title-tag ] }
|
||||
{ "style" [ style-tag ] }
|
||||
{ "write-style" [ write-style-tag ] }
|
||||
{ "atom" [ atom-tag ] }
|
||||
{ "write-atom" [ write-atom-tag ] }
|
||||
{ "view" [ view-tag ] }
|
||||
{ "edit" [ edit-tag ] }
|
||||
{ "summary" [ summary-tag ] }
|
||||
|
||||
! HTML elements
|
||||
{ "a" [ a-tag ] }
|
||||
{ "form" [ form-tag ] }
|
||||
{ "button" [ button-tag ] }
|
||||
|
||||
! Components
|
||||
{ "label" [ label singleton-component-tag ] }
|
||||
{ "link" [ link singleton-component-tag ] }
|
||||
{ "code" [ code tuple-component-tag ] }
|
||||
{ "farkup" [ farkup singleton-component-tag ] }
|
||||
{ "inspector" [ inspector singleton-component-tag ] }
|
||||
{ "comparison" [ comparison singleton-component-tag ] }
|
||||
{ "html" [ html singleton-component-tag ] }
|
||||
|
||||
! Forms
|
||||
{ "form" [ form-tag ] }
|
||||
{ "error-message" [ error-message-tag ] }
|
||||
{ "validation-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 ] }
|
||||
{ "even" [ even-tag ] }
|
||||
{ "odd" [ odd-tag ] }
|
||||
{ "each" [ each-tag ] }
|
||||
{ "each-assoc" [ each-assoc-tag ] }
|
||||
{ "each-tuple" [ each-tuple-tag ] }
|
||||
{ "bind-assoc" [ bind-assoc-tag ] }
|
||||
{ "bind-tuple" [ bind-tuple-tag ] }
|
||||
{ "comment" [ drop ] }
|
||||
{ "call-next-template" [ drop call-next-template ] }
|
||||
[ "Unknown chloe tag: " swap append throw ]
|
||||
|
||||
[ "Unknown chloe tag: " prepend throw ]
|
||||
} case ;
|
||||
|
||||
: 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:if t:code="http.server.templating.chloe.tests:test4-aux?">
|
||||
<t:if t:code="html.templates.chloe.tests:test4-aux?">
|
||||
True
|
||||
</t:if>
|
||||
|
||||
|
|
@ -2,7 +2,7 @@
|
|||
|
||||
<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
|
||||
</t:if>
|
||||
|
||||
|
|
@ -2,7 +2,7 @@
|
|||
|
||||
<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
|
||||
</t:if>
|
||||
|
||||
|
|
@ -2,7 +2,7 @@
|
|||
|
||||
<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
|
||||
</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
|
||||
http.server.templating http.server.templating.fhtml kernel
|
||||
html.templates html.templates.fhtml kernel
|
||||
tools.test sequences parser ;
|
||||
IN: http.server.templating.fhtml.tests
|
||||
IN: html.templates.fhtml.tests
|
||||
|
||||
: test-template ( path -- ? )
|
||||
"resource:extra/http/server/templating/fhtml/test/"
|
||||
"resource:extra/html/templates/fhtml/test/"
|
||||
prepend
|
||||
[
|
||||
".fhtml" append <fhtml> [ call-template ] with-string-writer
|
||||
|
|
@ -4,12 +4,10 @@
|
|||
USING: continuations sequences kernel namespaces debugger
|
||||
combinators math quotations generic strings splitting
|
||||
accessors assocs fry
|
||||
parser io io.files io.streams.string io.encodings.utf8 source-files
|
||||
html html.elements
|
||||
http.server.static http.server http.server.templating ;
|
||||
IN: http.server.templating.fhtml
|
||||
|
||||
: templating-vocab ( -- vocab-name ) "http.server.templating.fhtml" ;
|
||||
parser io io.files io.streams.string io.encodings.utf8
|
||||
html.elements
|
||||
html.templates ;
|
||||
IN: html.templates.fhtml
|
||||
|
||||
! We use a custom lexer so that %> ends a token even if not
|
||||
! followed by whitespace
|
||||
|
|
@ -35,7 +33,7 @@ DEFER: <% delimiter
|
|||
: found-<% ( accum lexer col -- accum )
|
||||
[
|
||||
over line-text>>
|
||||
>r >r column>> r> r> subseq parsed
|
||||
[ column>> ] 2dip subseq parsed
|
||||
\ write-html parsed
|
||||
] 2keep 2 + >>column drop ;
|
||||
|
||||
|
|
@ -62,37 +60,20 @@ DEFER: <% delimiter
|
|||
|
||||
: parse-template ( string -- quot )
|
||||
[
|
||||
use [ clone ] change
|
||||
templating-vocab use+
|
||||
"quiet" on
|
||||
parser-notes off
|
||||
"html.templates.fhtml" use+
|
||||
string-lines parse-template-lines
|
||||
] with-scope ;
|
||||
] with-file-vocabs ;
|
||||
|
||||
: eval-template ( string -- ) parse-template call ;
|
||||
|
||||
: html-error. ( error -- )
|
||||
<pre> error. </pre> ;
|
||||
: eval-template ( string -- )
|
||||
parse-template call ;
|
||||
|
||||
TUPLE: fhtml path ;
|
||||
|
||||
C: <fhtml> fhtml
|
||||
|
||||
M: fhtml call-template* ( filename -- )
|
||||
'[
|
||||
, path>> [
|
||||
"quiet" on
|
||||
parser-notes off
|
||||
templating-vocab use+
|
||||
! so that reload works properly
|
||||
dup source-file file set
|
||||
utf8 file-contents
|
||||
[ eval-template ] [ html-error. drop ] recover
|
||||
] with-file-vocabs
|
||||
] assert-depth ;
|
||||
|
||||
! file responder integration
|
||||
: enable-fhtml ( responder -- responder )
|
||||
[ <fhtml> serve-template ]
|
||||
"application/x-factor-server-page"
|
||||
pick special>> set-at ;
|
||||
'[ , path>> utf8 file-contents eval-template ] assert-depth ;
|
||||
|
||||
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 -- )
|
||||
#! Downloads the contents of a URL to a file.
|
||||
>r http-get r> latin1 [ write ] with-file-writer ;
|
||||
[ http-get ] dip latin1 [ write ] with-file-writer ;
|
||||
|
||||
: download ( url -- )
|
||||
dup download-name download-to ;
|
||||
|
|
|
|||
|
|
@ -237,7 +237,7 @@ test-db [
|
|||
[ ] [
|
||||
[
|
||||
<dispatcher>
|
||||
<action> [ "text/plain" <content> [ "Hi" write ] >>body ] >>display
|
||||
<action> [ [ "Hi" write ] <text-content> ] >>display
|
||||
<login>
|
||||
<sessions>
|
||||
"" add-responder
|
||||
|
|
|
|||
|
|
@ -9,7 +9,9 @@ math.parser calendar calendar.format
|
|||
io io.streams.string io.encodings.utf8 io.encodings.string
|
||||
io.sockets io.sockets.secure
|
||||
|
||||
unicode.case unicode.categories qualified ;
|
||||
unicode.case unicode.categories qualified
|
||||
|
||||
html.templates ;
|
||||
|
||||
EXCLUDE: fry => , ;
|
||||
|
||||
|
|
@ -65,14 +67,14 @@ M: https protocol>string drop "https" ;
|
|||
2dup length 2 - >= [
|
||||
2drop
|
||||
] [
|
||||
>r 1+ dup 2 + r> subseq hex> [ , ] when*
|
||||
[ 1+ dup 2 + ] dip subseq hex> [ , ] when*
|
||||
] if ;
|
||||
|
||||
: url-decode-% ( index str -- index str )
|
||||
2dup url-decode-hex >r 3 + r> ;
|
||||
2dup url-decode-hex [ 3 + ] dip ;
|
||||
|
||||
: url-decode-+-or-other ( index str ch -- index str )
|
||||
dup CHAR: + = [ drop CHAR: \s ] when , >r 1+ r> ;
|
||||
dup CHAR: + = [ drop CHAR: \s ] when , [ 1+ ] dip ;
|
||||
|
||||
: url-decode-iter ( index str -- )
|
||||
2dup length >= [
|
||||
|
|
@ -158,7 +160,7 @@ M: https protocol>string drop "https" ;
|
|||
dup [
|
||||
"&" split H{ } clone [
|
||||
[
|
||||
>r "=" split1 [ dup [ url-decode ] when ] bi@ swap r>
|
||||
[ "=" split1 [ dup [ url-decode ] when ] bi@ swap ] dip
|
||||
add-query-param
|
||||
] curry each
|
||||
] keep
|
||||
|
|
@ -174,7 +176,7 @@ M: https protocol>string drop "https" ;
|
|||
] assoc-map
|
||||
[
|
||||
[
|
||||
>r url-encode r>
|
||||
[ url-encode ] dip
|
||||
[ url-encode "=" swap 3append , ] with each
|
||||
] assoc-each
|
||||
] { } make "&" join ;
|
||||
|
|
@ -342,7 +344,7 @@ SYMBOL: max-post-request
|
|||
dup "cookie" header [ parse-cookies >>cookies ] when* ;
|
||||
|
||||
: parse-content-type-attributes ( string -- attributes )
|
||||
" " split harvest [ "=" split1 >r >lower r> ] { } map>assoc ;
|
||||
" " split harvest [ "=" split1 [ >lower ] dip ] { } map>assoc ;
|
||||
|
||||
: parse-content-type ( content-type -- type encoding )
|
||||
";" split1 parse-content-type-attributes "charset" swap at ;
|
||||
|
|
@ -521,18 +523,8 @@ body ;
|
|||
over unparse-content-type "content-type" pick set-at
|
||||
write-header ;
|
||||
|
||||
GENERIC: write-response-body* ( body -- )
|
||||
|
||||
M: f write-response-body* drop ;
|
||||
|
||||
M: string write-response-body* write ;
|
||||
|
||||
M: callable write-response-body* call ;
|
||||
|
||||
M: object write-response-body* output-stream get stream-copy ;
|
||||
|
||||
: write-response-body ( response -- response )
|
||||
dup body>> write-response-body* ;
|
||||
dup body>> call-template ;
|
||||
|
||||
M: response write-response ( respose -- )
|
||||
write-response-version
|
||||
|
|
@ -547,10 +539,10 @@ M: response write-full-response ( request response -- )
|
|||
swap method>> "HEAD" = [ write-response-body ] unless ;
|
||||
|
||||
: get-cookie ( request/response name -- cookie/f )
|
||||
>r cookies>> r> '[ , _ name>> = ] find nip ;
|
||||
[ cookies>> ] dip '[ , _ name>> = ] find nip ;
|
||||
|
||||
: delete-cookie ( request/response name -- )
|
||||
over cookies>> >r get-cookie r> delete ;
|
||||
over cookies>> [ get-cookie ] dip delete ;
|
||||
|
||||
: put-cookie ( request/response cookie -- request/response )
|
||||
[ name>> dupd get-cookie [ dupd delete-cookie ] when* ] keep
|
||||
|
|
|
|||
|
|
@ -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
|
||||
io.streams.string http.server sequences splitting accessors ;
|
||||
IN: http.server.actions.tests
|
||||
|
||||
[
|
||||
"a" [ v-number ] { { "a" "123" } } validate-param
|
||||
[ 123 ] [ "a" get ] unit-test
|
||||
] with-scope
|
||||
|
||||
<action>
|
||||
[ "a" get "b" get + ] >>display
|
||||
{ { "a" [ v-number ] } { "b" [ v-number ] } } >>get-params
|
||||
[ "a" param "b" param [ string>number ] bi@ + ] >>display
|
||||
"action-1" set
|
||||
|
||||
: lf>crlf "\n" split "\r\n" join ;
|
||||
|
|
|
|||
|
|
@ -1,68 +1,94 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors sequences kernel assocs combinators
|
||||
http.server http.server.validators http hashtables namespaces
|
||||
fry continuations locals boxes xml.entities html.elements io ;
|
||||
USING: accessors sequences kernel assocs combinators http.server
|
||||
validators http hashtables namespaces fry continuations locals
|
||||
boxes xml.entities html.elements html.components io arrays math ;
|
||||
IN: http.server.actions
|
||||
|
||||
SYMBOL: params
|
||||
|
||||
SYMBOL: validation-message
|
||||
SYMBOL: rest-param
|
||||
|
||||
: render-validation-message ( -- )
|
||||
validation-message get value>> [
|
||||
<span "error" =class span>
|
||||
escape-string write
|
||||
</span>
|
||||
] when* ;
|
||||
|
||||
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
|
||||
: render-validation-messages ( -- )
|
||||
validation-messages get
|
||||
dup empty? [ drop ] [
|
||||
<ul "errors" =class ul>
|
||||
[ <li> message>> escape-string write </li> ] each
|
||||
</ul>
|
||||
] if ;
|
||||
|
||||
: handle-post ( -- response )
|
||||
action get post-params>> action-params
|
||||
[ <400> ] [ action get submit>> call ] if ;
|
||||
TUPLE: action rest-param init display validate submit ;
|
||||
|
||||
: 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 ( -- * )
|
||||
action get display>> call exit-with ;
|
||||
request get method>> "POST" =
|
||||
[ action get display>> call ] [ <400> ] if exit-with ;
|
||||
|
||||
: validation-failed-with ( string -- * )
|
||||
validation-message get >box
|
||||
validation-failed ;
|
||||
: handle-post ( action -- response )
|
||||
init-validation
|
||||
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 )
|
||||
dup action set
|
||||
'[
|
||||
, [ CHAR: / = ] right-trim empty? [
|
||||
, action set
|
||||
request get
|
||||
<box> validation-message set
|
||||
[ request-params params set ]
|
||||
[
|
||||
method>> {
|
||||
{ "GET" [ handle-get ] }
|
||||
{ "HEAD" [ handle-get ] }
|
||||
{ "POST" [ handle-post ] }
|
||||
} case
|
||||
] bi
|
||||
] [
|
||||
<404>
|
||||
] if
|
||||
, dup empty? [ drop ] [ handle-rest-param ] if
|
||||
|
||||
init-validation
|
||||
,
|
||||
request get
|
||||
[ request-params rest-param get assoc-union params set ]
|
||||
[ method>> ] bi
|
||||
{
|
||||
{ "GET" [ handle-get ] }
|
||||
{ "HEAD" [ handle-get ] }
|
||||
{ "POST" [ handle-post ] }
|
||||
} case
|
||||
] 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
|
||||
! 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.sessions
|
||||
http.server.auth.providers ;
|
||||
|
|
@ -38,4 +38,4 @@ SYMBOL: capabilities
|
|||
|
||||
V{ } clone capabilities set-global
|
||||
|
||||
: define-capability ( word -- ) capabilities get push-new ;
|
||||
: define-capability ( word -- ) capabilities get adjoin ;
|
||||
|
|
|
|||
|
|
@ -10,12 +10,12 @@
|
|||
|
||||
<tr>
|
||||
<th class="field-label">User name:</th>
|
||||
<td><t:view t:component="username" /></td>
|
||||
<td><t:label t:name="username" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
<th class="field-label">Real name:</th>
|
||||
<td><t:edit t:component="realname" /></td>
|
||||
<td><t:field t:name="realname" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
|
|
@ -25,7 +25,7 @@
|
|||
|
||||
<tr>
|
||||
<th class="field-label">Current password:</th>
|
||||
<td><t:edit t:component="password" /></td>
|
||||
<td><t:password t:name="password" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
|
|
@ -35,12 +35,12 @@
|
|||
|
||||
<tr>
|
||||
<th class="field-label">New password:</th>
|
||||
<td><t:edit t:component="new-password" /></td>
|
||||
<td><t:password t:name="new-password" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
<th class="field-label">Verify:</th>
|
||||
<td><t:edit t:component="verify-password" /></td>
|
||||
<td><t:password t:name="verify-password" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
|
|
@ -50,7 +50,7 @@
|
|||
|
||||
<tr>
|
||||
<th class="field-label">E-mail:</th>
|
||||
<td><t:edit t:component="email" /></td>
|
||||
<td><t:field t:name="email" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
|
|
@ -62,7 +62,7 @@
|
|||
|
||||
<p>
|
||||
<input type="submit" value="Update" />
|
||||
<t:validation-message />
|
||||
<t:validation-messages />
|
||||
</p>
|
||||
|
||||
</t:form>
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors quotations assocs kernel splitting
|
||||
combinators sequences namespaces hashtables sets
|
||||
fry arrays threads locals qualified random
|
||||
fry arrays threads qualified random validators
|
||||
io
|
||||
io.sockets
|
||||
io.encodings.utf8
|
||||
|
|
@ -12,23 +12,22 @@ continuations
|
|||
destructors
|
||||
checksums
|
||||
checksums.sha2
|
||||
validators
|
||||
html.components
|
||||
html.elements
|
||||
html.templates
|
||||
html.templates.chloe
|
||||
http
|
||||
http.server
|
||||
http.server.auth
|
||||
http.server.auth.providers
|
||||
http.server.auth.providers.db
|
||||
http.server.actions
|
||||
http.server.components
|
||||
http.server.flows
|
||||
http.server.forms
|
||||
http.server.sessions
|
||||
http.server.boilerplate
|
||||
http.server.templating
|
||||
http.server.templating.chloe
|
||||
http.server.validators ;
|
||||
IN: http.server.auth.login
|
||||
http.server.boilerplate ;
|
||||
QUALIFIED: smtp
|
||||
IN: http.server.auth.login
|
||||
|
||||
TUPLE: login < dispatcher users checksum ;
|
||||
|
||||
|
|
@ -65,149 +64,122 @@ M: user-saver dispose
|
|||
3append <chloe> ;
|
||||
|
||||
! ! ! 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 )
|
||||
username>> set-uid
|
||||
"$login" end-flow ;
|
||||
username>> set-uid "$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 )
|
||||
[let | form [ <login-form> ] |
|
||||
<action>
|
||||
[ blank-values ] >>init
|
||||
: <login-action> ( -- action )
|
||||
<action>
|
||||
[ "login" login-template <html-content> ] >>display
|
||||
|
||||
[ form edit-form ] >>display
|
||||
[
|
||||
{
|
||||
{ "username" [ v-required ] }
|
||||
{ "password" [ v-required ] }
|
||||
} validate-params
|
||||
|
||||
[
|
||||
blank-values
|
||||
|
||||
form validate-form
|
||||
|
||||
"password" value "username" value check-login
|
||||
[ successful-login ] [ login-failed ] if*
|
||||
] >>submit
|
||||
] ;
|
||||
"password" value
|
||||
"username" value check-login
|
||||
[ successful-login ] [ login-failed ] if*
|
||||
] >>submit ;
|
||||
|
||||
! ! ! New user registration
|
||||
|
||||
: <register-form> ( -- form )
|
||||
"register" <form>
|
||||
"register" login-template >>edit-template
|
||||
"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 ;
|
||||
: user-exists ( -- * )
|
||||
"username taken" validation-error
|
||||
validation-failed ;
|
||||
|
||||
: password-mismatch "passwords do not match" validation-failed-with ;
|
||||
|
||||
: user-exists "username taken" validation-failed-with ;
|
||||
: password-mismatch ( -- * )
|
||||
"passwords do not match" validation-error
|
||||
validation-failed ;
|
||||
|
||||
: same-password-twice ( -- )
|
||||
"new-password" value "verify-password" value =
|
||||
[ password-mismatch ] unless ;
|
||||
|
||||
:: <register-action> ( -- action )
|
||||
[let | form [ <register-form> ] |
|
||||
<action>
|
||||
[ blank-values ] >>init
|
||||
: <register-action> ( -- action )
|
||||
<page-action>
|
||||
"register" login-template >>template
|
||||
|
||||
[ form edit-form ] >>display
|
||||
[
|
||||
{
|
||||
{ "username" [ v-username ] }
|
||||
{ "realname" [ [ v-one-line ] v-optional ] }
|
||||
{ "new-password" [ v-password ] }
|
||||
{ "verify-password" [ v-password ] }
|
||||
{ "email" [ [ v-email ] v-optional ] }
|
||||
{ "captcha" [ v-captcha ] }
|
||||
} validate-params
|
||||
|
||||
[
|
||||
blank-values
|
||||
same-password-twice
|
||||
] >>validate
|
||||
|
||||
form validate-form
|
||||
[
|
||||
"username" value <user>
|
||||
"realname" value >>realname
|
||||
"new-password" value >>encoded-password
|
||||
"email" value >>email
|
||||
H{ } clone >>profile
|
||||
|
||||
same-password-twice
|
||||
users new-user [ user-exists ] unless*
|
||||
|
||||
"username" value <user>
|
||||
"realname" value >>realname
|
||||
"new-password" value >>encoded-password
|
||||
"email" value >>email
|
||||
H{ } clone >>profile
|
||||
login get init-user-profile
|
||||
|
||||
users new-user [ user-exists ] unless*
|
||||
|
||||
successful-login
|
||||
|
||||
login get init-user-profile
|
||||
] >>submit
|
||||
] ;
|
||||
successful-login
|
||||
] >>submit ;
|
||||
|
||||
! ! ! Editing user profile
|
||||
|
||||
: <edit-profile-form> ( -- form )
|
||||
"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 )
|
||||
<action>
|
||||
[
|
||||
logged-in-user get
|
||||
[ username>> "username" set-value ]
|
||||
[ realname>> "realname" set-value ]
|
||||
[ email>> "email" set-value ]
|
||||
tri
|
||||
] >>init
|
||||
|
||||
:: <edit-profile-action> ( -- action )
|
||||
[let | form [ <edit-profile-form> ] |
|
||||
<action>
|
||||
[
|
||||
blank-values
|
||||
[ "edit-profile" login-template <html-content> ] >>display
|
||||
|
||||
logged-in-user get
|
||||
[ username>> "username" set-value ]
|
||||
[ realname>> "realname" set-value ]
|
||||
[ email>> "email" set-value ]
|
||||
tri
|
||||
] >>init
|
||||
[
|
||||
uid "username" set-value
|
||||
|
||||
[ form edit-form ] >>display
|
||||
{
|
||||
{ "realname" [ [ v-one-line ] v-optional ] }
|
||||
{ "password" [ ] }
|
||||
{ "new-password" [ [ v-password ] v-optional ] }
|
||||
{ "verify-password" [ [ v-password ] v-optional ] }
|
||||
{ "email" [ [ v-email ] v-optional ] }
|
||||
} validate-params
|
||||
|
||||
[
|
||||
blank-values
|
||||
uid "username" set-value
|
||||
{ "password" "new-password" "verify-password" }
|
||||
[ value empty? not ] contains? [
|
||||
"password" value uid check-login
|
||||
[ "incorrect password" validation-error ] unless
|
||||
|
||||
form validate-form
|
||||
same-password-twice
|
||||
] when
|
||||
] >>validate
|
||||
|
||||
logged-in-user get
|
||||
[
|
||||
logged-in-user get
|
||||
|
||||
{ "password" "new-password" "verify-password" }
|
||||
[ value empty? ] all? [
|
||||
same-password-twice
|
||||
"new-password" value dup empty?
|
||||
[ drop ] [ >>encoded-password ] if
|
||||
|
||||
"password" value uid check-login
|
||||
[ login-failed ] unless
|
||||
"realname" value >>realname
|
||||
"email" value >>email
|
||||
|
||||
"new-password" value >>encoded-password
|
||||
] unless
|
||||
t >>changed?
|
||||
|
||||
"realname" value >>realname
|
||||
"email" value >>email
|
||||
drop
|
||||
|
||||
t >>changed?
|
||||
|
||||
drop
|
||||
|
||||
"$login" end-flow
|
||||
] >>submit
|
||||
] ;
|
||||
"$login" end-flow
|
||||
] >>submit ;
|
||||
|
||||
! ! ! Password recovery
|
||||
|
||||
|
|
@ -250,92 +222,61 @@ SYMBOL: lost-password-from
|
|||
'[ , password-email smtp:send-email ]
|
||||
"E-mail send thread" spawn drop ;
|
||||
|
||||
: <recover-form-1> ( -- form )
|
||||
"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 )
|
||||
<action>
|
||||
[ "recover-1" login-template <html-content> ] >>display
|
||||
|
||||
:: <recover-action-1> ( -- action )
|
||||
[let | form [ <recover-form-1> ] |
|
||||
<action>
|
||||
[ blank-values ] >>init
|
||||
[
|
||||
{
|
||||
{ "username" [ v-username ] }
|
||||
{ "email" [ v-email ] }
|
||||
{ "captcha" [ v-captcha ] }
|
||||
} validate-params
|
||||
] >>validate
|
||||
|
||||
[ form edit-form ] >>display
|
||||
[
|
||||
"email" value "username" value
|
||||
users issue-ticket [
|
||||
send-password-email
|
||||
] when*
|
||||
|
||||
[
|
||||
blank-values
|
||||
"recover-2" login-template <html-content>
|
||||
] >>submit ;
|
||||
|
||||
form validate-form
|
||||
|
||||
"email" value "username" value
|
||||
users issue-ticket [
|
||||
send-password-email
|
||||
] when*
|
||||
|
||||
"recover-2" login-template serve-template
|
||||
] >>submit
|
||||
] ;
|
||||
|
||||
: <recover-form-3>
|
||||
"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>
|
||||
[
|
||||
{ "username" [ v-required ] }
|
||||
: <recover-action-3> ( -- action )
|
||||
<action>
|
||||
[
|
||||
{
|
||||
{ "username" [ v-username ] }
|
||||
{ "ticket" [ v-required ] }
|
||||
] >>get-params
|
||||
} validate-params
|
||||
] >>init
|
||||
|
||||
[
|
||||
[
|
||||
"username" [ get ] keep set
|
||||
"ticket" [ get ] keep set
|
||||
] H{ } make-assoc values set
|
||||
] >>init
|
||||
[ "recover-3" login-template <html-content> ] >>display
|
||||
|
||||
[ <recover-form-3> edit-form ] >>display
|
||||
[
|
||||
{
|
||||
{ "username" [ v-username ] }
|
||||
{ "ticket" [ v-required ] }
|
||||
{ "new-password" [ v-password ] }
|
||||
{ "verify-password" [ v-password ] }
|
||||
} validate-params
|
||||
|
||||
[
|
||||
blank-values
|
||||
same-password-twice
|
||||
] >>validate
|
||||
|
||||
form validate-form
|
||||
[
|
||||
"ticket" value
|
||||
"username" value
|
||||
users claim-ticket [
|
||||
"new-password" value >>encoded-password
|
||||
users update-user
|
||||
|
||||
same-password-twice
|
||||
|
||||
"ticket" value
|
||||
"username" value
|
||||
users claim-ticket [
|
||||
"new-password" value >>encoded-password
|
||||
users update-user
|
||||
|
||||
"recover-4" login-template serve-template
|
||||
] [
|
||||
<400>
|
||||
] if*
|
||||
] >>submit
|
||||
] ;
|
||||
"recover-4" login-template <html-content>
|
||||
] [
|
||||
<400>
|
||||
] if*
|
||||
] >>submit ;
|
||||
|
||||
! ! ! Logout
|
||||
: <logout-action> ( -- action )
|
||||
|
|
|
|||
|
|
@ -10,12 +10,12 @@
|
|||
|
||||
<tr>
|
||||
<th class="field-label">User name:</th>
|
||||
<td><t:edit t:component="username" /></td>
|
||||
<td><t:field t:name="username" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
<th class="field-label">Password:</th>
|
||||
<td><t:edit t:component="password" /></td>
|
||||
<td><t:password t:name="password" /></td>
|
||||
</tr>
|
||||
|
||||
</table>
|
||||
|
|
@ -23,7 +23,7 @@
|
|||
<p>
|
||||
|
||||
<input type="submit" value="Log in" />
|
||||
<t:validation-message />
|
||||
<t:validation-messages />
|
||||
|
||||
</p>
|
||||
|
||||
|
|
|
|||
|
|
@ -10,25 +10,25 @@
|
|||
|
||||
<table>
|
||||
|
||||
<tr>
|
||||
<th class="field-label">User name:</th>
|
||||
<td><t:edit t:component="username" /></td>
|
||||
</tr>
|
||||
<tr>
|
||||
<th class="field-label">User name:</th>
|
||||
<td><t:field t:name="username" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
<th class="field-label">E-mail:</th>
|
||||
<td><t:edit t:component="email" /></td>
|
||||
</tr>
|
||||
<tr>
|
||||
<th class="field-label">E-mail:</th>
|
||||
<td><t:field t:name="email" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
<th class="field-label">Captcha:</th>
|
||||
<td><t:edit t:component="captcha" /></td>
|
||||
</tr>
|
||||
<tr>
|
||||
<th class="field-label">Captcha:</th>
|
||||
<td><t:field t:name="captcha" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
<td></td>
|
||||
<td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to e-mail you will be blocked.</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td></td>
|
||||
<td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to e-mail you will be blocked.</td>
|
||||
</tr>
|
||||
|
||||
</table>
|
||||
|
||||
|
|
|
|||
|
|
@ -10,29 +10,29 @@
|
|||
|
||||
<table>
|
||||
|
||||
<t:edit t:component="username" />
|
||||
<t:edit t:component="ticket" />
|
||||
<t:hidden t:name="username" />
|
||||
<t:hidden t:name="ticket" />
|
||||
|
||||
<tr>
|
||||
<th class="field-label">Password:</th>
|
||||
<td><t:edit t:component="new-password" /></td>
|
||||
<th class="field-label">Password:</th>
|
||||
<td><t:password t:name="new-password" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
<th class="field-label">Verify password:</th>
|
||||
<td><t:edit t:component="verify-password" /></td>
|
||||
<th class="field-label">Verify password:</th>
|
||||
<td><t:password t:name="verify-password" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
<td></td>
|
||||
<td>Enter your password twice to ensure it is correct.</td>
|
||||
<td></td>
|
||||
<td>Enter your password twice to ensure it is correct.</td>
|
||||
</tr>
|
||||
|
||||
</table>
|
||||
|
||||
<p>
|
||||
<input type="submit" value="Set password" />
|
||||
<t:validation-message />
|
||||
<t:validation-messages />
|
||||
</p>
|
||||
|
||||
</t:form>
|
||||
|
|
|
|||
|
|
@ -8,62 +8,62 @@
|
|||
|
||||
<table>
|
||||
|
||||
<tr>
|
||||
<th class="field-label">User name:</th>
|
||||
<td><t:edit t:component="username" /></td>
|
||||
</tr>
|
||||
<tr>
|
||||
<th class="field-label">User name:</th>
|
||||
<td><t:field t:name="username" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
<th class="field-label">Real name:</th>
|
||||
<td><t:edit t:component="realname" /></td>
|
||||
</tr>
|
||||
<tr>
|
||||
<th class="field-label">Real name:</th>
|
||||
<td><t:field t:name="realname" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
<td></td>
|
||||
<td>Specifying a real name is optional.</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td></td>
|
||||
<td>Specifying a real name is optional.</td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
<th class="field-label">Password:</th>
|
||||
<td><t:edit t:component="new-password" /></td>
|
||||
</tr>
|
||||
<tr>
|
||||
<th class="field-label">Password:</th>
|
||||
<td><t:password t:name="new-password" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
<th class="field-label">Verify:</th>
|
||||
<td><t:edit t:component="verify-password" /></td>
|
||||
</tr>
|
||||
<tr>
|
||||
<th class="field-label">Verify:</th>
|
||||
<td><t:password t:name="verify-password" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
<td></td>
|
||||
<td>Enter your password twice to ensure it is correct.</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td></td>
|
||||
<td>Enter your password twice to ensure it is correct.</td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
<th class="field-label">E-mail:</th>
|
||||
<td><t:edit t:component="email" /></td>
|
||||
</tr>
|
||||
<tr>
|
||||
<th class="field-label">E-mail:</th>
|
||||
<td><t:field t:name="email" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
<td></td>
|
||||
<td>Specifying an e-mail address is optional. It enables the "recover password" feature.</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td></td>
|
||||
<td>Specifying an e-mail address is optional. It enables the "recover password" feature.</td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
<th class="field-label">Captcha:</th>
|
||||
<td><t:edit t:component="captcha" /></td>
|
||||
</tr>
|
||||
<tr>
|
||||
<th class="field-label">Captcha:</th>
|
||||
<td><t:field t:name="captcha" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
<td></td>
|
||||
<td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td></td>
|
||||
<td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.</td>
|
||||
</tr>
|
||||
|
||||
</table>
|
||||
|
||||
<p>
|
||||
|
||||
<input type="submit" value="Register" />
|
||||
<t:validation-message />
|
||||
<t:validation-messages />
|
||||
|
||||
</p>
|
||||
|
||||
|
|
|
|||
|
|
@ -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 new-user ( user provider -- user/f )
|
||||
>r dup username>> r> assoc>>
|
||||
2dup key? [ 3drop f ] [ pick >r set-at r> ] if ;
|
||||
[ dup username>> ] dip assoc>>
|
||||
2dup key? [ 3drop f ] [ pick [ set-at ] dip ] if ;
|
||||
|
|
|
|||
|
|
@ -1,73 +1,13 @@
|
|||
! Copyright (c) 2008 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel namespaces boxes sequences strings
|
||||
io io.streams.string arrays locals
|
||||
html.elements
|
||||
http
|
||||
http.server
|
||||
http.server.sessions
|
||||
http.server.templating ;
|
||||
USING: accessors kernel namespaces http.server html.templates
|
||||
locals ;
|
||||
IN: http.server.boilerplate
|
||||
|
||||
TUPLE: boilerplate < filter-responder template ;
|
||||
|
||||
: <boilerplate> f boilerplate boa ;
|
||||
|
||||
SYMBOL: title
|
||||
|
||||
: set-title ( string -- )
|
||||
title get >box ;
|
||||
|
||||
: write-title ( -- )
|
||||
title get value>> write ;
|
||||
|
||||
SYMBOL: style
|
||||
|
||||
: add-style ( string -- )
|
||||
"\n" style get push-all
|
||||
style get push-all ;
|
||||
|
||||
: write-style ( -- )
|
||||
style get >string write ;
|
||||
|
||||
SYMBOL: atom-feed
|
||||
|
||||
: set-atom-feed ( title url -- )
|
||||
2array atom-feed get >box ;
|
||||
|
||||
: write-atom-feed ( -- )
|
||||
atom-feed get value>> [
|
||||
<link "alternate" =rel "application/atom+xml" =type
|
||||
[ first =title ] [ second =href ] bi
|
||||
link/>
|
||||
] when* ;
|
||||
|
||||
SYMBOL: nested-template?
|
||||
|
||||
SYMBOL: next-template
|
||||
|
||||
: call-next-template ( -- )
|
||||
next-template get write-html ;
|
||||
|
||||
M: f call-template* drop call-next-template ;
|
||||
|
||||
: with-boilerplate ( body template -- )
|
||||
[
|
||||
title get [ <box> title set ] unless
|
||||
atom-feed get [ <box> atom-feed set ] unless
|
||||
style get [ SBUF" " clone style set ] unless
|
||||
|
||||
[
|
||||
[
|
||||
nested-template? on
|
||||
write-response-body*
|
||||
] with-string-writer
|
||||
next-template set
|
||||
]
|
||||
[ call-template ]
|
||||
bi*
|
||||
] with-scope ; inline
|
||||
|
||||
M:: boilerplate call-responder* ( path responder -- )
|
||||
path responder call-next-method
|
||||
dup content-type>> "text/html" = [
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2004 Chris Double.
|
||||
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||
! 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
|
||||
accessors arrays alarms quotations combinators fry assocs.lib ;
|
||||
IN: http.server.callbacks
|
||||
|
|
@ -90,7 +90,7 @@ SYMBOL: current-show
|
|||
[ restore-request store-current-show ] when* ;
|
||||
|
||||
: show-final ( quot -- * )
|
||||
>r redirect-to-here store-current-show r>
|
||||
[ redirect-to-here store-current-show ] dip
|
||||
call exit-with ; inline
|
||||
|
||||
: resuming-callback ( responder request -- id )
|
||||
|
|
@ -111,7 +111,7 @@ M: callback-responder call-responder* ( path responder -- response )
|
|||
] with-exit-continuation ;
|
||||
|
||||
: 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
|
||||
] 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