extra/html/parser/printer/printer.factor

   1 USING: accessors assocs combinators html.parser
   2 html.parser.utils io kernel math namespaces sequences strings
   3 unicode.categories ;
   4 IN: html.parser.printer
   5
   6 TUPLE: html-printer ;
   7 TUPLE: text-printer < html-printer ;
   8 TUPLE: src-printer < html-printer ;
   9 TUPLE: html-prettyprinter < html-printer ;
  10
  11 HOOK: print-text-tag html-printer ( tag -- )
  12 HOOK: print-comment-tag html-printer ( tag -- )
  13 HOOK: print-dtd-tag html-printer ( tag -- )
  14 HOOK: print-opening-tag html-printer ( tag -- )
  15 HOOK: print-closing-tag html-printer ( tag -- )
  16
  17 ERROR: unknown-tag-error tag ;
  18
  19 : print-tag ( tag -- )
  20     {
  21         { [ dup name>> text = ] [ print-text-tag ] }
  22         { [ dup name>> comment = ] [ print-comment-tag ] }
  23         { [ dup name>> dtd = ] [ print-dtd-tag ] }
  24         { [ dup [ name>> string? ] [ closing?>> ] bi and ]
  25             [ print-closing-tag ] }
  26         { [ dup name>> string? ]
  27             [ print-opening-tag ] }
  28         [ unknown-tag-error ]
  29     } cond ;
  30
  31 : print-tags ( vector -- ) [ print-tag ] each ;
  32
  33 : html-text. ( vector -- )
  34     T{ text-printer } html-printer [ print-tags ] with-variable ;
  35
  36 : html-src. ( vector -- )
  37     T{ src-printer } html-printer [ print-tags ] with-variable ;
  38
  39 M: text-printer print-opening-tag
  40     name>> "br" = [ nl ] when ;
  41
  42 M: text-printer print-closing-tag
  43     name>> "p" = [ nl ] when ;
  44
  45 M: html-printer print-text-tag ( tag -- )
  46     text>> write ;
  47
  48 M: html-printer print-comment-tag ( tag -- )
  49     "<!--" write text>> write "-->" write ;
  50
  51 M: html-printer print-dtd-tag ( tag -- )
  52     "<!" write text>> write ">" write ;
  53
  54 : print-attributes ( hashtable -- )
  55     [ [ bl write "=" write ] [ ?quote write ] bi* ] assoc-each ;
  56
  57 M: src-printer print-opening-tag ( tag -- )
  58     "<" write
  59     [ name>> write ]
  60     [ attributes>> dup assoc-empty? [ drop ] [ print-attributes ] if ] bi
  61     ">" write ;
  62
  63 M: src-printer print-closing-tag ( tag -- )
  64     "</" write
  65     name>> write
  66     ">" write ;
  67
  68 SYMBOL: tab-width
  69 SYMBOL: #indentations
  70 SYMBOL: tagstack
  71
  72 : prettyprint-html ( vector -- )
  73     [
  74         T{ html-prettyprinter } html-printer set
  75         V{ } clone tagstack set
  76         2 tab-width set
  77         0 #indentations set
  78         print-tags
  79     ] with-scope ;
  80
  81 : tabs ( -- vseq )
  82     tab-width get #indentations get * CHAR: \s <repetition> ;
  83
  84 M: html-prettyprinter print-opening-tag ( tag -- )
  85     name>>
  86     [ tabs write "<" write write ">\n" write ]
  87     ! These tags usually don't have any closing tag associated with them.
  88     [ { "br" "img" } member? [ #indentations inc ] unless ] bi ;
  89
  90 M: html-prettyprinter print-closing-tag ( tag -- )
  91     [ tabs write "</" write name>> write ">\n" write ]
  92     ! These tags usually don't have any closing tag associated with them.
  93     [ { "br" "img" } member? [ #indentations dec ] unless ] bi ;
  94
  95 M: html-prettyprinter print-text-tag ( tag -- )
  96     text>> [ blank? ] trim [ tabs write write "\n" write ] unless-empty ;