basis/xml/tests/xmltest.factor

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