basis/xml/syntax/inverse/inverse.factor

   1 ! Copyright (C) 2005, 2009 Daniel Ehrenberg
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs combinators
   4 combinators.short-circuit inverse kernel namespaces sequences
   5 sequences.generalizations sorting strings unicode xml.data ;
   6 USE: xml.syntax.private ! required but does not reference words
   7 IN: xml.syntax.inverse
   8
   9 : remove-blanks ( seq -- newseq )
  10     [ { [ string? not ] [ [ blank? ] all? not ] } 1|| ] filter ;
  11
  12 GENERIC: >xml ( xml -- tag )
  13 M: xml >xml body>> ;
  14 M: tag >xml ;
  15 M: xml-chunk >xml
  16     remove-blanks
  17     [ length 1 =/fail ]
  18     [ first dup tag? [ fail ] unless ] bi ;
  19 M: object >xml fail ;
  20
  21 : 1chunk ( object -- xml-chunk )
  22     1array <xml-chunk> ;
  23
  24 GENERIC: >xml-chunk ( xml -- chunk )
  25 M: xml >xml-chunk body>> 1chunk ;
  26 M: xml-chunk >xml-chunk ;
  27 M: object >xml-chunk 1chunk ;
  28
  29 GENERIC: [undo-xml] ( xml -- quot )
  30
  31 M: xml [undo-xml]
  32     body>> [undo-xml] '[ >xml @ ] ;
  33
  34 M: xml-chunk [undo-xml]
  35     seq>> [undo-xml] '[ >xml-chunk @ ] ;
  36
  37 : undo-attrs ( attrs -- quot: ( attrs -- ) )
  38     [
  39         [ main>> ] dip dup interpolated?
  40         [ var>> '[ _ attr _ set ] ]
  41         [ '[ _ attr _ =/fail ] ] if
  42     ] { } assoc>map '[ _ cleave ] ;
  43
  44 M: tag [undo-xml] ( tag -- quot: ( tag -- ) )
  45     {
  46         [ name>> main>> '[ name>> main>> _ =/fail ] ]
  47         [ attrs>> undo-attrs ]
  48         [ children>> [undo-xml] '[ children>> @ ] ]
  49     } cleave '[ _ _ _ tri ] ;
  50
  51 : firstn-strong ( seq n -- ... )
  52     [ assure-length ] [ firstn ] 2bi ; inline
  53
  54 M: sequence [undo-xml] ( sequence -- quot: ( seq -- ) )
  55     remove-blanks [ length ] [ [ [undo-xml] ] { } map-as ] bi
  56     '[ remove-blanks _ firstn-strong _ spread ] ;
  57
  58 M: string [undo-xml] ( string -- quot: ( string -- ) )
  59     '[ _ =/fail ] ;
  60
  61 M: xml-data [undo-xml] ( datum -- quot: ( datum -- ) )
  62     '[ _ =/fail ] ;
  63
  64 M: interpolated [undo-xml]
  65     var>> '[ _ set ] ;
  66
  67 : >enum ( assoc -- enum )
  68     ! Assumes keys are 0..n
  69     sort-keys values <enumerated> ;
  70
  71 : undo-xml ( xml -- quot )
  72     [undo-xml] '[ H{ } clone [ _ with-variables ] keep >enum ] ;
  73
  74 \ interpolate-xml 1 [ undo-xml ] define-pop-inverse