Merge branch 'master' of git://factorcode.org/git/factor

db4
Doug Coleman 2008-09-19 18:01:06 -05:00
commit 59d38f88be
9 changed files with 102 additions and 73 deletions

View File

@ -9,7 +9,7 @@ HELP: write-farkup
{ $values { "string" string } } { $values { "string" string } }
{ $description "Parse a Farkup string and writes the resulting HTML to " { $link output-stream } "." } ; { $description "Parse a Farkup string and writes the resulting HTML to " { $link output-stream } "." } ;
HELP: farkup ( string -- farkup ) HELP: parse-farkup ( string -- farkup )
{ $values { "string" string } { "farkup" "a Farkup syntax tree node" } } { $values { "string" string } { "farkup" "a Farkup syntax tree node" } }
{ $description "Parses Farkup and outputs a tree of " { $link "farkup-ast" } "." } ; { $description "Parses Farkup and outputs a tree of " { $link "farkup-ast" } "." } ;
@ -18,7 +18,7 @@ HELP: (write-farkup)
{ $description "Writes a Farkup syntax tree as HTML on " { $link output-stream } "." } ; { $description "Writes a Farkup syntax tree as HTML on " { $link output-stream } "." } ;
ARTICLE: "farkup-ast" "Farkup syntax tree nodes" ARTICLE: "farkup-ast" "Farkup syntax tree nodes"
"The " { $link farkup } " word outputs a tree of nodes corresponding to the Farkup syntax of the input string. This tree can be programatically traversed and mutated before being passed on to " { $link write-farkup } "." "The " { $link parse-farkup } " word outputs a tree of nodes corresponding to the Farkup syntax of the input string. This tree can be programatically traversed and mutated before being passed on to " { $link write-farkup } "."
{ $subsection heading1 } { $subsection heading1 }
{ $subsection heading2 } { $subsection heading2 }
{ $subsection heading3 } { $subsection heading3 }
@ -44,7 +44,7 @@ $nl
{ $subsection convert-farkup } { $subsection convert-farkup }
{ $subsection write-farkup } { $subsection write-farkup }
"The syntax tree of a piece of Farkup can also be inspected and modified:" "The syntax tree of a piece of Farkup can also be inspected and modified:"
{ $subsection farkup } { $subsection parse-farkup }
{ $subsection (write-farkup) } { $subsection (write-farkup) }
{ $subsection "farkup-ast" } ; { $subsection "farkup-ast" } ;

View File

@ -11,13 +11,11 @@ link-no-follow? off
[ "Baz" ] [ "Baz" simple-link-title ] unit-test [ "Baz" ] [ "Baz" simple-link-title ] unit-test
[ ] [ [ ] [
"abcd-*strong*\nasdifj\nweouh23ouh23" "abcd-*strong*\nasdifj\nweouh23ouh23" parse-farkup drop
"paragraph" \ farkup rule parse drop
] unit-test ] unit-test
[ ] [ [ ] [
"abcd-*strong*\nasdifj\nweouh23ouh23\n" "abcd-*strong*\nasdifj\nweouh23ouh23\n" parse-farkup drop
"paragraph" \ farkup rule parse drop
] unit-test ] unit-test
[ "<p>a-b</p>" ] [ "a-b" convert-farkup ] unit-test [ "<p>a-b</p>" ] [ "a-b" convert-farkup ] unit-test
@ -118,3 +116,7 @@ link-no-follow? off
] unit-test ] unit-test
[ "<p><a href='a'>a</a> <a href='b'>c</a></p>" ] [ "[[a]] [[b|c]]" convert-farkup ] unit-test [ "<p><a href='a'>a</a> <a href='b'>c</a></p>" ] [ "[[a]] [[b|c]]" convert-farkup ] unit-test
[ "<p><a href='C%2b%2b'>C++</a></p>" ] [ "[[C++]]" convert-farkup ] unit-test
[ "<p>&lt;foo&gt;</p>" ] [ "<foo>" convert-farkup ] unit-test

View File

@ -1,29 +1,29 @@
! Copyright (C) 2008 Doug Coleman. ! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays combinators html.elements io io.streams.string USING: accessors arrays combinators html.elements io
kernel math memoize namespaces peg peg.ebnf prettyprint io.streams.string kernel math memoize namespaces peg peg.ebnf
sequences sequences.deep strings xml.entities vectors splitting prettyprint sequences sequences.deep strings xml.entities
xmode.code2html ; vectors splitting xmode.code2html urls ;
IN: farkup IN: farkup
SYMBOL: relative-link-prefix SYMBOL: relative-link-prefix
SYMBOL: disable-images? SYMBOL: disable-images?
SYMBOL: link-no-follow? SYMBOL: link-no-follow?
TUPLE: heading1 obj ; TUPLE: heading1 child ;
TUPLE: heading2 obj ; TUPLE: heading2 child ;
TUPLE: heading3 obj ; TUPLE: heading3 child ;
TUPLE: heading4 obj ; TUPLE: heading4 child ;
TUPLE: strong obj ; TUPLE: strong child ;
TUPLE: emphasis obj ; TUPLE: emphasis child ;
TUPLE: superscript obj ; TUPLE: superscript child ;
TUPLE: subscript obj ; TUPLE: subscript child ;
TUPLE: inline-code obj ; TUPLE: inline-code child ;
TUPLE: paragraph obj ; TUPLE: paragraph child ;
TUPLE: list-item obj ; TUPLE: list-item child ;
TUPLE: list obj ; TUPLE: list child ;
TUPLE: table obj ; TUPLE: table child ;
TUPLE: table-row obj ; TUPLE: table-row child ;
TUPLE: link href text ; TUPLE: link href text ;
TUPLE: image href text ; TUPLE: image href text ;
TUPLE: code mode string ; TUPLE: code mode string ;
@ -34,7 +34,7 @@ TUPLE: code mode string ;
: simple-link-title ( string -- string' ) : simple-link-title ( string -- string' )
dup absolute-url? [ "/" last-split1 swap or ] unless ; dup absolute-url? [ "/" last-split1 swap or ] unless ;
EBNF: farkup EBNF: parse-farkup
nl = ("\r\n" | "\r" | "\n") => [[ drop "\n" ]] nl = ("\r\n" | "\r" | "\n") => [[ drop "\n" ]]
2nl = nl nl 2nl = nl nl
@ -65,7 +65,7 @@ subscript = "~" (!("~" | nl).)+ "~"
inline-code = "%" (!("%" | nl).)+ "%" inline-code = "%" (!("%" | nl).)+ "%"
=> [[ second >string inline-code boa ]] => [[ second >string inline-code boa ]]
escaped-char = "\" . => [[ second ]] escaped-char = "\" . => [[ second 1string ]]
link-content = (!("|"|"]").)+ link-content = (!("|"|"]").)+
@ -89,20 +89,26 @@ inline-tag = strong | emphasis | superscript | subscript | inline-code
inline-delimiter = '*' | '_' | '^' | '~' | '%' | '\' | '[' inline-delimiter = '*' | '_' | '^' | '~' | '%' | '\' | '['
table-column = (list | (!(nl | inline-delimiter | '|').)+ | inline-tag | inline-delimiter ) '|' cell = (!(inline-delimiter | '|' | nl).)+
=> [[ >string ]]
table-column = (list | cell | inline-tag | inline-delimiter ) '|'
=> [[ first ]] => [[ first ]]
table-row = "|" (table-column)+ table-row = "|" (table-column)+
=> [[ second table-row boa ]] => [[ second table-row boa ]]
table = ((table-row nl => [[ first ]] )+ table-row? | table-row) table = ((table-row nl => [[ first ]] )+ table-row? | table-row)
=> [[ table boa ]] => [[ table boa ]]
paragraph-item = ( table | (!(nl | code | heading | inline-delimiter | table ).) | inline-tag | inline-delimiter)+ text = (!(nl | code | heading | inline-delimiter | table ).)+
=> [[ >string ]]
paragraph-item = (table | text | inline-tag | inline-delimiter)+
paragraph = ((paragraph-item nl => [[ first ]])+ nl+ => [[ first ]] paragraph = ((paragraph-item nl => [[ first ]])+ nl+ => [[ first ]]
| (paragraph-item nl)+ paragraph-item? | (paragraph-item nl)+ paragraph-item?
| paragraph-item) | paragraph-item)
=> [[ paragraph boa ]] => [[ paragraph boa ]]
list-item = '-' ((!(inline-delimiter | nl).)+ | inline-tag)* list-item = '-' (cell | inline-tag)*
=> [[ second list-item boa ]] => [[ second list-item boa ]]
list = ((list-item nl)+ list-item? | list-item) list = ((list-item nl)+ list-item? | list-item)
=> [[ list boa ]] => [[ list boa ]]
@ -136,7 +142,7 @@ stand-alone
: write-link ( href text -- ) : write-link ( href text -- )
escape-link escape-link
[ <a =href link-no-follow? get [ "true" =nofollow ] when a> ] [ <a url-encode =href link-no-follow? get [ "true" =nofollow ] when a> ]
[ write </a> ] [ write </a> ]
bi* ; bi* ;
@ -146,7 +152,7 @@ stand-alone
<strong> "Images are not allowed" write </strong> <strong> "Images are not allowed" write </strong>
] [ ] [
escape-link escape-link
[ <img =src ] [ [ =alt ] unless-empty img/> ] bi* [ <img url-encode =src ] [ [ =alt ] unless-empty img/> ] bi*
] if ; ] if ;
: render-code ( string mode -- string' ) : render-code ( string mode -- string' )
@ -161,31 +167,30 @@ GENERIC: (write-farkup) ( farkup -- )
: <foo.> ( string -- ) <foo> write ; : <foo.> ( string -- ) <foo> write ;
: </foo.> ( string -- ) </foo> write ; : </foo.> ( string -- ) </foo> write ;
: in-tag. ( obj quot string -- ) [ <foo.> call ] keep </foo.> ; inline : in-tag. ( obj quot string -- ) [ <foo.> call ] keep </foo.> ; inline
M: heading1 (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "h1" in-tag. ; M: heading1 (write-farkup) [ child>> (write-farkup) ] "h1" in-tag. ;
M: heading2 (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "h2" in-tag. ; M: heading2 (write-farkup) [ child>> (write-farkup) ] "h2" in-tag. ;
M: heading3 (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "h3" in-tag. ; M: heading3 (write-farkup) [ child>> (write-farkup) ] "h3" in-tag. ;
M: heading4 (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "h4" in-tag. ; M: heading4 (write-farkup) [ child>> (write-farkup) ] "h4" in-tag. ;
M: strong (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "strong" in-tag. ; M: strong (write-farkup) [ child>> (write-farkup) ] "strong" in-tag. ;
M: emphasis (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "em" in-tag. ; M: emphasis (write-farkup) [ child>> (write-farkup) ] "em" in-tag. ;
M: superscript (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "sup" in-tag. ; M: superscript (write-farkup) [ child>> (write-farkup) ] "sup" in-tag. ;
M: subscript (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "sub" in-tag. ; M: subscript (write-farkup) [ child>> (write-farkup) ] "sub" in-tag. ;
M: inline-code (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "code" in-tag. ; M: inline-code (write-farkup) [ child>> (write-farkup) ] "code" in-tag. ;
M: list-item (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "li" in-tag. ; M: list-item (write-farkup) [ child>> (write-farkup) ] "li" in-tag. ;
M: list (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "ul" in-tag. ; M: list (write-farkup) [ child>> (write-farkup) ] "ul" in-tag. ;
M: paragraph (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "p" in-tag. ; M: paragraph (write-farkup) [ child>> (write-farkup) ] "p" in-tag. ;
M: link (write-farkup) ( obj -- ) [ href>> ] [ text>> ] bi write-link ; M: link (write-farkup) [ href>> ] [ text>> ] bi write-link ;
M: image (write-farkup) ( obj -- ) [ href>> ] [ text>> ] bi write-image-link ; M: image (write-farkup) [ href>> ] [ text>> ] bi write-image-link ;
M: code (write-farkup) ( obj -- ) [ string>> ] [ mode>> ] bi render-code ; M: code (write-farkup) [ string>> ] [ mode>> ] bi render-code ;
M: table-row (write-farkup) ( obj -- ) M: table-row (write-farkup) ( obj -- )
obj>> [ [ [ (write-farkup) ] "td" in-tag. ] each ] "tr" in-tag. ; child>> [ [ [ (write-farkup) ] "td" in-tag. ] each ] "tr" in-tag. ;
M: table (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "table" in-tag. ; M: table (write-farkup) [ child>> (write-farkup) ] "table" in-tag. ;
M: fixnum (write-farkup) ( obj -- ) write1 ; M: string (write-farkup) escape-string write ;
M: string (write-farkup) ( obj -- ) write ; M: vector (write-farkup) [ (write-farkup) ] each ;
M: vector (write-farkup) ( obj -- ) [ (write-farkup) ] each ; M: f (write-farkup) drop ;
M: f (write-farkup) ( obj -- ) drop ;
: write-farkup ( string -- ) : write-farkup ( string -- )
farkup (write-farkup) ; parse-farkup (write-farkup) ;
: convert-farkup ( string -- string' ) : convert-farkup ( string -- string' )
farkup [ (write-farkup) ] with-string-writer ; parse-farkup [ (write-farkup) ] with-string-writer ;

View File

@ -14,7 +14,8 @@ html.elements
html.components html.components
html.components html.components
html.templates.chloe html.templates.chloe
html.templates.chloe.syntax ; html.templates.chloe.syntax
html.templates.chloe.compiler ;
IN: furnace.actions IN: furnace.actions
SYMBOL: params SYMBOL: params
@ -29,7 +30,8 @@ SYMBOL: rest
</ul> </ul>
] unless-empty ; ] unless-empty ;
CHLOE: validation-messages drop render-validation-messages ; CHLOE: validation-messages
drop [ render-validation-messages ] [code] ;
TUPLE: action rest authorize init display validate submit ; TUPLE: action rest authorize init display validate submit ;

View File

@ -48,8 +48,6 @@ IN: html.elements
! !
! <input "text" =type "name" =name "20" =size input/> ! <input "text" =type "name" =name "20" =size input/>
: elements-vocab ( -- vocab-name ) "html.elements" ;
SYMBOL: html SYMBOL: html
: write-html ( str -- ) : write-html ( str -- )
@ -60,6 +58,8 @@ SYMBOL: html
<< <<
: elements-vocab ( -- vocab-name ) "html.elements" ;
: html-word ( name def effect -- ) : html-word ( name def effect -- )
#! Define 'word creating' word to allow #! Define 'word creating' word to allow
#! dynamically creating words. #! dynamically creating words.

View File

@ -14,7 +14,7 @@ IN: urls
[ letter? ] [ letter? ]
[ LETTER? ] [ LETTER? ]
[ digit? ] [ digit? ]
[ "/_-." member? ] [ "/_-.:" member? ]
} 1|| ; foldable } 1|| ; foldable
<PRIVATE <PRIVATE
@ -25,7 +25,7 @@ IN: urls
PRIVATE> PRIVATE>
: url-encode ( str -- str ) : url-encode ( str -- encoded )
[ [
[ dup url-quotable? [ , ] [ push-utf8 ] if ] each [ dup url-quotable? [ , ] [ push-utf8 ] if ] each
] "" make ; ] "" make ;
@ -58,7 +58,7 @@ PRIVATE>
PRIVATE> PRIVATE>
: url-decode ( str -- str ) : url-decode ( str -- decoded )
[ 0 swap url-decode-iter ] "" make utf8 decode ; [ 0 swap url-decode-iter ] "" make utf8 decode ;
<PRIVATE <PRIVATE

View File

@ -1356,16 +1356,18 @@ ARTICLE: "sequences-slices" "Subsequences and slices"
"A " { $emphasis "slice" } " is a virtual sequence which presents as view of a subsequence of an underlying sequence:" "A " { $emphasis "slice" } " is a virtual sequence which presents as view of a subsequence of an underlying sequence:"
{ $subsection slice } { $subsection slice }
{ $subsection slice? } { $subsection slice? }
"Creating slices:" "Extracting a slice:"
{ $subsection <slice> } { $subsection <slice> }
{ $subsection head-slice } { $subsection head-slice }
{ $subsection tail-slice } { $subsection tail-slice }
{ $subsection but-last-slice }
{ $subsection rest-slice }
{ $subsection head-slice* } { $subsection head-slice* }
{ $subsection tail-slice* } { $subsection tail-slice* }
"Removing the first or last element:"
{ $subsection rest-slice }
{ $subsection but-last-slice }
"Taking a sequence apart into a head and a tail:" "Taking a sequence apart into a head and a tail:"
{ $subsection unclip-slice } { $subsection unclip-slice }
{ $subsection unclip-last-slice }
{ $subsection cut-slice } { $subsection cut-slice }
"A utility for words which use slices as iterators:" "A utility for words which use slices as iterators:"
{ $subsection <flat-slice> } ; { $subsection <flat-slice> } ;

13
extra/irc/client/client.factor Normal file → Executable file
View File

@ -91,8 +91,6 @@ SYMBOL: current-irc-client
: irc-send ( irc-message -- ) irc> out-messages>> mailbox-put ; : irc-send ( irc-message -- ) irc> out-messages>> mailbox-put ;
: listener> ( name -- listener/f ) irc> listeners>> at ; : listener> ( name -- listener/f ) irc> listeners>> at ;
: maybe-mailbox-get ( mailbox quot: ( irc-message -- ) -- )
[ dup mailbox-empty? [ drop 0.1 sleep ] ] dip '[ mailbox-get @ ] if ; inline
GENERIC: to-listener ( message obj -- ) GENERIC: to-listener ( message obj -- )
@ -294,14 +292,14 @@ DEFER: (connect-irc)
[ (reader-loop) ] [ handle-disconnect ] recover t ; [ (reader-loop) ] [ handle-disconnect ] recover t ;
: writer-loop ( -- ? ) : writer-loop ( -- ? )
irc> out-messages>> [ handle-outgoing-irc ] maybe-mailbox-get t ; irc> out-messages>> mailbox-get handle-outgoing-irc t ;
! ====================================== ! ======================================
! Processing loops ! Processing loops
! ====================================== ! ======================================
: in-multiplexer-loop ( -- ? ) : in-multiplexer-loop ( -- ? )
irc> in-messages>> [ handle-incoming-irc ] maybe-mailbox-get t ; irc> in-messages>> mailbox-get handle-incoming-irc t ;
: strings>privmsg ( name string -- privmsg ) : strings>privmsg ( name string -- privmsg )
privmsg new [ (>>trailing) ] keep [ (>>name) ] keep ; privmsg new [ (>>trailing) ] keep [ (>>name) ] keep ;
@ -314,9 +312,10 @@ DEFER: (connect-irc)
: listener-loop ( name -- ? ) : listener-loop ( name -- ? )
dup listener> [ dup listener> [
out-messages>> [ maybe-annotate-with-name out-messages>> mailbox-get
irc> out-messages>> mailbox-put ] with maybe-annotate-with-name
maybe-mailbox-get t irc> out-messages>> mailbox-put
t
] [ drop f ] if* ; ] [ drop f ] if* ;
: spawn-irc-loop ( quot: ( -- ? ) name -- ) : spawn-irc-loop ( quot: ( -- ? ) name -- )

View File

@ -1,3 +1,5 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: math kernel accessors http.server http.server.dispatchers USING: math kernel accessors http.server http.server.dispatchers
furnace furnace.actions furnace.sessions furnace.redirection furnace furnace.actions furnace.sessions furnace.redirection
html.components html.forms html.templates.chloe html.components html.forms html.templates.chloe
@ -28,3 +30,20 @@ M: counter-app init-session* drop 0 count sset ;
[ 1- ] <counter-action> "dec" add-responder [ 1- ] <counter-action> "dec" add-responder
<display-action> "" add-responder <display-action> "" add-responder
<sessions> ; <sessions> ;
! Deployment example
USING: db.sqlite db.tuples db furnace.db namespaces ;
: counter-db ( -- params db ) "counter.db" sqlite-db ;
: init-counter-db ( -- )
counter-db [ session ensure-table ] with-db ;
: run-counter ( -- )
init-counter-db
<counter-app>
counter-db <db-persistence>
main-responder set-global
8080 httpd ;
MAIN: run-counter