{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Main where
import Control.Applicative (many)
import qualified Data.ByteString as B
import qualified Data.ByteString.Builder as BB
import qualified Data.ByteString.Lazy as BL
import Data.Either (isLeft)
import qualified Data.HashMap.Strict as HM
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
import qualified Xmlbf.XmlHtml as Xx
--------------------------------------------------------------------------------
main :: IO ()
main = Tasty.defaultMainWithIngredients
[ Tasty.consoleTestReporter
, Tasty.listingTests
] tt_main
--------------------------------------------------------------------------------
-- | Like 'X.element' but it crashes if the result is a 'Left'.
el :: T.Text -> [(T.Text, T.Text)] -> [X.Node] -> X.Node
el t as cs = case X.element t (HM.fromList as) cs of
Right x -> x
Left s -> error ("el: Left " ++ show s ++ "\"")
tt_main :: Tasty.TestTree
tt_main =
-- All of the testcases suffixed "-BAD" below are actually undesired results
-- provided by xmlhtml. They are kept here as an acknowledgement of this
-- known behavior. See https://github.com/snapframework/xmlhtml/issues/35
Tasty.testGroup "main"
[ HU.testCase "1" $ do
Xx.nodesXml "" @?= Right []
, HU.testCase "2-BAD" $ do
-- Leading whitespace droped :(
-- See https://github.com/snapframework/xmlhtml/issues/35
Xx.nodesXml " " @?= Right []
, HU.testCase "3" $ do
Xx.nodesXml "" @?= Right [el "foo" [] []]
, HU.testCase "4" $ do
Xx.nodesXml "" @?= Right [el "foo" [] []]
, HU.testCase "5-BAD" $ do
-- Leading whitespace droped :(
-- See https://github.com/snapframework/xmlhtml/issues/35
Xx.nodesXml " " @?= Right [el "foo" [] []]
, HU.testCase "6-BAD" $ do
-- Leading whitespace droped :(
-- See https://github.com/snapframework/xmlhtml/issues/35
Xx.nodesXml " " @?= Right [el "foo" [] [], " "]
, HU.testCase "7" $ do
Xx.nodesXml "" @?= Right [el "foo" [("a", "")] []]
, HU.testCase "8" $ do
Xx.nodesXml "" @?= Right [el "foo" [("a", "b")] []]
, HU.testCase "9" $ do
Xx.nodesXml "" @?= Right [el "foo" [("a", "b"), ("c", "")] []]
, HU.testCase "10" $ do
Xx.nodesXml "" @?= Right [el "foo" [("a", "b"), ("c", "d")] []]
, HU.testCase "11" $ do
Xx.nodesXml "bar" @?= Right [el "foo" [("a", "b")] ["bar"]]
, HU.testCase "12" $ do
Xx.nodesXml "" @?= Right [el "foo" [("a", "b")] [el "bar" [] []]]
, HU.testCase "13" $ do
HU.assertBool "should not parse"
(isLeft (Xx.nodesXml ""))
, HU.testCase "14" $ do
HU.assertBool "should not parse"
(isLeft (Xx.nodesXml ""))
, HU.testCase "15" $ do
Xx.nodesXml "<foo/>" @?= Right [""]
, HU.testCase "16" $ do
Xx.nodesXml "<" @?= Right ["<"]
]