unmaintained/farkup/farkup.factor

   1 ! Copyright (C) 2006 Matthew Willis. All Rights Reserved.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 !
   4 USING: parser-combinators kernel sequences lazy-lists
   5 namespaces strings arrays math io errors ;
   6
   7 IN: farkup
   8 LAZY: <(*)> ( parser -- parser )
   9     ! kleene star matching, but take shortest match first
  10     { } succeed swap dup <(*)> <&:> <|> ;
  11
  12 LAZY: <(+)> ( parser -- parser )
  13     dup <(*)> <&:> ;
  14
  15 LAZY: 'consume1' ( -- parser ) [ CHAR: \n = not ] satisfy ;
  16
  17 LAZY: '\n' ( -- parser ) [ CHAR: \n = ] satisfy ;
  18
  19 : open-tag ( text -- tag ) [ CHAR: < , , CHAR: > , ] { } make ;
  20
  21 : close-tag ( text -- tag ) [ "</" , , CHAR: > , ] { } make ;
  22
  23 : both-tags ( text -- open-tag close-tag ) dup open-tag swap close-tag ;
  24
  25 DEFER: 'inline'
  26 LAZY: simple-tag ( start end html -- parser )
  27      both-tags [ \ drop , , ] [ ] make rot token swap <@ >r
  28      [ \ drop , , ] [ ] make swap token swap <@
  29      'inline' <(+)> <&> r> <&> ;
  30
  31 LAZY: prefix-tag ( pre html -- parser )
  32     >r 'inline' <!*> >r token r> &>
  33     r> both-tags [ swap , \ swap , , \ 3array , ] [ ] make <@ ;
  34
  35 LAZY: 'strong' ( -- parser ) "*" "*" "strong" simple-tag ;
  36
  37 LAZY: 'link' ( -- parser )
  38     "[" token [ drop "<a href=\"" ] <@ 'consume1' <(+)> <&>
  39     "," token [ drop "\">" ] <@ <&>
  40     'consume1' <(+)> <&> "]" token [ drop "</a>" ] <@ <&> ;
  41
  42 LAZY: 'inline' ( -- parser )
  43     'strong'
  44     'link' <|>
  45     'consume1' <|> ;
  46
  47 LAZY: 'h1' ( -- parser ) "=" "h1" prefix-tag ;
  48 LAZY: 'h2' ( -- parser ) "==" "h2" prefix-tag ;
  49 LAZY: 'h3' ( -- parser ) "===" "h3" prefix-tag ;
  50 LAZY: 'h4' ( -- parser ) "====" "h4" prefix-tag ;
  51 LAZY: 'h5' ( -- parser ) "=====" "h5" prefix-tag ;
  52 LAZY: 'h6' ( -- parser ) "======" "h6" prefix-tag ;
  53
  54 LAZY: 'blockquote' ( -- parser ) "[\"" "\"]" "blockquote" simple-tag ;
  55
  56 LAZY: 'block' ( -- parser )
  57     'h6' 'h5' 'h4' 'h3' 'h2' 'h1' <|> <|> <|> <|> <|>
  58     'blockquote' <|>
  59     'inline' <!+> [ "<p>" swap "</p>" 3array ] <@ <|> ;
  60
  61 LAZY: 'farkup' ( -- parser )
  62     'block' '\n' <!+> 'block' <&> <!*> <&> ;
  63
  64 GENERIC: tree-write ( object -- )
  65
  66 PREDICATE: sequence non-leaf dup number? swap string? or not ;
  67 M: non-leaf tree-write ( sequence -- ) [ tree-write ] each ;
  68
  69 M: string tree-write ( string -- ) write ;
  70
  71 M: number tree-write ( char -- ) write1 ;
  72
  73 : farkup ( str -- html )
  74     'farkup' parse dup nil?
  75     [ error ] [ car parse-result-parsed [ tree-write ] string-out ] if ;
  76
  77 ! useful debugging code below
  78
  79 : farkup-backtracks ( wiki -- backtracks )
  80     ! for debugging and optimization only
  81     'farkup' parse list>array length ;
  82
  83 : farkup-parsed ( wiki -- all-parses )
  84     ! for debugging and optimization only
  85     'farkup' parse list>array
  86     [ parse-result-parsed [ tree-write ] string-out ] map ;