{-# OPTIONS -fno-warn-missing-signatures #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE
EmptyDataDecls
, OverloadedStrings
, ScopedTypeVariables
, TemplateHaskell
, TypeFamilies
#-}
module Main (main) where
import Test.Tasty
import GHC.Generics (Generic)
import Test.Tasty.HUnit
import Test.Tasty.TH
import Text.XML.HXT.Arrow.Pickle
import PickleUtils
import Generics.XmlPickler
data SingleCons = SingleCons deriving (Show, Eq, Generic)
instance XmlPickler SingleCons where xpickle = gxpickle
bidir :: (Show a, Eq a, XmlPickler a) => String -> a -> IO ()
bidir s d = do
eq s (toXML d)
eq (Right d) (eitherFromXML s)
eq (Right d) (encDec d)
encDec :: XmlPickler a => a -> Either String a
encDec = eitherFromXML . toXML
eq :: (Show a, Eq a) => a -> a -> Assertion
eq = (@=?)
case_constructorWithoutFields =
bidir "<singleCons/>" SingleCons
data Record = Record { recordField :: Int } deriving (Show, Eq, Generic)
instance XmlPickler Record where xpickle = gxpickle
case_record =
bidir "<record><recordField>1</recordField></record>" Record { recordField = 1 }
data RecordTwoFields = D { d1 :: Int, d2 :: String } deriving (Show, Eq, Generic)
instance XmlPickler RecordTwoFields where xpickle = gxpickle
case_recordWithFields =
bidir "<d><d1>1</d1><d2>aap</d2></d>" D {d1 = 1, d2 = "aap"}
data E = E Int deriving (Show, Eq, Generic)
instance XmlPickler E where xpickle = gxpickle
case_constructorOneField =
bidir "<e>1</e>" (E 1)
data F = F Int String deriving (Show, Eq, Generic)
instance XmlPickler F where xpickle = gxpickle
--case_constructorWithFields = do
-- bidir "<f>1aap</f>" (F 1 "aap")
data G = G1 Int | G2 String deriving (Show, Eq, Generic)
instance XmlPickler G where xpickle = gxpickle
case_sumConstructorsWithField = do
bidir "<g1>1</g1>" (G1 1)
bidir "<g2>aap</g2>" (G2 "aap")
data H = H1 { h1 :: Int } | H2 { h2 :: String } deriving (Show, Eq, Generic)
instance XmlPickler H where xpickle = gxpickle
case_sumRecord = do
bidir "<h1><h1>1</h1></h1>" H1 { h1 = 1 }
bidir "<h2><h2>aap</h2></h2>" H2 { h2 = "aap" }
data J = J1 { j1 :: Int, j2 :: String } | J2 deriving (Show, Eq, Generic)
instance XmlPickler J where xpickle = gxpickle
case_sumRecordConstructorWithoutFields = do
bidir "<j1><j1>1</j1><j2>aap</j2></j1>" J1 {j1 = 1, j2 = "aap"}
bidir "<j2/>" J2
data L = L1 | L2 Int String deriving (Show, Eq, Generic)
instance XmlPickler L where xpickle = gxpickle
case_sumConstructorWithoutFieldsConstructorWithFields =
bidir "<l1/>" L1
-- bidir "<l2>1aap</l2>" (L2 1 "aap")
data M = M1 | M2 Int M deriving (Show, Eq, Generic)
instance XmlPickler M where xpickle = gxpickle
case_sumConstructorWithoutFieldsConstructorWithRecursiveField = do
let a = M1
let b = M2 1 M1
let c = M2 1 (M2 2 M1)
bidir "<m1/>" a
bidir "<m2>1<m1/></m2>" b
bidir "<m2>1<m2>2<m1/></m2></m2>" c
data N = N1 | N2 { n1 :: Int, n2 :: N } deriving (Show, Eq, Generic)
instance XmlPickler N where xpickle = gxpickle
case_sum_constructorWithoutFields_record = do
bidir "<n1/>" N1
bidir "<n2><n1>1</n1><n2><n1/></n2></n2>" N2 { n1 = 1, n2 = N1 }
bidir "<n2><n1>1</n1><n2><n2><n1>2</n1><n2><n1/></n2></n2></n2></n2>" N2 { n1 = 1, n2 = N2 { n1 = 2, n2 = N1 } }
data O = O { _o :: [Int] } deriving (Show, Eq, Generic)
instance XmlPickler O where xpickle = gxpickle
--case_recordListField =
-- bidir "<o><o>123</o></o>" O {o = [1,2,3]}
data P = P [Int] deriving (Show, Eq, Generic)
instance XmlPickler P where xpickle = gxpickle
--case_constructorListField =
-- bidir "<p>123</p>" (P [1,2,3])
data Q = Q Int Int Int deriving (Show, Eq, Generic)
instance XmlPickler Q where xpickle = gxpickle
--case_ConstructorSameTypedFields =
-- bidir "<q>123</q>" (Q 1 2 3)
data T = T { r1 :: Maybe Int } deriving (Show, Eq, Generic)
instance XmlPickler T where xpickle = gxpickle
case_RecordMaybeField = do
bidir "<t/>" T { r1 = Nothing }
bidir "<t><r1>1</r1></t>" T { r1 = Just 1 }
data V = V1 | V2 | V3 deriving (Show, Eq, Generic)
instance XmlPickler V where xpickle = gxpickle
case_constructorsWithoutFields = do
bidir "<v1/>" V1
bidir "<v2/>" V2
data W = W { underscore1_ :: Int, _underscore2 :: Int } deriving (Show, Eq, Generic)
instance XmlPickler W where xpickle = gxpickle
case_recordWithUnderscoredFields =
bidir "<w><underscore1>1</underscore1><underscore2>2</underscore2></w>" W {underscore1_ = 1, _underscore2 = 2}
data Stat = StatA | StatB (Maybe Prog)
deriving (Eq, Show, Generic)
data Prog = Prog { aff :: Int }
deriving (Eq, Show, Generic)
instance XmlPickler Stat where xpickle = gxpickle
instance XmlPickler Prog where xpickle = gxpickle
case_stat = do
let a = StatB (Just Prog { aff = 1 })
bidir "<statB><prog><aff>1</aff></prog></statB>" a
let b = StatB Nothing
bidir "<statB/>" b
data X = X (Maybe Int) Int deriving (Eq, Show, Generic)
instance XmlPickler X where xpickle = gxpickle
--case_constructorWithMaybeField = do
-- let a = X (Just 1) 2
-- bidir "<x>12</x>" a
--
-- let b = X Nothing 2
-- bidir "<x>2</x>" b
--
-- eq (Left "when expecting a Int, encountered Boolean instead" :: Either String X)
-- (eitherFromXML "[true,2]")
data X1 = X1 { x1a :: Maybe Int, x1b :: Int } deriving (Eq, Show, Generic)
instance XmlPickler X1 where xpickle = gxpickle
case_recordWithMaybeField = do
let a = X1 { x1a = Just 1, x1b = 2 }
bidir "<x1><x1a>1</x1a><x1b>2</x1b></x1>" a
let b = X1 Nothing 2
bidir "<x1><x1b>2</x1b></x1>" b
eq (Nothing :: Maybe X1)
(maybeFromXML "{\"x1a\":true,\"x1b\":2}")
data X2 = X2 { x2 :: Maybe Int }
deriving (Eq, Show, Generic)
instance XmlPickler X2 where xpickle = gxpickle
case_recordWithOnlyOneMaybeField =
bidir "<x2><x2>1</x2></x2>" X2 { x2 = Just 1 }
tests :: TestTree
tests = $testGroupGenerator
main :: IO ()
main = defaultMain $ testGroup "regular-xmlpickler" [tests]