xmlbf-0.4.1: test/Test.hs
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Main where
import Debug.Trace
import Control.Applicative (many, liftA2)
import qualified Control.Monad.Trans.State as S
import qualified Data.ByteString as B
import qualified Data.ByteString.Builder as BB
import qualified Data.ByteString.Lazy as BL
import qualified Data.HashMap.Strict as HM
import Data.Either (isLeft)
import qualified Data.Text as T
import qualified Test.Tasty as Tasty
import qualified Test.Tasty.Runners as Tasty
import Test.Tasty.QuickCheck ((===))
import qualified Test.Tasty.QuickCheck as QC
import qualified Test.Tasty.HUnit as HU
import Test.Tasty.HUnit ((@?=), (@=?))
import qualified Test.QuickCheck.Instances ()
import qualified Xmlbf as X
--------------------------------------------------------------------------------
main :: IO ()
main = Tasty.defaultMainWithIngredients
[ Tasty.consoleTestReporter
, Tasty.listingTests
] tt_main
--------------------------------------------------------------------------------
tt_main :: Tasty.TestTree
tt_main = Tasty.testGroup "main"
[ tt_element
, tt_encoding
, tt_parsing
, tt_fixpoints
]
tt_element :: Tasty.TestTree
tt_element = Tasty.testGroup "element"
[ HU.testCase "empty name" $ do
HU.assert (isLeft (X.element "" [] []))
, HU.testCase "name with leading whitespace" $ do
HU.assert (isLeft (X.element " x" [] []))
, HU.testCase "name with trailing whitespace" $ do
HU.assert (isLeft (X.element "x " [] []))
, HU.testCase "empty attribute" $ do
HU.assert (isLeft (X.element "x" [("","a")] []))
, HU.testCase "attribute with leading whitespace" $ do
HU.assert (isLeft (X.element "x" [(" x","a")] []))
, HU.testCase "attribute with trailing whitespace" $ do
HU.assert (isLeft (X.element "x" [("x ","a")] []))
]
tt_encoding :: Tasty.TestTree
tt_encoding = Tasty.testGroup "Encoding"
[ HU.testCase "" $ do
bsEncode [] @?= ""
, HU.testCase "<x a=\"y\"/>" $ do
let n0 = X.element' "x" [("a","y")] []
bsEncode [n0] @?= "<x a=\"y\"/>"
, HU.testCase "<x a=\"y\" b=\"\"/>" $ do
let n0 = X.element' "x" [("a","y"), ("b","")] []
bsEncode [n0] @?= "<x a=\"y\" b=\"\"/>"
, HU.testCase "<x a=\"y\" b=\"z\"/>" $ do
let n0 = X.element' "x" [("a","y"), ("b","z")] []
bsEncode [n0] @?= "<x a=\"y\" b=\"z\"/>"
, HU.testCase "<x a=\"y\" b=\"z\"></x>" $ do
let n0 = X.element' "x" [("a","y"), ("b","z")] [X.text ""]
bsEncode [n0] @?= "<x a=\"y\" b=\"z\"></x>"
, HU.testCase "<x>foo</x>" $ do
let n0 = X.element' "x" [] [X.text "foo"]
bsEncode [n0] @?= "<x>foo</x>"
, HU.testCase "<x>foobar</x>" $ do
let n0 = X.element' "x" [] [X.text "foo", X.text "bar"]
bsEncode [n0] @?= "<x>foobar</x>"
, HU.testCase "<x><y/></x>" $ do
let n0 = X.element' "x" [] [X.element' "y" [] []]
bsEncode [n0] @?= "<x><y/></x>"
, HU.testCase "<x><y/></x>" $ do
let n0 = X.element' "x" []
[X.text "", X.element' "y" [] [], X.text ""]
bsEncode [n0] @?= "<x><y/></x>"
, HU.testCase "<x><y/><z/></x>" $ do
let n0 = X.element' "x" []
[X.element' "y" [] [], X.element' "z" [] []]
bsEncode [n0] @?= "<x><y/><z/></x>"
, HU.testCase "<x><y>" $ do
let n0 = X.element' "x" [] []
n1 = X.element' "y" [] []
bsEncode [n0,n1] @?= "<x/><y/>"
]
--------------------------------------------------------------------------------
tt_parsing :: Tasty.TestTree
tt_parsing = Tasty.testGroup "Parsing"
[ HU.testCase "endOfInput" $ do
Right () @=? X.runParser X.pEndOfInput []
, HU.testCase "endOfInput: Not end of input yet" $ do
Left "Not end of input yet" @=? X.runParser X.pEndOfInput [X.text "&"]
, HU.testCase "text: empty" $ do
Left "Missing text node" @=? X.runParser X.pText []
, HU.testCase "text: Missing text node" $ do
Left "Missing text node" @=? X.runParser X.pText [X.element' "a" [] []]
, HU.testCase "text" $ do
Right "&" @=? X.runParser X.pText [X.text "&"]
, HU.testCase "text: concat" $ do
Right "&<" @=? X.runParser X.pText
[X.text "&", X.text "", X.text "<"]
, HU.testCase "text: twice" $ do
Left "Missing text node" @=? X.runParser (X.pText >> X.pText)
[X.text "&", X.text "", X.text "<"]
, HU.testCase "element: empty" $ do
Left "Missing element \"x\"" @=? X.runParser (X.pElement "x" (pure ())) []
, HU.testCase "element: Missing element" $ do
Left "Missing element \"x\""
@=? X.runParser (X.pElement "x" (pure ())) [X.element' "y" [] []]
, HU.testCase "element: pure" $ do
Right ()
@=? X.runParser (X.pElement "x" (pure ())) [X.element' "x" [] []]
, HU.testCase "element: leading whitespace" $ do
Right ()
@=? X.runParser (X.pElement "x" (pure ()))
[X.text " \n \t", X.element' "x" [] []]
, HU.testCase "element: text" $ do
Right "ab"
@=? X.runParser (X.pElement "x" X.pText)
[X.element' "x" [] [X.text "a", X.text "b"]]
, HU.testCase "element: nested" $ do
Right ([("a","b")], "z")
@=? X.runParser
(X.pElement "x" (X.pElement "y" (liftA2 (,) X.pAttrs X.pText)))
[X.element' "x" [] [X.element' "y" [("a","b")] [X.text "z"]]]
, HU.testCase "element: nested with leading whitespace" $ do
Right ([("a","b")], "z")
@=? X.runParser
(X.pElement "x" (X.pElement "y" (liftA2 (,) X.pAttrs X.pText)))
[X.text " ", X.element' "x" [] [X.text " ", X.element' "y" [("a","b")] [X.text "z"]]]
, HU.testCase "attr" $ do
Right "a"
@=? X.runParser (X.pElement "x" (X.pAttr "y"))
[X.element' "x" [("y","a"), ("z","b")] []]
, HU.testCase "attr: Missing" $ do
Left "Missing attribute \"y\""
@=? X.runParser (X.pElement "x" (X.pAttr "y")) [X.element' "x" [] []]
, HU.testCase "attrs: empty" $ do
Right []
@=? X.runParser (X.pElement "x" X.pAttrs) [X.element' "x" [] []]
, HU.testCase "attrs" $ do
Right [("y","a"), ("z","b")]
@=? X.runParser (X.pElement "x" X.pAttrs)
[X.element' "x" [("z","b"), ("y","a")] []]
, HU.testCase "read" $ do
Right False @=? X.runParser (X.pRead =<< X.pText) [X.text "False"]
(Left "Can't read as Bool: \"XXXXX\"" :: Either String Bool)
@=? X.runParser (X.pRead =<< X.pText) [X.text "XXXXX"]
]
node0 :: X.Node
node0 =
X.element' "a" []
[ X.element' "b" []
[ X.element' "c" [] []
, X.element' "d" [] [] ]
, X.element' "e" []
[ X.element' "f" [] []
, X.element' "g" [] [] ] ]
fixvisit :: (X.Node -> S.State T.Text [X.Node])
-> (X.Node -> S.State T.Text [X.Node])
fixvisit k n@(X.Element t _ _) = do
S.modify (\ts -> mappend ts t)
pure [n]
tt_fixpoints :: Tasty.TestTree
tt_fixpoints = Tasty.testGroup "fixpoints"
[ HU.testCase "dfpos: depth-first post-order?" $ do
let (ns, ts) = S.runState (X.dfposM fixvisit node0) []
ns @?= [node0]
ts @?= "cdbfgea"
, HU.testCase "dfpos: output single node" $ do
let n0 = X.element' "x" [] [X.text "a", X.text "b"]
f = \k -> \case
X.Text "ab" -> k (X.text "foo")
X.Text "foo" -> k (X.text "FOO")
n -> [n]
n1 = X.element' "x" [] [X.text "FOO"]
[n1] @?= X.dfpos f n0
, HU.testCase "dfpos: output multiple nodes" $ do
let n0 = X.element' "x" [] [X.text "a"]
f = \k -> \case
X.Text "a" -> let ny = X.element' "y" [] [] in [ny, ny] >>= k
X.Element "y" _ _ -> k (X.text "b")
X.Element "x" as cs ->
let nz = X.element' "z" as cs in [nz, X.text "a"] >>= k
n -> [n]
ns1 = [X.element' "z" [] [X.text "bb"], X.text "bb"]
ns1 @?= X.dfpos f n0
, HU.testCase "dfpre: depth-first pre-order?" $ do
let (ns, ts) = S.runState (X.dfpreM fixvisit node0) []
ns @?= [node0]
ts @?= "abcdefg"
, HU.testCase "dfpre: output single node" $ do
let n0 = X.element' "x" [] [X.text "a", X.text "b"]
f = \k -> \case
X.Text "ab" -> k (X.text "foo")
X.Text "foo" -> k (X.text "FOO")
n -> [n]
n1 = X.element' "x" [] [X.text "FOO"]
[n1] @?= X.dfpre f n0
, HU.testCase "dfpre: output multiple nodes" $ do
let n0 = X.element' "x" [] [X.text "a"]
f = \k -> \case
X.Text "a" -> let ny = X.element' "y" [] [] in [ny, ny] >>= k
X.Element "y" _ _ -> k (X.text "b")
X.Element "x" as cs ->
let nz = X.element' "z" as cs in [nz, X.text "a"] >>= k
n -> [n]
ns1 = [X.element' "z" [] [X.text "bb"], X.text "bb"]
ns1 @?= X.dfpre f n0
]
--------------------------------------------------------------------------------
bsEncode :: [X.Node] -> B.ByteString
bsEncode = BL.toStrict . BB.toLazyByteString . X.encode