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 "vocab: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 ] ]
  30     [ '[ drop _ drop-input t ] ] bi recover ; inline
  31
  32 : well-formed? ( uri -- answer )
  33     [ file>xml ] fails? "not-wf" "valid" ? ;
  34
  35 : test-quots ( test -- result quot )
  36     [ type>> '[ _ ] ]
  37     [ '[ _ uri>> base swap append-path well-formed? ] ] bi ;
  38
  39 : xml-tests ( -- tests )
  40     base "xmltest.xml" append-path file>xml
  41     parse-tests [ test-quots 2array ] map ;
  42
  43 : run-xml-tests ( -- )
  44     xml-tests [ unit-test ] assoc-each ;
  45
  46 : works? ( result quot -- ? )
  47     [ first ] [ call ] bi* = ;
  48
  49 : partition-xml-tests ( -- successes failures )
  50     xml-tests [ first2 works? ] partition ;
  51
  52 : failing-valids ( -- tests )
  53     partition-xml-tests nip [ second first ] map [ type>> "valid" = ] filter ;
  54
  55 [ ] [ partition-xml-tests 2drop ] unit-test