xmlbf-0.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 = unsafeElement "x" [("a","y")] []
      bsEncode [n0] @?= "<x a=\"y\"/>"

  , HU.testCase "<x a=\"y\" b=\"\"/>" $ do
      let n0 = unsafeElement "x" [("a","y"), ("b","")] []
      bsEncode [n0] @?= "<x a=\"y\" b=\"\"/>"

  , HU.testCase "<x a=\"y\" b=\"z\"/>" $ do
      let n0 = unsafeElement "x" [("a","y"), ("b","z")] []
      bsEncode [n0] @?= "<x a=\"y\" b=\"z\"/>"

  , HU.testCase "<x a=\"y\" b=\"z\"></x>" $ do
      let n0 = unsafeElement "x" [("a","y"), ("b","z")] [X.Text ""]
      bsEncode [n0] @?= "<x a=\"y\" b=\"z\"></x>"

  , HU.testCase "<x>foo</x>" $ do
      let n0 = unsafeElement "x" [] [X.Text "foo"]
      bsEncode [n0] @?= "<x>foo</x>"

  , HU.testCase "<x>foobar</x>" $ do
      let n0 = unsafeElement "x" [] [X.Text "foo", X.Text "bar"]
      bsEncode [n0] @?= "<x>foobar</x>"

  , HU.testCase "<x><y/></x>" $ do
      let n0 = unsafeElement "x" [] [unsafeElement "y" [] []]
      bsEncode [n0] @?= "<x><y/></x>"

  , HU.testCase "<x><y/></x>" $ do
      let n0 = unsafeElement "x" []
                  [X.Text "", unsafeElement "y" [] [], X.Text ""]
      bsEncode [n0] @?= "<x><y/></x>"

  , HU.testCase "<x><y/><z/></x>" $ do
      let n0 = unsafeElement "x" []
                  [unsafeElement "y" [] [], unsafeElement "z" [] []]
      bsEncode [n0] @?= "<x><y/><z/></x>"

  , HU.testCase "<x><y>" $ do
      let n0 = unsafeElement "x" [] []
          n1 = unsafeElement "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 [unsafeElement "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 ())) [unsafeElement "y" [] []]

  , HU.testCase "element: pure" $ do
      Right ()
         @=? X.runParser (X.pElement "x" (pure ())) [unsafeElement "x" [] []]

  , HU.testCase "element: text" $ do
      Right "ab"
        @=? X.runParser (X.pElement "x" X.pText)
                [unsafeElement "x" [] [X.Text "a", X.Text "b"]]

  , HU.testCase "attr" $ do
      Right "a"
         @=? X.runParser (X.pElement "x" (X.pAttr "y"))
                [unsafeElement "x" [("y","a"), ("z","b")] []]

  , HU.testCase "attr: Missing" $ do
      Left "Missing attribute \"y\" in element \"x\""
         @=? X.runParser (X.pElement "x" (X.pAttr "y")) [unsafeElement "x" [] []]

  , HU.testCase "attrs: empty" $ do
      Right []
         @=? X.runParser (X.pElement "x" X.pAttrs) [unsafeElement "x" [] []]

  , HU.testCase "attrs" $ do
      Right [("y","a"), ("z","b")]
         @=? X.runParser (X.pElement "x" X.pAttrs)
                [unsafeElement "x" [("z","b"), ("y","a")] []]

  , HU.testCase "read" $ do
      Right False @=? X.runParser (X.pRead =<< X.pText) [X.Text "False"]
  ]

tt_fixpoints :: Tasty.TestTree
tt_fixpoints = Tasty.testGroup "fixpoints"
  [ HU.testCase "df: depth-first post-order?" $ do
      let n0 = unsafeElement "a" []
                  [ unsafeElement "b" []
                     [ unsafeElement "c" [] []
                     , unsafeElement "d" [] [] ]
                  , unsafeElement "e" []
                     [ unsafeElement "f" [] []
                     , unsafeElement "g" [] [] ] ]
          f = \k n@(X.Element t _ _) -> S.modify (t:) >> pure [n]
      ["c","d","b","f","g","e","a"] @=? reverse (S.execState (X.dfM f n0) [])
      [n0] @=? S.evalState (X.dfM f n0) []

  , HU.testCase "df: output single node" $ do
      let n0 = unsafeElement "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 = unsafeElement "x" [] [X.Text "FOO"]
      [n1] @=? X.df f n0

  , HU.testCase "df: output multiple nodes" $ do
      let n0 = unsafeElement "x" [] [X.Text "a"]
          f = \k -> \case
             X.Text "a" -> let ny = unsafeElement "y" [] [] in [ny, ny] >>= k
             X.Element "y" _ _ -> k (X.Text "b")
             X.Element "x" as cs  ->
                let nz = unsafeElement "z" as cs in [nz, X.Text "a"] >>= k
             n -> [n]
          ns1 = [unsafeElement "z" [] [X.Text "bb"], X.Text "bb"]
      ns1 @=? X.df f n0
  ]

--------------------------------------------------------------------------------

unsafeElement :: T.Text -> HM.HashMap T.Text T.Text -> [X.Node] -> X.Node
unsafeElement n as cs = case X.element n as cs of
  Right e -> e
  Left e -> error ("unsafeElement: " ++ e)

bsEncode :: [X.Node] -> B.ByteString
bsEncode = BL.toStrict . BB.toLazyByteString . X.encode

{--

instance QC.Arbitrary X.Node where
  arbitrary = QC.frequency
    [ (1, X.Element <$> QC.arbitrary)
    , (50, X.Text <$> QC.arbitrary) ]
  shrink (X.Text t0) = X.Text <$> QC.shrink t0
  shrink (X.Element e0) = X.Element <$> QC.shrink e0

instance QC.Arbitrary X.Element where
  arbitrary = X.Element
    <$> QC.arbitrary
    <*> QC.arbitrary
    <*> QC.arbitrary
  shrink (X.Element n as cs) =
    X.Element <$> QC.shrink n <*> QC.shrink as <*> QC.shrink cs
-}