basis/xml/syntax/syntax-tests.factor

   1 ! Copyright (C) 2005, 2009 Daniel Ehrenberg
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: xml io kernel math sequences strings xml.traversal
   4 tools.test math.parser xml.syntax xml.data xml.syntax.private
   5 accessors multiline locals inverse xml.writer splitting classes ;
   6 IN: xml.syntax.tests
   7
   8 ! TAGS test
   9
  10 TAGS: calculate ( tag -- n )
  11
  12 : calc-2children ( tag -- n n )
  13     children-tags first2 [ calculate ] dip calculate ;
  14
  15 TAG: number calculate
  16     children>string string>number ;
  17 TAG: add calculate
  18     calc-2children + ;
  19 TAG: minus calculate
  20     calc-2children - ;
  21 TAG: times calculate
  22     calc-2children * ;
  23 TAG: divide calculate
  24     calc-2children / ;
  25 TAG: neg calculate
  26     children-tags first calculate neg ;
  27
  28 : calc-arith ( string -- n )
  29     string>xml first-child-tag calculate ;
  30
  31 [ 32 ] [
  32     "<math><times><add><number>1</number><number>3</number></add><neg><number>-8</number></neg></times></math>"
  33     calc-arith
  34 ] unit-test
  35
  36 \ calc-arith must-infer
  37
  38 XML-NS: foo http://blah.com
  39
  40 [ T{ name { main "bling" } { url "http://blah.com" } } ] [ "bling" foo ] unit-test
  41
  42 ! XML literals
  43
  44 [ "a" "c" { "a" "c" f } ] [
  45     "<?xml version='1.0'?><x><-a-><b val=<-c->/><-></x>"
  46     string>doc
  47     [ second var>> ]
  48     [ fourth "val" attr var>> ]
  49     [ extract-variables ] tri
  50 ] unit-test
  51
  52 [ {" <?xml version="1.0" encoding="UTF-8"?>
  53 <x>
  54   one
  55   <b val="two"/>
  56   y
  57   <foo/>
  58 </x>"} ] [
  59     [let* | a [ "one" ] c [ "two" ] x [ "y" ]
  60            d [ [XML <-x-> <foo/> XML] ] |
  61         <XML
  62             <x> <-a-> <b val=<-c->/> <-d-> </x>
  63         XML> pprint-xml>string
  64     ]
  65 ] unit-test
  66
  67 [ {" <?xml version="1.0" encoding="UTF-8"?>
  68 <doc>
  69   <item>
  70     one
  71   </item>
  72   <item>
  73     two
  74   </item>
  75   <item>
  76     three
  77   </item>
  78 </doc>"} ] [
  79     "one two three" " " split
  80     [ [XML <item><-></item> XML] ] map
  81     <XML <doc><-></doc> XML> pprint-xml>string
  82 ] unit-test
  83
  84 [ {" <?xml version="1.0" encoding="UTF-8"?>
  85 <x number="3" url="http://factorcode.org/" string="hello" word="drop"/>"} ]
  86 [ 3 f "http://factorcode.org/" "hello" \ drop
  87   <XML <x number=<-> false=<-> url=<-> string=<-> word=<->/> XML>
  88   pprint-xml>string  ] unit-test
  89
  90 [ "<x>3</x>" ] [ 3 [XML <x><-></x> XML] xml>string ] unit-test
  91 [ "<x></x>" ] [ f [XML <x><-></x> XML] xml>string ] unit-test
  92
  93 \ <XML must-infer
  94 [ [XML <-> XML] ] must-infer
  95 [ [XML <foo><-></foo> <bar val=<->/> XML] ] must-infer
  96
  97 [ xml-chunk ] [ [ [XML <foo/> XML] ] first class ] unit-test
  98 [ xml ] [ [ <XML <foo/> XML> ] first class ] unit-test
  99 [ xml-chunk ] [ [ [XML <foo val=<->/> XML] ] third class ] unit-test
 100 [ xml ] [ [ <XML <foo val=<->/> XML> ] third class ] unit-test
 101 [ 1 ] [ [ [XML <foo/> XML] ] length ] unit-test
 102 [ 1 ] [ [ <XML <foo/> XML> ] length ] unit-test
 103
 104 [ "" ] [ [XML XML] concat ] unit-test
 105
 106 USE: inverse
 107
 108 [ "foo" ] [ [XML <a>foo</a> XML] [ [XML <a><-></a> XML] ] undo ] unit-test
 109 [ "foo" ] [ [XML <a bar='foo'/> XML] [ [XML <a bar=<-> /> XML] ] undo ] unit-test
 110 [ "foo" "baz" ] [ [XML <a bar='foo'>baz</a> XML] [ [XML <a bar=<->><-></a> XML] ] undo ] unit-test
 111
 112 : dispatch ( xml -- string )
 113     {
 114         { [ [XML <a><-></a> XML] ] [ "a" prepend ] }
 115         { [ [XML <b><-></b> XML] ] [ "b" prepend ] }
 116         { [ [XML <b val='yes'/> XML] ] [ "byes" ] }
 117         { [ [XML <b val=<->/> XML] ] [ "bno" prepend ] }
 118     } switch ;
 119
 120 [ "apple" ] [ [XML <a>pple</a> XML] dispatch ] unit-test
 121 [ "banana" ] [ [XML <b>anana</b> XML] dispatch ] unit-test
 122 [ "byes" ] [ [XML <b val="yes"/> XML] dispatch ] unit-test
 123 [ "bnowhere" ] [ [XML <b val="where"/> XML] dispatch ] unit-test
 124 [ "baboon" ] [ [XML <b val="something">aboon</b> XML] dispatch ] unit-test
 125 [ "apple" ] [ <XML <a>pple</a> XML> dispatch ] unit-test
 126 [ "apple" ] [ <XML <a>pple</a> XML> body>> dispatch ] unit-test
 127
 128 : dispatch-doc ( xml -- string )
 129     {
 130         { [ <XML <a><-></a> XML> ] [ "a" prepend ] }
 131         { [ <XML <b><-></b> XML> ] [ "b" prepend ] }
 132         { [ <XML <b val='yes'/> XML> ] [ "byes" ] }
 133         { [ <XML <b val=<->/> XML> ] [ "bno" prepend ] }
 134     } switch ;
 135
 136 [ "apple" ] [ <XML <a>pple</a> XML> dispatch-doc ] unit-test
 137 [ "apple" ] [ [XML <a>pple</a> XML] dispatch-doc ] unit-test
 138 [ "apple" ] [ <XML <a>pple</a> XML> body>> dispatch-doc ] unit-test