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