extra/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 io.streams.string
   4 kernel math memoize namespaces peg peg.ebnf prettyprint
   5 sequences sequences.deep strings xml.entities vectors splitting
   6 xmode.code2html ;
   7 IN: farkup
   8
   9 SYMBOL: relative-link-prefix
  10 SYMBOL: disable-images?
  11 SYMBOL: link-no-follow?
  12
  13 TUPLE: heading1 obj ;
  14 TUPLE: heading2 obj ;
  15 TUPLE: heading3 obj ;
  16 TUPLE: heading4 obj ;
  17 TUPLE: strong obj ;
  18 TUPLE: emphasis obj ;
  19 TUPLE: superscript obj ;
  20 TUPLE: subscript obj ;
  21 TUPLE: inline-code obj ;
  22 TUPLE: paragraph obj ;
  23 TUPLE: list-item obj ;
  24 TUPLE: list obj ;
  25 TUPLE: table obj ;
  26 TUPLE: table-row obj ;
  27 TUPLE: link href text ;
  28 TUPLE: image href text ;
  29 TUPLE: code mode string ;
  30
  31 EBNF: farkup
  32 nl               = ("\r\n" | "\r" | "\n") => [[ drop "\n" ]]
  33 2nl              = nl nl
  34
  35 heading1      = "=" (!("=" | nl).)+ "="
  36     => [[ second >string heading1 boa ]]
  37
  38 heading2      = "==" (!("=" | nl).)+ "=="
  39     => [[ second >string heading2 boa ]]
  40
  41 heading3      = "===" (!("=" | nl).)+ "==="
  42     => [[ second >string heading3 boa ]]
  43
  44 heading4      = "====" (!("=" | nl).)+ "===="
  45     => [[ second >string heading4 boa ]]
  46
  47 strong        = "*" (!("*" | nl).)+ "*"
  48     => [[ second >string strong boa ]]
  49
  50 emphasis      = "_" (!("_" | nl).)+ "_"
  51     => [[ second >string emphasis boa ]]
  52
  53 superscript   = "^" (!("^" | nl).)+ "^"
  54     => [[ second >string superscript boa ]]
  55
  56 subscript     = "~" (!("~" | nl).)+ "~"
  57     => [[ second >string subscript boa ]]
  58
  59 inline-code   = "%" (!("%" | nl).)+ "%"
  60     => [[ second >string inline-code boa ]]
  61
  62 escaped-char  = "\" .                => [[ second ]]
  63
  64 image-link       = "[[image:" (!("|") .)+  "|" (!("]]").)+ "]]"
  65                     => [[ [ second >string ] [ fourth >string ] bi image boa ]]
  66                   | "[[image:" (!("]").)+ "]]"
  67                     => [[ second >string f image boa ]]
  68
  69 simple-link      = "[[" (!("|]" | "]]") .)+ "]]"
  70     => [[ second >string dup link boa ]]
  71
  72 labelled-link    = "[[" (!("|") .)+ "|" (!("]]").)+ "]]"
  73     => [[ [ second >string ] [ fourth >string ] bi link boa ]]
  74
  75 link             = image-link | labelled-link | simple-link
  76
  77 heading          = heading4 | heading3 | heading2 | heading1
  78
  79 inline-tag       = strong | emphasis | superscript | subscript | inline-code
  80                    | link | escaped-char
  81
  82 inline-delimiter = '*' | '_' | '^' | '~' | '%' | '\' | '['
  83
  84 table-column     = (list | (!(nl | inline-delimiter | '|').)+ | inline-tag | inline-delimiter  ) '|'
  85     => [[ first ]]
  86 table-row        = "|" (table-column)+
  87     => [[ second table-row boa ]]
  88 table            =  ((table-row nl => [[ first ]] )+ table-row? | table-row)
  89     => [[ table boa ]]
  90
  91 paragraph-item = ( table | (!(nl | code | heading | inline-delimiter | table ).) | inline-tag | inline-delimiter)+
  92 paragraph = ((paragraph-item nl => [[ first ]])+ nl+ => [[ first ]]
  93              | (paragraph-item nl)+ paragraph-item?
  94              | paragraph-item)
  95     => [[ paragraph boa ]]
  96
  97 list-item      = '-' ((!(inline-delimiter | nl).)+ | inline-tag)*
  98     => [[ second list-item boa ]]
  99 list = ((list-item nl)+ list-item? | list-item)
 100     => [[ list boa ]]
 101
 102 code       =  '[' (!('{' | nl | '[').)+ '{' (!("}]").)+ "}]"
 103     => [[ [ second >string ] [ fourth >string ] bi code boa ]]
 104
 105 stand-alone      = (code | heading | list | table | paragraph | nl)*
 106 ;EBNF
 107
 108
 109
 110 : invalid-url "javascript:alert('Invalid URL in farkup');" ;
 111
 112 : check-url ( href -- href' )
 113     {
 114         { [ dup empty? ] [ drop invalid-url ] }
 115         { [ dup [ 127 > ] contains? ] [ drop invalid-url ] }
 116         { [ dup first "/\\" member? ] [ drop invalid-url ] }
 117         { [ CHAR: : over member? ] [
 118             dup { "http://" "https://" "ftp://" } [ head? ] with contains?
 119             [ drop invalid-url ] unless
 120         ] }
 121         [ relative-link-prefix get prepend ]
 122     } cond ;
 123
 124 : escape-link ( href text -- href-esc text-esc )
 125     >r check-url escape-quoted-string r> escape-string ;
 126
 127 : write-link ( text href -- )
 128     escape-link
 129     "<a" write
 130     " href=\"" write write "\"" write
 131     link-no-follow? get [ " nofollow=\"true\"" write ] when
 132     ">" write write "</a>" write ;
 133
 134 : write-image-link ( href text -- )
 135     disable-images? get [
 136         2drop "<strong>Images are not allowed</strong>" write
 137     ] [
 138         escape-link
 139         >r "<img src=\"" write write "\"" write r>
 140         dup empty? [ drop ] [ " alt=\"" write write "\"" write ] if
 141         "/>" write
 142     ] if ;
 143
 144 : render-code ( string mode -- string' )
 145     >r string-lines r>
 146     [
 147         <pre>
 148             htmlize-lines
 149         </pre>
 150     ] with-string-writer write ;
 151
 152 GENERIC: write-farkup ( obj -- )
 153 : <foo.> ( string -- ) <foo> write ;
 154 : </foo.> ( string -- ) </foo> write ;
 155 : in-tag. ( obj quot string -- ) [ <foo.> call ] keep </foo.> ; inline
 156 M: heading1 write-farkup ( obj -- ) [ obj>> write-farkup ] "h1" in-tag. ;
 157 M: heading2 write-farkup ( obj -- ) [ obj>> write-farkup ] "h2" in-tag. ;
 158 M: heading3 write-farkup ( obj -- ) [ obj>> write-farkup ] "h3" in-tag. ;
 159 M: heading4 write-farkup ( obj -- ) [ obj>> write-farkup ] "h4" in-tag. ;
 160 M: strong write-farkup ( obj -- ) [ obj>> write-farkup ] "strong" in-tag. ;
 161 M: emphasis write-farkup ( obj -- ) [ obj>> write-farkup ] "em" in-tag. ;
 162 M: superscript write-farkup ( obj -- ) [ obj>> write-farkup ] "sup" in-tag. ;
 163 M: subscript write-farkup ( obj -- ) [ obj>> write-farkup ] "sub" in-tag. ;
 164 M: inline-code write-farkup ( obj -- ) [ obj>> write-farkup ] "code" in-tag. ;
 165 M: list-item write-farkup ( obj -- ) [ obj>> write-farkup ] "li" in-tag. ;
 166 M: list write-farkup ( obj -- ) [ obj>> write-farkup ] "ul" in-tag. ;
 167 M: paragraph write-farkup ( obj -- ) [ obj>> write-farkup ] "p" in-tag. ;
 168 M: link write-farkup ( obj -- ) [ text>> ] [ href>> ] bi write-link ;
 169 M: image write-farkup ( obj -- ) [ href>> ] [ text>> ] bi write-image-link ;
 170 M: code write-farkup ( obj -- ) [ string>> ] [ mode>> ] bi render-code ;
 171 M: table-row write-farkup ( obj -- )
 172     obj>> [ [ [ write-farkup ] "td" in-tag. ] each ] "tr" in-tag. ;
 173 M: table write-farkup ( obj -- ) [ obj>> write-farkup ] "table" in-tag. ;
 174 M: fixnum write-farkup ( obj -- ) write1 ;
 175 M: string write-farkup ( obj -- ) write ;
 176 M: vector write-farkup ( obj -- ) [ write-farkup ] each ;
 177 M: f write-farkup ( obj -- ) drop ;
 178
 179 : convert-farkup ( string -- string' )
 180     farkup [ write-farkup ] with-string-writer ;