extra/html/parser/printer/printer.factor

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