basis/farkup/farkup.factor

   1 ! Copyright (C) 2008 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays combinators html.elements io
   4 io.streams.string kernel math namespaces peg peg.ebnf
   5 sequences sequences.deep strings xml.entities
   6 vectors splitting xmode.code2html urls.encoding ;
   7 IN: farkup
   8
   9 SYMBOL: relative-link-prefix
  10 SYMBOL: disable-images?
  11 SYMBOL: link-no-follow?
  12 SYMBOL: line-breaks?
  13
  14 TUPLE: heading1 child ;
  15 TUPLE: heading2 child ;
  16 TUPLE: heading3 child ;
  17 TUPLE: heading4 child ;
  18 TUPLE: strong child ;
  19 TUPLE: emphasis child ;
  20 TUPLE: superscript child ;
  21 TUPLE: subscript child ;
  22 TUPLE: inline-code child ;
  23 TUPLE: paragraph child ;
  24 TUPLE: list-item child ;
  25 TUPLE: unordered-list child ;
  26 TUPLE: ordered-list child ;
  27 TUPLE: table child ;
  28 TUPLE: table-row child ;
  29 TUPLE: link href text ;
  30 TUPLE: image href text ;
  31 TUPLE: code mode string ;
  32 TUPLE: line ;
  33 TUPLE: line-break ;
  34
  35 : absolute-url? ( string -- ? )
  36     { "http://" "https://" "ftp://" } [ head? ] with contains? ;
  37
  38 : simple-link-title ( string -- string' )
  39     dup absolute-url? [ "/" split1-last swap or ] unless ;
  40
  41 EBNF: parse-farkup
  42 nl               = ("\r\n" | "\r" | "\n") => [[ drop "\n" ]]
  43 whitespace       = " " | "\t" | nl
  44
  45 heading1      = "=" (!("=" | nl).)+ "="
  46     => [[ second >string heading1 boa ]]
  47
  48 heading2      = "==" (!("=" | nl).)+ "=="
  49     => [[ second >string heading2 boa ]]
  50
  51 heading3      = "===" (!("=" | nl).)+ "==="
  52     => [[ second >string heading3 boa ]]
  53
  54 heading4      = "====" (!("=" | nl).)+ "===="
  55     => [[ second >string heading4 boa ]]
  56
  57 heading          = heading4 | heading3 | heading2 | heading1
  58
  59
  60
  61 strong        = "*" (!("*" | nl).)+ "*"
  62     => [[ second >string strong boa ]]
  63
  64 emphasis      = "_" (!("_" | nl).)+ "_"
  65     => [[ second >string emphasis boa ]]
  66
  67 superscript   = "^" (!("^" | nl).)+ "^"
  68     => [[ second >string superscript boa ]]
  69
  70 subscript     = "~" (!("~" | nl).)+ "~"
  71     => [[ second >string subscript boa ]]
  72
  73 inline-code   = "%" (!("%" | nl).)+ "%"
  74     => [[ second >string inline-code boa ]]
  75
  76 link-content     = (!("|"|"]").)+
  77
  78 image-link       = "[[image:" link-content  "|" link-content "]]"
  79                     => [[ [ second >string ] [ fourth >string ] bi image boa ]]
  80                   | "[[image:" link-content "]]"
  81                     => [[ second >string f image boa ]]
  82
  83 simple-link      = "[[" link-content "]]"
  84     => [[ second >string dup simple-link-title link boa ]]
  85
  86 labelled-link    = "[[" link-content "|" link-content "]]"
  87     => [[ [ second >string ] [ fourth >string ] bi link boa ]]
  88
  89 link             = image-link | labelled-link | simple-link
  90
  91 escaped-char  = "\" .
  92     => [[ second 1string ]]
  93
  94 inline-tag       = strong | emphasis | superscript | subscript | inline-code
  95                    | link | escaped-char
  96
  97
  98
  99 inline-delimiter = '*' | '_' | '^' | '~' | '%' | '\' | '['
 100
 101 cell             = (!(inline-delimiter | '|' | nl).)+
 102     => [[ >string ]]
 103
 104 table-column     = (list | cell | inline-tag | inline-delimiter  ) '|'
 105     => [[ first ]]
 106 table-row        = "|" (table-column)+
 107     => [[ second table-row boa ]]
 108 table            =  ((table-row nl => [[ first ]] )+ table-row? | table-row)
 109     => [[ table boa ]]
 110
 111 text = (!(nl | code | heading | inline-delimiter | table ).)+
 112     => [[ >string ]]
 113
 114 paragraph-nl-item = nl list
 115     | nl line
 116     | nl => [[ line-breaks? get [ drop line-break new ] when ]]
 117 paragraph-item = (table | code | text | inline-tag | inline-delimiter)+
 118 paragraph = ((paragraph-item paragraph-nl-item)+ nl+ => [[ first ]]
 119              | (paragraph-item paragraph-nl-item)+ paragraph-item?
 120              | paragraph-item)
 121     => [[ paragraph boa ]]
 122
 123
 124 list-item     = (cell | inline-tag | inline-delimiter)*
 125
 126 ordered-list-item      = '#' list-item
 127     => [[ second list-item boa ]]
 128 ordered-list = ((ordered-list-item nl)+ ordered-list-item? | ordered-list-item)
 129     => [[ ordered-list boa ]]
 130
 131 unordered-list-item    = '-' list-item
 132     => [[ second list-item boa ]]
 133 unordered-list = ((unordered-list-item nl)+ unordered-list-item? | unordered-list-item)
 134     => [[ unordered-list boa ]]
 135
 136 list = ordered-list | unordered-list
 137
 138
 139 line = '___'
 140     => [[ drop line new ]]
 141
 142
 143 named-code
 144            =  '[' (!('{' | whitespace | '[').)+ '{' (!("}]").)+ "}]"
 145     => [[ [ second >string ] [ fourth >string ] bi code boa ]]
 146
 147 simple-code
 148            = "[{" (!("}]").)+ "}]"
 149     => [[ second f swap code boa ]]
 150
 151 code = named-code | simple-code
 152
 153
 154 stand-alone
 155            = (line | code | heading | list | table | paragraph | nl)*
 156 ;EBNF
 157
 158 : invalid-url "javascript:alert('Invalid URL in farkup');" ;
 159
 160 : check-url ( href -- href' )
 161     {
 162         { [ dup empty? ] [ drop invalid-url ] }
 163         { [ dup [ 127 > ] contains? ] [ drop invalid-url ] }
 164         { [ dup first "/\\" member? ] [ drop invalid-url ] }
 165         { [ CHAR: : over member? ] [ dup absolute-url? [ drop invalid-url ] unless ] }
 166         [ relative-link-prefix get prepend ]
 167     } cond ;
 168
 169 : escape-link ( href text -- href-esc text-esc )
 170     [ check-url escape-quoted-string ] dip escape-string ;
 171
 172 : write-link ( href text -- )
 173     escape-link
 174     [ <a url-encode =href link-no-follow? get [ "true" =nofollow ] when a> ]
 175     [ write </a> ]
 176     bi* ;
 177
 178 : write-image-link ( href text -- )
 179     disable-images? get [
 180         2drop
 181         <strong> "Images are not allowed" write </strong>
 182     ] [
 183         escape-link
 184         [ <img url-encode =src ] [ [ =alt ] unless-empty img/> ] bi*
 185     ] if ;
 186
 187 : render-code ( string mode -- string' )
 188     [ string-lines ] dip
 189     [
 190         <pre>
 191             htmlize-lines
 192         </pre>
 193     ] with-string-writer write ;
 194
 195 GENERIC: (write-farkup) ( farkup -- )
 196 : <foo.> ( string -- ) <foo> write ;
 197 : </foo.> ( string -- ) </foo> write ;
 198 : in-tag. ( obj quot string -- ) [ <foo.> call ] keep </foo.> ; inline
 199 M: heading1 (write-farkup) [ child>> (write-farkup) ] "h1" in-tag. ;
 200 M: heading2 (write-farkup) [ child>> (write-farkup) ] "h2" in-tag. ;
 201 M: heading3 (write-farkup) [ child>> (write-farkup) ] "h3" in-tag. ;
 202 M: heading4 (write-farkup) [ child>> (write-farkup) ] "h4" in-tag. ;
 203 M: strong (write-farkup) [ child>> (write-farkup) ] "strong" in-tag. ;
 204 M: emphasis (write-farkup) [ child>> (write-farkup) ] "em" in-tag. ;
 205 M: superscript (write-farkup) [ child>> (write-farkup) ] "sup" in-tag. ;
 206 M: subscript (write-farkup) [ child>> (write-farkup) ] "sub" in-tag. ;
 207 M: inline-code (write-farkup) [ child>> (write-farkup) ] "code" in-tag. ;
 208 M: list-item (write-farkup) [ child>> (write-farkup) ] "li" in-tag. ;
 209 M: unordered-list (write-farkup) [ child>> (write-farkup) ] "ul" in-tag. ;
 210 M: ordered-list (write-farkup) [ child>> (write-farkup) ] "ol" in-tag. ;
 211 M: paragraph (write-farkup) [ child>> (write-farkup) ] "p" in-tag. ;
 212 M: link (write-farkup) [ href>> ] [ text>> ] bi write-link ;
 213 M: image (write-farkup) [ href>> ] [ text>> ] bi write-image-link ;
 214 M: code (write-farkup) [ string>> ] [ mode>> ] bi render-code ;
 215 M: line (write-farkup) drop <hr/> ;
 216 M: line-break (write-farkup) drop <br/> nl ;
 217 M: table-row (write-farkup) ( obj -- )
 218     child>> [ [ [ (write-farkup) ] "td" in-tag. ] each ] "tr" in-tag. ;
 219 M: table (write-farkup) [ child>> (write-farkup) ] "table" in-tag. ;
 220 M: string (write-farkup) escape-string write ;
 221 M: vector (write-farkup) [ (write-farkup) ] each ;
 222 M: f (write-farkup) drop ;
 223
 224 : write-farkup ( string -- )
 225     parse-farkup (write-farkup) ;
 226
 227 : convert-farkup ( string -- string' )
 228     parse-farkup [ (write-farkup) ] with-string-writer ;