-! Copyright (C) 2008 Doug Coleman.
+! Copyright (C) 2008, 2009 Doug Coleman, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays combinators io
-io.streams.string kernel math namespaces peg peg.ebnf
-sequences sequences.deep strings xml.entities xml.literals
-vectors splitting xmode.code2html urls.encoding xml.data
-xml.writer ;
+USING: sequences kernel splitting lists fry accessors assocs math.order
+math combinators namespaces urls.encoding xml.syntax xmode.code2html
+xml.data arrays strings vectors xml.writer io.streams.string locals
+unicode.categories ;
IN: farkup
SYMBOL: relative-link-prefix
: simple-link-title ( string -- string' )
dup absolute-url? [ "/" split1-last swap or ] unless ;
-EBNF: parse-farkup
-nl = ("\r\n" | "\r" | "\n") => [[ drop "\n" ]]
-whitespace = " " | "\t" | nl
-
-heading1 = "=" (!("=" | nl).)+ "="
- => [[ second >string heading1 boa ]]
-
-heading2 = "==" (!("=" | nl).)+ "=="
- => [[ second >string heading2 boa ]]
-
-heading3 = "===" (!("=" | nl).)+ "==="
- => [[ second >string heading3 boa ]]
-
-heading4 = "====" (!("=" | nl).)+ "===="
- => [[ second >string heading4 boa ]]
-
-heading = heading4 | heading3 | heading2 | heading1
-
-
-
-strong = "*" (!("*" | nl).)+ "*"
- => [[ second >string strong boa ]]
-
-emphasis = "_" (!("_" | nl).)+ "_"
- => [[ second >string emphasis boa ]]
-
-superscript = "^" (!("^" | nl).)+ "^"
- => [[ second >string superscript boa ]]
-
-subscript = "~" (!("~" | nl).)+ "~"
- => [[ second >string subscript boa ]]
-
-inline-code = "%" (!("%" | nl).)+ "%"
- => [[ second >string inline-code boa ]]
-
-link-content = (!("|"|"]").)+
- => [[ >string ]]
-
-image-link = "[[image:" link-content "|" link-content "]]"
- => [[ [ second >string ] [ fourth >string ] bi image boa ]]
- | "[[image:" link-content "]]"
- => [[ second >string f image boa ]]
-
-simple-link = "[[" link-content "]]"
- => [[ second >string dup simple-link-title link boa ]]
-
-labelled-link = "[[" link-content "|" link-content "]]"
- => [[ [ second >string ] [ fourth >string ] bi link boa ]]
-
-link = image-link | labelled-link | simple-link
-
-escaped-char = "\" .
- => [[ second 1string ]]
-
-inline-tag = strong | emphasis | superscript | subscript | inline-code
- | link | escaped-char
-
-
-
-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 ]]
-
-text = (!(nl | code | heading | inline-delimiter | table ).)+
- => [[ >string ]]
-
-paragraph-nl-item = nl list
- | nl line
- | nl => [[ line-breaks? get [ drop line-break new ] when ]]
-paragraph-item = (table | code | text | inline-tag | inline-delimiter)+
-paragraph = ((paragraph-item paragraph-nl-item)+ nl+ => [[ first ]]
- | (paragraph-item paragraph-nl-item)+ paragraph-item?
- | paragraph-item)
- => [[ paragraph boa ]]
-
-
-list-item = (cell | inline-tag | inline-delimiter)*
-
-ordered-list-item = '#' list-item
- => [[ second list-item boa ]]
-ordered-list = ((ordered-list-item nl)+ ordered-list-item? | ordered-list-item)
- => [[ ordered-list boa ]]
-
-unordered-list-item = '-' list-item
- => [[ second list-item boa ]]
-unordered-list = ((unordered-list-item nl)+ unordered-list-item? | unordered-list-item)
- => [[ unordered-list boa ]]
-
-list = ordered-list | unordered-list
-
-
-line = '___'
- => [[ drop line new ]]
-
-
-named-code
- = '[' (!('{' | whitespace | '[').)+ '{' (!("}]").)+ "}]"
- => [[ [ second >string ] [ fourth >string ] bi code boa ]]
-
-simple-code
- = "[{" (!("}]").)+ "}]"
- => [[ second >string f swap code boa ]]
+! _foo*bar_baz*bing works like <i>foo*bar</i>baz<b>bing</b>
+! I could support overlapping, but there's not a good use case for it.
+
+DEFER: (parse-paragraph)
+
+: parse-paragraph ( string -- seq )
+ (parse-paragraph) list>array ;
+
+: make-paragraph ( string -- paragraph )
+ parse-paragraph paragraph boa ;
+
+: cut-half-slice ( string i -- before after-slice )
+ [ head ] [ 1 + short tail-slice ] 2bi ;
+
+: find-cut ( string quot -- before after delimiter )
+ dupd find
+ [ [ cut-half-slice ] [ f ] if* ] dip ; inline
+
+: parse-delimiter ( string delimiter class -- paragraph )
+ [ '[ _ = ] find-cut drop ] dip
+ '[ parse-paragraph _ new swap >>child ]
+ [ (parse-paragraph) ] bi* cons ;
+
+: delimiter-class ( delimiter -- class )
+ H{
+ { CHAR: * strong }
+ { CHAR: _ emphasis }
+ { CHAR: ^ superscript }
+ { CHAR: ~ subscript }
+ { CHAR: % inline-code }
+ } at ;
+
+: or-simple-title ( url title/f quot: ( title -- title' ) -- url title' )
+ [ "" like dup simple-link-title ] if* ; inline
+
+: parse-link ( string -- paragraph-list )
+ rest-slice "]]" split1-slice [
+ "|" split1
+ [ "image:" ?head ] dip swap
+ [ [ ] or-simple-title image boa ]
+ [ [ parse-paragraph ] or-simple-title link boa ] if
+ ] dip [ (parse-paragraph) cons ] [ 1list ] if* ;
+
+: ?first ( seq -- elt ) 0 swap ?nth ;
+
+: parse-big-link ( before after -- link rest )
+ dup ?first CHAR: [ =
+ [ parse-link ]
+ [ [ CHAR: [ suffix ] [ (parse-paragraph) ] bi* ]
+ if ;
+
+: escape ( before after -- before' after' )
+ [ nil ] [ unclip-slice swap [ suffix ] dip (parse-paragraph) ] if-empty ;
+
+: (parse-paragraph) ( string -- list )
+ [ nil ] [
+ [ "*_^~%[\\" member? ] find-cut [
+ {
+ { CHAR: [ [ parse-big-link ] }
+ { CHAR: \\ [ escape ] }
+ [ dup delimiter-class parse-delimiter ]
+ } case cons
+ ] [ drop "" like 1list ] if*
+ ] if-empty ;
+
+: <farkup-state> ( string -- state ) string-lines ;
+: look ( state i -- char ) swap first ?nth ;
+: done? ( state -- ? ) empty? ;
+: take-line ( state -- state' line ) unclip-slice ;
+
+: take-lines ( state char -- state' lines )
+ dupd '[ ?first _ = not ] find drop
+ [ cut-slice ] [ f ] if* swap ;
+
+:: (take-until) ( state delimiter accum -- string/f state' )
+ state empty? [ accum "\n" join f ] [
+ state unclip-slice :> first :> rest
+ first delimiter split1 :> after :> before
+ before accum push
+ after [
+ accum "\n" join
+ rest after prefix
+ ] [
+ rest delimiter accum (take-until)
+ ] if
+ ] if ;
-code = named-code | simple-code
+: take-until ( state delimiter -- string state'/f )
+ V{ } clone (take-until) ;
+
+: count= ( string -- n )
+ dup <reversed> [ [ CHAR: = = not ] find drop 0 or ] bi@ min ;
+
+: trim= ( string -- string' )
+ [ CHAR: = = ] trim ;
+
+: make-heading ( string class -- heading )
+ [ trim= parse-paragraph ] dip boa ; inline
+
+: parse-heading ( state -- state' heading )
+ take-line dup count= {
+ { 0 [ make-paragraph ] }
+ { 1 [ heading1 make-heading ] }
+ { 2 [ heading2 make-heading ] }
+ { 3 [ heading3 make-heading ] }
+ { 4 [ heading4 make-heading ] }
+ [ drop heading4 make-heading ]
+ } case ;
+
+: trim-row ( seq -- seq' )
+ rest
+ dup last empty? [ but-last ] when ;
+
+: ?last ( seq -- elt/f )
+ [ f ] [ last ] if-empty ;
+
+: coalesce ( rows -- rows' )
+ V{ } clone [
+ '[
+ _ dup ?last ?last CHAR: \\ =
+ [ [ pop "|" rot 3append ] keep ] when
+ push
+ ] each
+ ] keep ;
+
+: parse-table ( state -- state' table )
+ CHAR: | take-lines [
+ "|" split
+ trim-row
+ coalesce
+ [ parse-paragraph ] map
+ table-row boa
+ ] map table boa ;
+
+: parse-line ( state -- state' item )
+ take-line dup "___" =
+ [ drop line new ] [ make-paragraph ] if ;
+
+: parse-list ( state char class -- state' list )
+ [
+ take-lines
+ [ rest parse-paragraph list-item boa ] map
+ ] dip boa ; inline
+
+: parse-ul ( state -- state' ul )
+ CHAR: - unordered-list parse-list ;
+
+: parse-ol ( state -- state' ul )
+ CHAR: # ordered-list parse-list ;
+
+: parse-code ( state -- state' item )
+ dup 1 look CHAR: [ =
+ [ take-line make-paragraph ] [
+ dup "{" take-until [
+ [ nip rest ] dip
+ "}]" take-until
+ [ code boa ] dip swap
+ ] [ drop take-line make-paragraph ] if*
+ ] if ;
+: parse-item ( state -- state' item )
+ dup 0 look {
+ { CHAR: = [ parse-heading ] }
+ { CHAR: | [ parse-table ] }
+ { CHAR: _ [ parse-line ] }
+ { CHAR: - [ parse-ul ] }
+ { CHAR: # [ parse-ol ] }
+ { CHAR: [ [ parse-code ] }
+ { f [ rest-slice f ] }
+ [ drop take-line make-paragraph ]
+ } case ;
-stand-alone
- = (line | code | heading | list | table | paragraph | nl)*
-;EBNF
+: parse-farkup ( string -- farkup )
+ <farkup-state> [ dup done? not ] [ parse-item ] produce nip sift ;
-: invalid-url "javascript:alert('Invalid URL in farkup');" ;
+CONSTANT: invalid-url "javascript:alert('Invalid URL in farkup');"
: check-url ( href -- href' )
{
{ [ dup [ 127 > ] any? ] [ drop invalid-url ] }
{ [ dup first "/\\" member? ] [ drop invalid-url ] }
{ [ CHAR: : over member? ] [ dup absolute-url? [ drop invalid-url ] unless ] }
- [ relative-link-prefix get prepend "" like ]
- } cond url-encode ;
-
-: write-link ( href text -- xml )
- [ check-url link-no-follow? get "true" and ] dip
- [XML <a href=<-> nofollow=<->><-></a> XML] ;
-
-: write-image-link ( href text -- xml )
- disable-images? get [
- 2drop
- [XML <strong>Images are not allowed</strong> XML]
- ] [
- [ check-url ] [ f like ] bi*
- [XML <img src=<-> alt=<->/> XML]
- ] if ;
+ [ relative-link-prefix get prepend "" like url-encode ]
+ } cond ;
: render-code ( string mode -- xml )
[ string-lines ] dip htmlize-lines
M: paragraph (write-farkup) "p" farkup-inside ;
M: table (write-farkup) "table" farkup-inside ;
+: write-link ( href text -- xml )
+ [ check-url link-no-follow? get "nofollow" and ] dip
+ [XML <a href=<-> rel=<->><-></a> XML] ;
+
+: write-image-link ( href text -- xml )
+ disable-images? get [
+ 2drop
+ [XML <strong>Images are not allowed</strong> XML]
+ ] [
+ [ check-url ] [ f like ] bi*
+ [XML <img src=<-> alt=<->/> XML]
+ ] if ;
+
+: open-link ( link -- href text )
+ [ href>> ] [ text>> (write-farkup) ] bi ;
+
M: link (write-farkup)
- [ href>> ] [ text>> ] bi write-link ;
+ open-link write-link ;
M: image (write-farkup)
- [ href>> ] [ text>> ] bi write-image-link ;
+ open-link write-image-link ;
M: code (write-farkup)
[ string>> ] [ mode>> ] bi render-code ;
M: string (write-farkup) ;
-M: vector (write-farkup) [ (write-farkup) ] map ;
-
-M: f (write-farkup) ;
+M: array (write-farkup) [ (write-farkup) ] map ;
: farkup>xml ( string -- xml )
parse-farkup (write-farkup) ;
: convert-farkup ( string -- string' )
[ write-farkup ] with-string-writer ;
+
projects / factor.git / blobdiff