1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
|
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
module Test.TH
( thTests
)
where
import Test.Tasty
import Test.Tasty.HUnit
import Control.Monad (when)
import Data.Parameterized.Classes
import Data.Parameterized.NatRepr
import Data.Parameterized.TH.GADT
import GHC.TypeNats
data T1 = A | B | C
$(mkRepr ''T1)
$(mkKnownReprs ''T1)
$(return [])
instance TestEquality T1Repr where
testEquality = $(structuralTypeEquality [t|T1Repr|] [])
deriving instance Show (T1Repr t)
data T2 = T2_1 T1 | T2_2 Nat
$(mkRepr ''T2)
$(mkKnownReprs ''T2)
$(return [])
instance TestEquality T2Repr where
testEquality = $(structuralTypeEquality [t|T2Repr|]
[ (AnyType, [|testEquality|]) ])
deriving instance Show (T2Repr t)
eqTest :: (TestEquality f, Show (f a), Show (f b)) => f a -> f b -> IO ()
eqTest a b =
when (not (isJust (testEquality a b))) $ assertFailure $ show a ++ " /= " ++ show b
neqTest :: (TestEquality f, Show (f a), Show (f b)) => f a -> f b -> IO ()
neqTest a b =
when (isJust (testEquality a b)) $ assertFailure $ show a ++ " == " ++ show b
thTests :: IO TestTree
thTests = testGroup "TH" <$> return
[ testCase "Repr equality test" $ do
-- T1
ARepr `eqTest` ARepr
ARepr `neqTest` BRepr
BRepr `eqTest` BRepr
BRepr `neqTest` CRepr
-- T2
T2_1Repr ARepr `eqTest` T2_1Repr ARepr
T2_2Repr (knownNat @5) `eqTest` T2_2Repr (knownNat @5)
T2_1Repr ARepr `neqTest` T2_1Repr CRepr
T2_2Repr (knownNat @5) `neqTest` T2_2Repr (knownNat @9)
T2_1Repr BRepr `neqTest` T2_2Repr (knownNat @4)
, testCase "KnownRepr test" $ do
-- T1
let aRepr = knownRepr :: T1Repr 'A
bRepr = knownRepr :: T1Repr 'B
cRepr = knownRepr :: T1Repr 'C
aRepr `eqTest` ARepr
bRepr `eqTest` BRepr
cRepr `eqTest` CRepr
--T2
let t2ARepr = knownRepr :: T2Repr ('T2_1 'A)
t2BRepr = knownRepr :: T2Repr ('T2_1 'B)
t25Repr = knownRepr :: T2Repr ('T2_2 5)
t2ARepr `eqTest` T2_1Repr ARepr
t2BRepr `eqTest` T2_1Repr BRepr
t25Repr `eqTest` T2_2Repr (knownNat @5)
t2ARepr `neqTest` t2BRepr
t2ARepr `neqTest` t25Repr
t2BRepr `neqTest` t25Repr
]
|
