basis/xml/generator/generator.factor

   1 ! Copyright (C) 2006, 2007 Daniel Ehrenberg
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: namespaces kernel xml.data xml.utilities assocs splitting
   4 sequences parser lexer quotations sequences.lib xml.utilities ;
   5 IN: xml.generator
   6
   7 : comment, ( string -- ) <comment> , ;
   8 : directive, ( string -- ) <directive> , ;
   9 : instruction, ( string -- ) <instruction> , ;
  10 : nl, ( -- ) "\n" , ;
  11
  12 : (tag,) ( name attrs quot -- tag )
  13     -rot >r >r V{ } make r> r> rot <tag> ; inline
  14 : tag*, ( name attrs quot -- )
  15     (tag,) , ; inline
  16
  17 : contained*, ( name attrs -- )
  18     f <tag> , ;
  19
  20 : tag, ( name quot -- ) f swap tag*, ; inline
  21 : contained, ( name -- ) f contained*, ; inline
  22
  23 : make-xml* ( name attrs quot -- xml )
  24     (tag,) build-xml ; inline
  25 : make-xml ( name quot -- xml )
  26     f swap make-xml* ; inline
  27
  28 ! Word-based XML literal syntax
  29 : parsed-name ( accum -- accum )
  30     scan ":" split1 [ f <name> ] [ <name-tag> ] if* parsed ;
  31
  32 : run-combinator ( accum quot1 quot2 -- accum )
  33     >r [ ] like parsed r> [ parsed ] each ;
  34
  35 : parse-tag-contents ( accum contained? -- accum )
  36     [ \ contained*, parsed ] [
  37         scan-word \ [ =
  38         [ POSTPONE: [ \ tag*, parsed ]
  39         [ "Expected [ missing" throw ] if
  40     ] if ;
  41
  42 DEFER: >>
  43
  44 : attributes-parsed ( accum quot -- accum )
  45     dup empty? [ drop f parsed ] [
  46         >r \ >r parsed r> parsed
  47         [ H{ } make-assoc r> swap ] [ parsed ] each
  48     ] if ;
  49
  50 : <<
  51     parsed-name [
  52         \ >> parse-until >quotation
  53         attributes-parsed \ contained? get
  54     ] with-scope parse-tag-contents ; parsing
  55
  56 : ==
  57     \ call parsed parsed-name \ set parsed ; parsing
  58
  59 : //
  60     \ contained? on ; parsing
  61
  62 : parse-special ( accum end-token word -- accum )
  63     >r parse-tokens " " join parsed r> parsed ;
  64
  65 : <!-- "-->" \ comment, parse-special ; parsing
  66
  67 : <!  ">" \ directive, parse-special ; parsing
  68
  69 : <? "?>" \ instruction, parse-special ; parsing
  70
  71 : >xml-document ( seq -- xml )
  72     dup first prolog? [ unclip-slice ] [ standard-prolog ] if swap
  73     [ tag? ] split-around <xml> ;
  74
  75 DEFER: XML>
  76
  77 : <XML
  78     \ XML> [ >quotation ] parse-literal
  79     { } parsed \ make parsed \ >xml-document parsed ; parsing