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