Merge branch 'master' of git://factorcode.org/git/factor
Doug Coleman
commit
59d38f88be
|
|
@ -9,7 +9,7 @@ HELP: write-farkup
|
|||
{ $values { "string" string } }
|
||||
{ $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" } }
|
||||
{ $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 } "." } ;
|
||||
|
||||
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 heading2 }
|
||||
{ $subsection heading3 }
|
||||
|
|
@ -44,7 +44,7 @@ $nl
|
|||
{ $subsection convert-farkup }
|
||||
{ $subsection write-farkup }
|
||||
"The syntax tree of a piece of Farkup can also be inspected and modified:"
|
||||
{ $subsection farkup }
|
||||
{ $subsection parse-farkup }
|
||||
{ $subsection (write-farkup) }
|
||||
{ $subsection "farkup-ast" } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -11,13 +11,11 @@ link-no-follow? off
|
|||
[ "Baz" ] [ "Baz" simple-link-title ] unit-test
|
||||
|
||||
[ ] [
|
||||
"abcd-*strong*\nasdifj\nweouh23ouh23"
|
||||
"paragraph" \ farkup rule parse drop
|
||||
"abcd-*strong*\nasdifj\nweouh23ouh23" parse-farkup drop
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"abcd-*strong*\nasdifj\nweouh23ouh23\n"
|
||||
"paragraph" \ farkup rule parse drop
|
||||
"abcd-*strong*\nasdifj\nweouh23ouh23\n" parse-farkup drop
|
||||
] unit-test
|
||||
|
||||
[ "<p>a-b</p>" ] [ "a-b" convert-farkup ] unit-test
|
||||
|
|
@ -118,3 +116,7 @@ link-no-follow? off
|
|||
] 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><foo></p>" ] [ "<foo>" convert-farkup ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,29 +1,29 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays combinators html.elements io io.streams.string
|
||||
kernel math memoize namespaces peg peg.ebnf prettyprint
|
||||
sequences sequences.deep strings xml.entities vectors splitting
|
||||
xmode.code2html ;
|
||||
USING: accessors arrays combinators html.elements io
|
||||
io.streams.string kernel math memoize namespaces peg peg.ebnf
|
||||
prettyprint sequences sequences.deep strings xml.entities
|
||||
vectors splitting xmode.code2html urls ;
|
||||
IN: farkup
|
||||
|
||||
SYMBOL: relative-link-prefix
|
||||
SYMBOL: disable-images?
|
||||
SYMBOL: link-no-follow?
|
||||
|
||||
TUPLE: heading1 obj ;
|
||||
TUPLE: heading2 obj ;
|
||||
TUPLE: heading3 obj ;
|
||||
TUPLE: heading4 obj ;
|
||||
TUPLE: strong obj ;
|
||||
TUPLE: emphasis obj ;
|
||||
TUPLE: superscript obj ;
|
||||
TUPLE: subscript obj ;
|
||||
TUPLE: inline-code obj ;
|
||||
TUPLE: paragraph obj ;
|
||||
TUPLE: list-item obj ;
|
||||
TUPLE: list obj ;
|
||||
TUPLE: table obj ;
|
||||
TUPLE: table-row obj ;
|
||||
TUPLE: heading1 child ;
|
||||
TUPLE: heading2 child ;
|
||||
TUPLE: heading3 child ;
|
||||
TUPLE: heading4 child ;
|
||||
TUPLE: strong child ;
|
||||
TUPLE: emphasis child ;
|
||||
TUPLE: superscript child ;
|
||||
TUPLE: subscript child ;
|
||||
TUPLE: inline-code child ;
|
||||
TUPLE: paragraph child ;
|
||||
TUPLE: list-item child ;
|
||||
TUPLE: list child ;
|
||||
TUPLE: table child ;
|
||||
TUPLE: table-row child ;
|
||||
TUPLE: link href text ;
|
||||
TUPLE: image href text ;
|
||||
TUPLE: code mode string ;
|
||||
|
|
@ -34,7 +34,7 @@ TUPLE: code mode string ;
|
|||
: simple-link-title ( string -- string' )
|
||||
dup absolute-url? [ "/" last-split1 swap or ] unless ;
|
||||
|
||||
EBNF: farkup
|
||||
EBNF: parse-farkup
|
||||
nl = ("\r\n" | "\r" | "\n") => [[ drop "\n" ]]
|
||||
2nl = nl nl
|
||||
|
||||
|
|
@ -65,7 +65,7 @@ subscript = "~" (!("~" | nl).)+ "~"
|
|||
inline-code = "%" (!("%" | nl).)+ "%"
|
||||
=> [[ second >string inline-code boa ]]
|
||||
|
||||
escaped-char = "\" . => [[ second ]]
|
||||
escaped-char = "\" . => [[ second 1string ]]
|
||||
|
||||
link-content = (!("|"|"]").)+
|
||||
|
||||
|
|
@ -89,20 +89,26 @@ inline-tag = strong | emphasis | superscript | subscript | inline-code
|
|||
|
||||
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 ]]
|
||||
table-row = "|" (table-column)+
|
||||
=> [[ second table-row boa ]]
|
||||
table = ((table-row nl => [[ first ]] )+ table-row? | table-row)
|
||||
=> [[ 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-item nl)+ paragraph-item?
|
||||
| paragraph-item)
|
||||
=> [[ paragraph boa ]]
|
||||
|
||||
list-item = '-' ((!(inline-delimiter | nl).)+ | inline-tag)*
|
||||
|
||||
list-item = '-' (cell | inline-tag)*
|
||||
=> [[ second list-item boa ]]
|
||||
list = ((list-item nl)+ list-item? | list-item)
|
||||
=> [[ list boa ]]
|
||||
|
|
@ -136,7 +142,7 @@ stand-alone
|
|||
|
||||
: write-link ( href text -- )
|
||||
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> ]
|
||||
bi* ;
|
||||
|
||||
|
|
@ -146,7 +152,7 @@ stand-alone
|
|||
<strong> "Images are not allowed" write </strong>
|
||||
] [
|
||||
escape-link
|
||||
[ <img =src ] [ [ =alt ] unless-empty img/> ] bi*
|
||||
[ <img url-encode =src ] [ [ =alt ] unless-empty img/> ] bi*
|
||||
] if ;
|
||||
|
||||
: render-code ( string mode -- string' )
|
||||
|
|
@ -161,31 +167,30 @@ GENERIC: (write-farkup) ( farkup -- )
|
|||
: <foo.> ( string -- ) <foo> write ;
|
||||
: </foo.> ( string -- ) </foo> write ;
|
||||
: in-tag. ( obj quot string -- ) [ <foo.> call ] keep </foo.> ; inline
|
||||
M: heading1 (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "h1" in-tag. ;
|
||||
M: heading2 (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "h2" in-tag. ;
|
||||
M: heading3 (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "h3" in-tag. ;
|
||||
M: heading4 (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "h4" in-tag. ;
|
||||
M: strong (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "strong" in-tag. ;
|
||||
M: emphasis (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "em" in-tag. ;
|
||||
M: superscript (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "sup" in-tag. ;
|
||||
M: subscript (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "sub" in-tag. ;
|
||||
M: inline-code (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "code" in-tag. ;
|
||||
M: list-item (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "li" in-tag. ;
|
||||
M: list (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "ul" in-tag. ;
|
||||
M: paragraph (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "p" in-tag. ;
|
||||
M: link (write-farkup) ( obj -- ) [ href>> ] [ text>> ] bi write-link ;
|
||||
M: image (write-farkup) ( obj -- ) [ href>> ] [ text>> ] bi write-image-link ;
|
||||
M: code (write-farkup) ( obj -- ) [ string>> ] [ mode>> ] bi render-code ;
|
||||
M: heading1 (write-farkup) [ child>> (write-farkup) ] "h1" in-tag. ;
|
||||
M: heading2 (write-farkup) [ child>> (write-farkup) ] "h2" in-tag. ;
|
||||
M: heading3 (write-farkup) [ child>> (write-farkup) ] "h3" in-tag. ;
|
||||
M: heading4 (write-farkup) [ child>> (write-farkup) ] "h4" in-tag. ;
|
||||
M: strong (write-farkup) [ child>> (write-farkup) ] "strong" in-tag. ;
|
||||
M: emphasis (write-farkup) [ child>> (write-farkup) ] "em" in-tag. ;
|
||||
M: superscript (write-farkup) [ child>> (write-farkup) ] "sup" in-tag. ;
|
||||
M: subscript (write-farkup) [ child>> (write-farkup) ] "sub" in-tag. ;
|
||||
M: inline-code (write-farkup) [ child>> (write-farkup) ] "code" in-tag. ;
|
||||
M: list-item (write-farkup) [ child>> (write-farkup) ] "li" in-tag. ;
|
||||
M: list (write-farkup) [ child>> (write-farkup) ] "ul" in-tag. ;
|
||||
M: paragraph (write-farkup) [ child>> (write-farkup) ] "p" in-tag. ;
|
||||
M: link (write-farkup) [ href>> ] [ text>> ] bi write-link ;
|
||||
M: image (write-farkup) [ href>> ] [ text>> ] bi write-image-link ;
|
||||
M: code (write-farkup) [ string>> ] [ mode>> ] bi render-code ;
|
||||
M: table-row (write-farkup) ( obj -- )
|
||||
obj>> [ [ [ (write-farkup) ] "td" in-tag. ] each ] "tr" in-tag. ;
|
||||
M: table (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "table" in-tag. ;
|
||||
M: fixnum (write-farkup) ( obj -- ) write1 ;
|
||||
M: string (write-farkup) ( obj -- ) write ;
|
||||
M: vector (write-farkup) ( obj -- ) [ (write-farkup) ] each ;
|
||||
M: f (write-farkup) ( obj -- ) drop ;
|
||||
child>> [ [ [ (write-farkup) ] "td" in-tag. ] each ] "tr" in-tag. ;
|
||||
M: table (write-farkup) [ child>> (write-farkup) ] "table" in-tag. ;
|
||||
M: string (write-farkup) escape-string write ;
|
||||
M: vector (write-farkup) [ (write-farkup) ] each ;
|
||||
M: f (write-farkup) drop ;
|
||||
|
||||
: write-farkup ( string -- )
|
||||
farkup (write-farkup) ;
|
||||
parse-farkup (write-farkup) ;
|
||||
|
||||
: convert-farkup ( string -- string' )
|
||||
farkup [ (write-farkup) ] with-string-writer ;
|
||||
parse-farkup [ (write-farkup) ] with-string-writer ;
|
||||
|
|
|
|||
|
|
@ -14,7 +14,8 @@ html.elements
|
|||
html.components
|
||||
html.components
|
||||
html.templates.chloe
|
||||
html.templates.chloe.syntax ;
|
||||
html.templates.chloe.syntax
|
||||
html.templates.chloe.compiler ;
|
||||
IN: furnace.actions
|
||||
|
||||
SYMBOL: params
|
||||
|
|
@ -29,7 +30,8 @@ SYMBOL: rest
|
|||
</ul>
|
||||
] 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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -48,8 +48,6 @@ IN: html.elements
|
|||
!
|
||||
! <input "text" =type "name" =name "20" =size input/>
|
||||
|
||||
: elements-vocab ( -- vocab-name ) "html.elements" ;
|
||||
|
||||
SYMBOL: html
|
||||
|
||||
: write-html ( str -- )
|
||||
|
|
@ -60,6 +58,8 @@ SYMBOL: html
|
|||
|
||||
<<
|
||||
|
||||
: elements-vocab ( -- vocab-name ) "html.elements" ;
|
||||
|
||||
: html-word ( name def effect -- )
|
||||
#! Define 'word creating' word to allow
|
||||
#! dynamically creating words.
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@ IN: urls
|
|||
[ letter? ]
|
||||
[ LETTER? ]
|
||||
[ digit? ]
|
||||
[ "/_-." member? ]
|
||||
[ "/_-.:" member? ]
|
||||
} 1|| ; foldable
|
||||
|
||||
<PRIVATE
|
||||
|
|
@ -25,7 +25,7 @@ IN: urls
|
|||
|
||||
PRIVATE>
|
||||
|
||||
: url-encode ( str -- str )
|
||||
: url-encode ( str -- encoded )
|
||||
[
|
||||
[ dup url-quotable? [ , ] [ push-utf8 ] if ] each
|
||||
] "" make ;
|
||||
|
|
@ -58,7 +58,7 @@ PRIVATE>
|
|||
|
||||
PRIVATE>
|
||||
|
||||
: url-decode ( str -- str )
|
||||
: url-decode ( str -- decoded )
|
||||
[ 0 swap url-decode-iter ] "" make utf8 decode ;
|
||||
|
||||
<PRIVATE
|
||||
|
|
|
|||
|
|
@ -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:"
|
||||
{ $subsection slice }
|
||||
{ $subsection slice? }
|
||||
"Creating slices:"
|
||||
"Extracting a slice:"
|
||||
{ $subsection <slice> }
|
||||
{ $subsection head-slice }
|
||||
{ $subsection tail-slice }
|
||||
{ $subsection but-last-slice }
|
||||
{ $subsection rest-slice }
|
||||
{ $subsection head-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:"
|
||||
{ $subsection unclip-slice }
|
||||
{ $subsection unclip-last-slice }
|
||||
{ $subsection cut-slice }
|
||||
"A utility for words which use slices as iterators:"
|
||||
{ $subsection <flat-slice> } ;
|
||||
|
|
|
|||
|
|
@ -91,8 +91,6 @@ SYMBOL: current-irc-client
|
|||
: irc-send ( irc-message -- ) irc> out-messages>> mailbox-put ;
|
||||
: 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 -- )
|
||||
|
||||
|
|
@ -294,14 +292,14 @@ DEFER: (connect-irc)
|
|||
[ (reader-loop) ] [ handle-disconnect ] recover t ;
|
||||
|
||||
: writer-loop ( -- ? )
|
||||
irc> out-messages>> [ handle-outgoing-irc ] maybe-mailbox-get t ;
|
||||
irc> out-messages>> mailbox-get handle-outgoing-irc t ;
|
||||
|
||||
! ======================================
|
||||
! Processing loops
|
||||
! ======================================
|
||||
|
||||
: 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 )
|
||||
privmsg new [ (>>trailing) ] keep [ (>>name) ] keep ;
|
||||
|
|
@ -314,9 +312,10 @@ DEFER: (connect-irc)
|
|||
|
||||
: listener-loop ( name -- ? )
|
||||
dup listener> [
|
||||
out-messages>> [ maybe-annotate-with-name
|
||||
irc> out-messages>> mailbox-put ] with
|
||||
maybe-mailbox-get t
|
||||
out-messages>> mailbox-get
|
||||
maybe-annotate-with-name
|
||||
irc> out-messages>> mailbox-put
|
||||
t
|
||||
] [ drop f ] if* ;
|
||||
|
||||
: spawn-irc-loop ( quot: ( -- ? ) name -- )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
furnace furnace.actions furnace.sessions furnace.redirection
|
||||
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
|
||||
<display-action> "" add-responder
|
||||
<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
|
||||
|
|
|
|||
Loading…
Reference in New Issue