basis/farkup/farkup.factor

   1 ! Copyright (C) 2008, 2009 Doug Coleman, Daniel Ehrenberg.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: sequences kernel splitting lists fry accessors assocs math.order
   4 math combinators namespaces urls.encoding xml.syntax xmode.code2html
   5 xml.data arrays strings vectors xml.writer io.streams.string locals
   6 unicode.categories ;
   7 FROM: namespaces => set ;
   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 ! _foo*bar_baz*bing works like <i>foo*bar</i>baz<b>bing</b>
  43 ! I could support overlapping, but there's not a good use case for it.
  44
  45 DEFER: (parse-paragraph)
  46
  47 : parse-paragraph ( string -- seq )
  48     (parse-paragraph) list>array ;
  49
  50 : make-paragraph ( string -- paragraph )
  51     parse-paragraph paragraph boa ;
  52
  53 : cut-half-slice ( string i -- before after-slice )
  54     [ head ] [ 1 + short tail-slice ] 2bi ;
  55
  56 : find-cut ( string quot -- before after delimiter )
  57     dupd find
  58     [ [ cut-half-slice ] [ f ] if* ] dip ; inline
  59
  60 : parse-delimiter ( string delimiter class -- paragraph )
  61     [ '[ _ = ] find-cut drop ] dip
  62     '[ parse-paragraph _ new swap >>child ]
  63     [ (parse-paragraph) ] bi* cons ;
  64
  65 : delimiter-class ( delimiter -- class )
  66     H{
  67         { CHAR: * strong }
  68         { CHAR: _ emphasis }
  69         { CHAR: ^ superscript }
  70         { CHAR: ~ subscript }
  71         { CHAR: % inline-code }
  72     } at ;
  73
  74 : or-simple-title ( ... url title/f quot: ( ... title -- ... title' ) -- ... url title' )
  75     [ "" like dup simple-link-title ] if* ; inline
  76
  77 : parse-link ( string -- paragraph-list )
  78     rest-slice "]]" split1-slice [
  79         "|" split1
  80         [ "image:" ?head ] dip swap
  81         [ [ ] or-simple-title image boa ]
  82         [ [ parse-paragraph ] or-simple-title link boa ] if
  83     ] dip [ (parse-paragraph) cons ] [ 1list ] if* ;
  84
  85 : ?first ( seq -- elt ) 0 swap ?nth ;
  86
  87 : parse-big-link ( before after -- link rest )
  88     dup ?first CHAR: [ =
  89     [ parse-link ]
  90     [ [ CHAR: [ suffix ] [ (parse-paragraph) ] bi* ]
  91     if ;
  92
  93 : escape ( before after -- before' after' )
  94     [ nil ] [ unclip-slice swap [ suffix ] dip (parse-paragraph) ] if-empty ;
  95
  96 : (parse-paragraph) ( string -- list )
  97     [ nil ] [
  98         [ "*_^~%[\\" member? ] find-cut [
  99             {
 100                 { CHAR: [ [ parse-big-link ] }
 101                 { CHAR: \\ [ escape ] }
 102                 [ dup delimiter-class parse-delimiter ]
 103             } case cons
 104         ] [ drop "" like 1list ] if*
 105     ] if-empty ;
 106
 107 : <farkup-state> ( string -- state ) string-lines ;
 108 : look ( state i -- char ) swap first ?nth ;
 109 : done? ( state -- ? ) empty? ;
 110 : take-line ( state -- state' line ) unclip-slice ;
 111
 112 : take-lines ( state char -- state' lines )
 113     dupd '[ ?first _ = not ] find drop
 114     [ cut-slice ] [ f ] if* swap ;
 115
 116 :: (take-until) ( state delimiter accum -- string/f state' )
 117     state empty? [ accum "\n" join f ] [
 118         state unclip-slice :> ( rest first )
 119         first delimiter split1 :> ( before after )
 120         before accum push
 121         after [
 122             accum "\n" join
 123             rest after prefix
 124         ] [
 125             rest delimiter accum (take-until)
 126         ] if
 127     ] if ;
 128
 129 : take-until ( state delimiter -- string state'/f )
 130     V{ } clone (take-until) ;
 131
 132 : count= ( string -- n )
 133     dup <reversed> [ [ CHAR: = = not ] find drop 0 or ] bi@ min ;
 134
 135 : trim= ( string -- string' )
 136     [ CHAR: = = ] trim ;
 137
 138 : make-heading ( string class -- heading )
 139     [ trim= parse-paragraph ] dip boa ; inline
 140
 141 : parse-heading ( state -- state' heading )
 142     take-line dup count= {
 143         { 0 [ make-paragraph ] }
 144         { 1 [ heading1 make-heading ] }
 145         { 2 [ heading2 make-heading ] }
 146         { 3 [ heading3 make-heading ] }
 147         { 4 [ heading4 make-heading ] }
 148         [ drop heading4 make-heading ]
 149     } case ;
 150
 151 : trim-row ( seq -- seq' )
 152     rest
 153     dup last empty? [ but-last ] when ;
 154
 155 : ?last ( seq -- elt/f )
 156     [ f ] [ last ] if-empty ;
 157
 158 : coalesce ( rows -- rows' )
 159     V{ } clone [
 160         '[
 161             _ dup ?last ?last CHAR: \\ =
 162             [ [ pop "|" rot 3append ] keep ] when
 163             push
 164         ] each
 165     ] keep ;
 166
 167 : parse-table ( state -- state' table )
 168     CHAR: | take-lines [
 169         "|" split
 170         trim-row
 171         coalesce
 172         [ parse-paragraph ] map
 173         table-row boa
 174     ] map table boa ;
 175
 176 : parse-line ( state -- state' item )
 177     take-line dup "___" =
 178     [ drop line new ] [ make-paragraph ] if ;
 179
 180 : parse-list ( state char class -- state' list )
 181     [
 182         take-lines
 183         [ rest parse-paragraph list-item boa ] map
 184     ] dip boa ; inline
 185
 186 : parse-ul ( state -- state' ul )
 187     CHAR: - unordered-list parse-list ;
 188
 189 : parse-ol ( state -- state' ul )
 190     CHAR: # ordered-list parse-list ;
 191
 192 : parse-code ( state -- state' item )
 193     dup 1 look CHAR: [ =
 194     [ take-line make-paragraph ] [
 195         dup "{" take-until [
 196             [ nip rest ] dip
 197             "}]" take-until
 198             [ code boa ] dip swap
 199         ] [ drop take-line make-paragraph ] if*
 200     ] if ;
 201
 202 : parse-item ( state -- state' item )
 203     dup 0 look {
 204         { CHAR: = [ parse-heading ] }
 205         { CHAR: | [ parse-table ] }
 206         { CHAR: _ [ parse-line ] }
 207         { CHAR: - [ parse-ul ] }
 208         { CHAR: # [ parse-ol ] }
 209         { CHAR: [ [ parse-code ] }
 210         { f [ rest-slice f ] }
 211         [ drop take-line make-paragraph ]
 212     } case ;
 213
 214 : parse-farkup ( string -- farkup )
 215     <farkup-state> [ dup done? not ] [ parse-item ] produce nip sift ;
 216
 217 CONSTANT: invalid-url "javascript:alert('Invalid URL in farkup');"
 218
 219 : check-url ( href -- href' )
 220     {
 221         { [ dup empty? ] [ drop invalid-url ] }
 222         { [ dup [ 127 > ] any? ] [ drop invalid-url ] }
 223         { [ dup first "/\\" member? ] [ drop invalid-url ] }
 224         { [ CHAR: : over member? ] [ dup absolute-url? [ drop invalid-url ] unless ] }
 225         [ relative-link-prefix get prepend "" like url-encode ]
 226     } cond ;
 227
 228 : render-code ( string mode -- xml )
 229     [ string-lines ] dip htmlize-lines
 230     [XML <pre><-></pre> XML] ;
 231
 232 GENERIC: (write-farkup) ( farkup -- xml )
 233
 234 : farkup-inside ( farkup name -- xml )
 235     <simple-name> swap T{ attrs } swap
 236     child>> (write-farkup) 1array <tag> ;
 237
 238 M: heading1 (write-farkup) "h1" farkup-inside ;
 239 M: heading2 (write-farkup) "h2" farkup-inside ;
 240 M: heading3 (write-farkup) "h3" farkup-inside ;
 241 M: heading4 (write-farkup) "h4" farkup-inside ;
 242 M: strong (write-farkup) "strong" farkup-inside ;
 243 M: emphasis (write-farkup) "em" farkup-inside ;
 244 M: superscript (write-farkup) "sup" farkup-inside ;
 245 M: subscript (write-farkup) "sub" farkup-inside ;
 246 M: inline-code (write-farkup) "code" farkup-inside ;
 247 M: list-item (write-farkup) "li" farkup-inside ;
 248 M: unordered-list (write-farkup) "ul" farkup-inside ;
 249 M: ordered-list (write-farkup) "ol" farkup-inside ;
 250 M: paragraph (write-farkup) "p" farkup-inside ;
 251 M: table (write-farkup) "table" farkup-inside ;
 252
 253 : write-link ( href text -- xml )
 254     [ check-url link-no-follow? get "nofollow" and ] dip
 255     [XML <a href=<-> rel=<->><-></a> XML] ;
 256
 257 : write-image-link ( href text -- xml )
 258     disable-images? get [
 259         2drop
 260         [XML <strong>Images are not allowed</strong> XML]
 261     ] [
 262         [ check-url ] [ f like ] bi*
 263         [XML <img src=<-> alt=<->/> XML]
 264     ] if ;
 265
 266 : open-link ( link -- href text )
 267     [ href>> ] [ text>> (write-farkup) ] bi ;
 268
 269 M: link (write-farkup)
 270     open-link write-link ;
 271
 272 M: image (write-farkup)
 273     open-link write-image-link ;
 274
 275 M: code (write-farkup)
 276     [ string>> ] [ mode>> ] bi render-code ;
 277
 278 M: line (write-farkup)
 279     drop [XML <hr/> XML] ;
 280
 281 M: line-break (write-farkup)
 282     drop [XML <br/> XML] ;
 283
 284 M: table-row (write-farkup)
 285     child>>
 286     [ (write-farkup) [XML <td><-></td> XML] ] map
 287     [XML <tr><-></tr> XML] ;
 288
 289 M: string (write-farkup) ;
 290
 291 M: array (write-farkup) [ (write-farkup) ] map ;
 292
 293 : farkup>xml ( string -- xml )
 294     parse-farkup (write-farkup) ;
 295
 296 : write-farkup ( string -- )
 297     farkup>xml write-xml ;
 298
 299 : convert-farkup ( string -- string' )
 300     [ write-farkup ] with-string-writer ;
 301