{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Main where
import Control.Applicative
import Data.ByteString as BS
import Data.Foldable
import Data.Monoid
import SAX
import Test.Hspec
newtype World = World ByteString deriving (Show, Eq)
data Hello = Hello
{ hHello :: ByteString
, hWorld :: World
, hIsDom :: Bool
, hNonExistent :: [ByteString]
} deriving (Show, Eq)
newtype R r = R (Result r)
instance Eq r => Eq (R r) where
(R (Done a)) == (R (Done b)) = a == b
(R (Fail a)) == (R (Fail b)) = a == b
_ == _ = False
helloXml :: ByteString
helloXml = "Helloand Me world!"
helloParser :: SaxParser Hello
helloParser = do
withTag "f" $ do
withTag "foo" $ do
withTag "bar" $ do
withTag "hello" $ do
hello <- withTag "inner" bytes
skipTag "skipMe"
world <- World . BS.concat <$> some (withTag "world" bytes)
isDom <- (withTag "is_dom" $ pure True) <|> pure False
ne <- many (withTag "fish" bytes)
pure $ Hello hello world isDom ne
skipTagXmls :: [(ByteString, SaxParser ByteString)]
skipTagXmls = fmap (\(x,p) -> ("" <> x, p))
[ ("b", skipTag "a" >> withTag "b" bytes)
, ("b", skipTag "a" >> withTag "b" bytes)
]
atTagXmls :: [(ByteString, SaxParser ByteString, R ByteString)]
atTagXmls = fmap (\(x,p, r) -> ("" <> x, p, r))
[ ("b", atTag "b" bytes, R (Done "b"))
, ("b", atTag "a" $ atTag "b" bytes, R (Done "b"))
, ("cb", atTag "a" $ atTag "b" bytes, R (Done "b"))
, ("", atTag "b" bytes, R (Fail "()"))
, ("b", atTag "b" bytes, R (Done "b"))
, ("cbtrue", atTag "a" $ atTag "c" bytes, R (Done "c"))
, ("cbtrue", atTag "c" bytes, R (Done "true"))
]
main :: IO ()
main = hspec $ do
describe "parser" $ do
it "works" $ do
parseSax helloParser (streamXml helloXml) `shouldSatisfy`
\res -> case res of
(Done r ) -> r == Hello "Hello" (World " world!") False []
_ -> False
describe "skipTag" $ do
for_ skipTagXmls $ \(xml, parser) ->
it (" parses " ++ show xml) $ do
parseSax parser (streamXml xml) `shouldSatisfy` \case
Done _ -> True
_ -> False
describe "atTag" $ do
for_ atTagXmls $ \(xml, parser, result) ->
it (" parses " ++ show xml) $ do
parseSax parser (streamXml xml) `shouldSatisfy` ((==result) . R)