basis/xml/tests/xmltest.factor

   1 USING: accessors assocs combinators combinators.smart
   2 continuations fry generalizations io.pathnames kernel macros
   3 sequences stack-checker tools.test xml xml.traversal xml.writer
   4 arrays xml.data ;
   5 IN: xml.tests.suite
   6
   7 TUPLE: xml-test id uri sections description type ;
   8
   9 : >xml-test ( tag -- test )
  10     xml-test new swap {
  11         [ "TYPE" attr >>type ]
  12         [ "ID" attr >>id ]
  13         [ "URI" attr >>uri ]
  14         [ "SECTIONS" attr >>sections ]
  15         [ children>> xml>string >>description ]
  16     } cleave ;
  17
  18 : parse-tests ( xml -- tests )
  19     "TEST" tags-named [ >xml-test ] map ;
  20
  21 CONSTANT: base "vocab:xml/tests/xmltest/"
  22
  23 MACRO: drop-inputs ( quot -- newquot )
  24     infer in>> length '[ _ ndrop ] ;
  25
  26 : fails? ( quot -- ? )
  27     [ drop-outputs f ] [ nip drop-inputs t ] bi-curry recover ; inline
  28
  29 : well-formed? ( uri -- answer )
  30     [ file>xml ] fails? "not-wf" "valid" ? ;
  31
  32 : test-quots ( test -- result quot )
  33     [ type>> '[ _ ] ]
  34     [ '[ _ uri>> base swap append-path well-formed? ] ] bi ;
  35
  36 : xml-tests ( -- tests )
  37     base "xmltest.xml" append-path file>xml
  38     parse-tests [ test-quots 2array ] map ;
  39
  40 : run-xml-tests ( -- )
  41     xml-tests [ unit-test ] assoc-each ;
  42
  43 : works? ( result quot -- ? )
  44     [ first ] [ call( -- result ) ] bi* = ;
  45
  46 : partition-xml-tests ( -- successes failures )
  47     xml-tests [ first2 works? ] partition ;
  48
  49 : failing-valids ( -- tests )
  50     partition-xml-tests nip [ second first ] map [ type>> "valid" = ] filter ;
  51
  52 [ ] [ partition-xml-tests 2drop ] unit-test