{-# Language CPP, FlexibleContexts, TypeFamilies, KindSignatures, TemplateHaskell, GADTs, RankNTypes, MagicHash, ConstraintKinds, PolyKinds #-}
#if __GLASGOW_HASKELL__ < 806
{-# Language TypeInType #-}
#endif
#if __GLASGOW_HASKELL__ >= 807
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
#endif
#if MIN_VERSION_template_haskell(2,21,0)
{-# Language TypeAbstractions #-}
#endif
#if MIN_VERSION_template_haskell(2,18,0)
{-# LANGUAGE UnliftedDatatypes #-}
#endif
{-|
Module : Main
Description : Test cases for the th-abstraction package
Copyright : Eric Mertens 2017
License : ISC
Maintainer : emertens@gmail.com
This module checks that the 'reifyDatatype' logic works consistently
across a wide range of datatypes. These tests are validated across
the versions of GHC supported by this package.
-}
module Main (main) where
import Control.Monad (unless, when, zipWithM_)
import qualified Data.Map as Map
import Data.Kind
import Data.Type.Equality ((:~:)(..))
#if __GLASGOW_HASKELL__ >= 810
import GHC.Exts (Any, RuntimeRep(..), TYPE)
#endif
#if __GLASGOW_HASKELL__ >= 902
import GHC.Exts (UnliftedType, Levity(..))
#endif
import GHC.Exts (Array#)
import qualified Language.Haskell.TH as TH (Type)
import Language.Haskell.TH hiding (Type)
import Language.Haskell.TH.Datatype as Datatype
import Language.Haskell.TH.Datatype.TyVarBndr
import Language.Haskell.TH.Lib (starK)
import Harness
import Types
-- | Test entry point. Tests will pass or fail at compile time.
main :: IO ()
main =
do adt1Test
gadt1Test
gadt2Test
gadtrec1Test
equalTest
showableTest
recordTest
voidstosTest
strictDemoTest
recordVanillaTest
t43Test
t58Test
dataFamilyTest
ghc78bugTest
quotedTest
polyTest
gadtFamTest
famLocalDecTest1
famLocalDecTest2
recordFamTest
t46Test
t73Test
t95Test
fixityLookupTest
resolvePredSynonymsTest
reifyDatatypeWithConNameTest
reifyConstructorTest
importedEqualityTest
kindSubstTest
t59Test
t61Test
t66Test
t80Test
t79TestA
#if MIN_VERSION_template_haskell(2,19,0)
t79TestB
#endif
t37Test
polyKindedExTyvarTest
#if __GLASGOW_HASKELL__ >= 807
resolveTypeSynonymsVKATest
#endif
regressionTest44
t63Test
t70Test
t88Test
captureAvoidanceTest
#if MIN_VERSION_template_haskell(2,20,0)
t100Test
#endif
#if MIN_VERSION_template_haskell(2,21,0)
t103Test
#endif
#if __GLASGOW_HASKELL__ >= 810
t107Test
t108Test
#endif
#if __GLASGOW_HASKELL__ >= 804
t110Test
#endif
#if MIN_VERSION_template_haskell(2,16,0)
unboxedTupleTest
#endif
#if MIN_VERSION_template_haskell(2,18,0)
unliftedGADTDecTest
#endif
primTyConTest
adt1Test :: IO ()
adt1Test =
$(do info <- reifyDatatype ''Adt1
let names = map mkName ["a","b"]
[aTvb,bTvb] = map (\v -> kindedTV v starK) names
vars@[aVar,bVar] = map (VarT . mkName) ["a","b"]
[aSig,bSig] = map (\v -> SigT v starK) vars
validateDI info
DatatypeInfo
{ datatypeName = ''Adt1
, datatypeContext = []
, datatypeVars = [aTvb,bTvb]
, datatypeInstTypes = [aSig, bSig]
, datatypeVariant = Datatype
, datatypeReturnKind = starK
, datatypeCons =
[ ConstructorInfo
{ constructorName = 'Adtc1
, constructorContext = []
, constructorVars = []
, constructorFields = [AppT (AppT (TupleT 2) aVar) bVar]
, constructorStrictness = [notStrictAnnot]
, constructorVariant = NormalConstructor }
, ConstructorInfo
{ constructorName = 'Adtc2
, constructorContext = []
, constructorVars = []
, constructorFields = [ConT ''Bool, ConT ''Int]
, constructorStrictness = [notStrictAnnot, notStrictAnnot]
, constructorVariant = InfixConstructor }
]
}
)
gadt1Test :: IO ()
gadt1Test =
$(do info <- reifyDatatype ''Gadt1
let a = mkName "a"
aVar = VarT a
validateDI info
DatatypeInfo
{ datatypeName = ''Gadt1
, datatypeContext = []
, datatypeVars = [kindedTV a starK]
, datatypeInstTypes = [SigT aVar starK]
, datatypeVariant = Datatype
, datatypeReturnKind = starK
, datatypeCons =
[ ConstructorInfo
{ constructorName = 'Gadtc1
, constructorVars = []
, constructorContext = [equalPred aVar (ConT ''Int)]
, constructorFields = [ConT ''Int]
, constructorStrictness = [notStrictAnnot]
, constructorVariant = NormalConstructor }
, ConstructorInfo
{ constructorName = 'Gadtc2
, constructorVars = []
, constructorContext = []
, constructorFields = [AppT (AppT (TupleT 2) aVar) aVar]
, constructorStrictness = [notStrictAnnot]
, constructorVariant = NormalConstructor }
, ConstructorInfo
{ constructorName = '(:**:)
, constructorVars = []
, constructorContext = [equalPred aVar (TupleT 0)]
, constructorFields = [ConT ''Bool, ConT ''Char]
, constructorStrictness = [notStrictAnnot, notStrictAnnot]
, constructorVariant = InfixConstructor }
, ConstructorInfo
{ constructorName = '(:!!:)
, constructorVars = []
, constructorContext = [equalPred aVar (ConT ''Double)]
, constructorFields = [ConT ''Char, ConT ''Bool]
, constructorStrictness = [notStrictAnnot, notStrictAnnot]
, constructorVariant = NormalConstructor }
]
}
)
gadtrec1Test :: IO ()
gadtrec1Test =
$(do info <- reifyDatatype ''Gadtrec1
let a = mkName "a"
con = gadtRecVanillaCI
validateDI info
DatatypeInfo
{ datatypeName = ''Gadtrec1
, datatypeContext = []
, datatypeVars = [kindedTV a starK]
, datatypeInstTypes = [SigT (VarT a) starK]
, datatypeVariant = Datatype
, datatypeReturnKind = starK
, datatypeCons =
[ con, con { constructorName = 'Gadtrecc2 } ]
}
)
equalTest :: IO ()
equalTest =
$(do info <- reifyDatatype ''Equal
let names = map mkName ["a","b","c"]
[aTvb,bTvb,cTvb] = map (\v -> kindedTV v starK) names
vars@[aVar,bVar,cVar] = map VarT names
[aSig,bSig,cSig] = map (\v -> SigT v starK) vars
validateDI info
DatatypeInfo
{ datatypeName = ''Equal
, datatypeContext = []
, datatypeVars = [aTvb, bTvb, cTvb]
, datatypeInstTypes = [aSig, bSig, cSig]
, datatypeVariant = Datatype
, datatypeReturnKind = starK
, datatypeCons =
[ ConstructorInfo
{ constructorName = 'Equalc
, constructorVars = []
, constructorContext =
[ equalPred aVar cVar
, equalPred bVar cVar
, classPred ''Read [cVar]
, classPred ''Show [cVar]
]
, constructorFields =
[ListT `AppT` cVar, ConT ''Maybe `AppT` cVar]
, constructorStrictness =
[notStrictAnnot, notStrictAnnot]
, constructorVariant = NormalConstructor }
]
}
)
showableTest :: IO ()
showableTest =
$(do info <- reifyDatatype ''Showable
let a = mkName "a"
validateDI info
DatatypeInfo
{ datatypeName = ''Showable
, datatypeContext = []
, datatypeVars = []
, datatypeInstTypes = []
, datatypeVariant = Datatype
, datatypeReturnKind = starK
, datatypeCons =
[ ConstructorInfo
{ constructorName = 'Showable
, constructorVars = [kindedTV a starK]
, constructorContext = [classPred ''Show [VarT a]]
, constructorFields = [VarT a]
, constructorStrictness = [notStrictAnnot]
, constructorVariant = NormalConstructor }
]
}
)
recordTest :: IO ()
recordTest =
$(do info <- reifyDatatype ''R
validateDI info
DatatypeInfo
{ datatypeName = ''R
, datatypeContext = []
, datatypeVars = []
, datatypeInstTypes = []
, datatypeVariant = Datatype
, datatypeReturnKind = starK
, datatypeCons =
[ ConstructorInfo
{ constructorName = 'R1
, constructorVars = []
, constructorContext = []
, constructorFields = [ConT ''Int, ConT ''Int]
, constructorStrictness = [notStrictAnnot, notStrictAnnot]
, constructorVariant = RecordConstructor ['field1, 'field2] }
]
}
)
gadt2Test :: IO ()
gadt2Test =
$(do info <- reifyDatatype ''Gadt2
let names = map mkName ["a","b"]
[aTvb,bTvb] = map (\v -> kindedTV v starK) names
vars@[aVar,bVar] = map VarT names
[aSig,bSig] = map (\v -> SigT v starK) vars
x = mkName "x"
con = ConstructorInfo
{ constructorName = undefined
, constructorVars = []
, constructorContext = []
, constructorFields = []
, constructorStrictness = []
, constructorVariant = NormalConstructor }
validateDI info
DatatypeInfo
{ datatypeName = ''Gadt2
, datatypeContext = []
, datatypeVars = [aTvb, bTvb]
, datatypeInstTypes = [aSig, bSig]
, datatypeVariant = Datatype
, datatypeReturnKind = starK
, datatypeCons =
[ con { constructorName = 'Gadt2c1
, constructorContext = [equalPred bVar (AppT ListT aVar)] }
, con { constructorName = 'Gadt2c2
, constructorContext = [equalPred aVar (AppT ListT bVar)] }
, con { constructorName = 'Gadt2c3
, constructorVars = [kindedTV x starK]
, constructorContext =
[equalPred aVar (AppT ListT (VarT x))
,equalPred bVar (AppT ListT (VarT x))] } ]
}
)
voidstosTest :: IO ()
voidstosTest =
$(do info <- reifyDatatype ''VoidStoS
let g = mkName "g"
validateDI info
DatatypeInfo
{ datatypeName = ''VoidStoS
, datatypeContext = []
, datatypeVars = [kindedTV g (arrowKCompat starK starK)]
, datatypeInstTypes = [SigT (VarT g) (arrowKCompat starK starK)]
, datatypeVariant = Datatype
, datatypeReturnKind = starK
, datatypeCons = []
}
)
strictDemoTest :: IO ()
strictDemoTest =
$(do info <- reifyDatatype ''StrictDemo
validateDI info
DatatypeInfo
{ datatypeName = ''StrictDemo
, datatypeContext = []
, datatypeVars = []
, datatypeInstTypes = []
, datatypeVariant = Datatype
, datatypeReturnKind = starK
, datatypeCons =
[ ConstructorInfo
{ constructorName = 'StrictDemo
, constructorVars = []
, constructorContext = []
, constructorFields = [ConT ''Int, ConT ''Int, ConT ''Int]
, constructorStrictness = [ notStrictAnnot
, isStrictAnnot
, unpackedAnnot
]
, constructorVariant = NormalConstructor } ]
}
)
recordVanillaTest :: IO ()
recordVanillaTest =
$(do info <- reifyRecord 'gadtrec1a
validateCI info gadtRecVanillaCI)
t43Test :: IO ()
t43Test =
$(do [decPlain] <- [d| data T43Plain where MkT43Plain :: T43Plain |]
infoPlain <- normalizeDec decPlain
validateDI infoPlain
DatatypeInfo
{ datatypeName = mkName "T43Plain"
, datatypeContext = []
, datatypeVars = []
, datatypeInstTypes = []
, datatypeVariant = Datatype
, datatypeReturnKind = starK
, datatypeCons =
[ ConstructorInfo
{ constructorName = mkName "MkT43Plain"
, constructorVars = []
, constructorContext = []
, constructorFields = []
, constructorStrictness = []
, constructorVariant = NormalConstructor } ]
}
[decFam] <- [d| data instance T43Fam where MkT43Fam :: T43Fam |]
infoFam <- normalizeDec decFam
validateDI infoFam
DatatypeInfo
{ datatypeName = mkName "T43Fam"
, datatypeContext = []
, datatypeVars = []
, datatypeInstTypes = []
, datatypeVariant = DataInstance
, datatypeReturnKind = starK
, datatypeCons =
[ ConstructorInfo
{ constructorName = mkName "MkT43Fam"
, constructorVars = []
, constructorContext = []
, constructorFields = []
, constructorStrictness = []
, constructorVariant = NormalConstructor } ]
}
)
t58Test :: IO ()
t58Test =
$(do [dec] <- [d| data Foo where
MkFoo :: a -> Foo |]
info <- normalizeDec dec
let a = mkName "a"
validateDI info
DatatypeInfo
{ datatypeName = mkName "Foo"
, datatypeContext = []
, datatypeVars = []
, datatypeInstTypes = []
, datatypeVariant = Datatype
, datatypeReturnKind = starK
, datatypeCons =
[ ConstructorInfo
{ constructorName = mkName "MkFoo"
, constructorVars = [plainTV a]
, constructorContext = []
, constructorFields = [VarT a]
, constructorStrictness = [notStrictAnnot]
, constructorVariant = NormalConstructor } ]
}
)
dataFamilyTest :: IO ()
dataFamilyTest =
$(do info <- reifyDatatype 'DFMaybe
let a = mkName "a"
validateDI info
DatatypeInfo
{ datatypeName = ''DF
, datatypeContext = []
, datatypeVars = [kindedTV a starK]
, datatypeInstTypes = [AppT (ConT ''Maybe) (VarT a)]
, datatypeVariant = DataInstance
, datatypeReturnKind = starK
, datatypeCons =
[ ConstructorInfo
{ constructorName = 'DFMaybe
, constructorVars = []
, constructorContext = []
, constructorFields = [ConT ''Int, ListT `AppT` VarT a]
, constructorStrictness = [notStrictAnnot, notStrictAnnot]
, constructorVariant = NormalConstructor } ]
}
)
ghc78bugTest :: IO ()
ghc78bugTest =
$(do info <- reifyDatatype 'DF1
let c = mkName "c"
cVar = VarT c
validateDI info
DatatypeInfo
{ datatypeName = ''DF1
, datatypeContext = []
, datatypeVars = [kindedTV c starK]
, datatypeInstTypes = [SigT cVar starK]
, datatypeVariant = DataInstance
, datatypeReturnKind = starK
, datatypeCons =
[ ConstructorInfo
{ constructorName = 'DF1
, constructorVars = []
, constructorContext = []
, constructorFields = [cVar]
, constructorStrictness = [notStrictAnnot]
, constructorVariant = NormalConstructor } ]
}
)
quotedTest :: IO ()
quotedTest =
$(do [dec] <- [d| data instance Quoted a = MkQuoted a |]
info <- normalizeDec dec
let a = mkName "a"
aVar = VarT a
validateDI info
DatatypeInfo
{ datatypeName = mkName "Quoted"
, datatypeContext = []
, datatypeVars = [plainTV a]
, datatypeInstTypes = [aVar]
, datatypeVariant = DataInstance
, datatypeReturnKind = starK
, datatypeCons =
[ ConstructorInfo
{ constructorName = mkName "MkQuoted"
, constructorVars = []
, constructorContext = []
, constructorFields = [aVar]
, constructorStrictness = [notStrictAnnot]
, constructorVariant = NormalConstructor } ]
}
)
polyTest :: IO ()
polyTest =
$(do info <- reifyDatatype 'MkPoly
let [a,k] = map mkName ["a","k"]
kVar = VarT k
validateDI info
DatatypeInfo
{ datatypeName = ''Poly
, datatypeContext = []
, datatypeVars = [kindedTV k starK, kindedTV a kVar]
, datatypeInstTypes = [SigT (VarT a) kVar]
, datatypeVariant = DataInstance
, datatypeReturnKind = starK
, datatypeCons =
[ ConstructorInfo
{ constructorName = 'MkPoly
, constructorVars = []
, constructorContext = []
, constructorFields = []
, constructorStrictness = []
, constructorVariant = NormalConstructor } ]
}
)
gadtFamTest :: IO ()
gadtFamTest =
$(do info <- reifyDatatype 'MkGadtFam1
let names@[c,d,e,q] = map mkName ["c","d","e","q"]
[cTvb,dTvb,eTvb,qTvb] = map (\v -> kindedTV v starK) names
[cTy,dTy,eTy,qTy] = map VarT names
[cSig,dSig] = map (\v -> SigT v starK) [cTy,dTy]
validateDI info
DatatypeInfo
{ datatypeName = ''GadtFam
, datatypeContext = []
, datatypeVars = [cTvb,dTvb]
, datatypeInstTypes = [cSig,dSig]
, datatypeVariant = DataInstance
, datatypeReturnKind = starK
, datatypeCons =
[ ConstructorInfo
{ constructorName = 'MkGadtFam1
, constructorVars = []
, constructorContext = []
, constructorFields = [dTy,cTy]
, constructorStrictness = [notStrictAnnot, notStrictAnnot]
, constructorVariant = NormalConstructor }
, ConstructorInfo
{ constructorName = '(:&&:)
, constructorVars = [kindedTV e starK]
, constructorContext = [equalPred cTy (AppT ListT eTy)]
, constructorFields = [eTy,dTy]
, constructorStrictness = [notStrictAnnot, notStrictAnnot]
, constructorVariant = InfixConstructor }
, ConstructorInfo
{ constructorName = '(:^^:)
, constructorVars = []
, constructorContext = [ equalPred cTy (ConT ''Int)
, equalPred dTy (ConT ''Int)
]
, constructorFields = [ConT ''Int, ConT ''Int]
, constructorStrictness = [notStrictAnnot, notStrictAnnot]
, constructorVariant = NormalConstructor }
, gadtRecFamCI
, ConstructorInfo
{ constructorName = 'MkGadtFam4
, constructorVars = []
, constructorContext = [ equalPred cTy dTy
, equalPred (ConT ''Int) dTy
]
, constructorFields = [dTy]
, constructorStrictness = [notStrictAnnot]
, constructorVariant = NormalConstructor }
, ConstructorInfo
{ constructorName = 'MkGadtFam5
, constructorVars = [kindedTV q starK]
, constructorContext = [ equalPred cTy (ConT ''Bool)
, equalPred dTy (ConT ''Bool)
, equalPred qTy (ConT ''Char)
]
, constructorFields = [qTy]
, constructorStrictness = [notStrictAnnot]
, constructorVariant = NormalConstructor } ]
}
)
famLocalDecTest1 :: IO ()
famLocalDecTest1 =
$(do [dec] <- [d| data instance FamLocalDec1 Int = FamLocalDec1Int { mochi :: Double } |]
info <- normalizeDec dec
validateDI info
DatatypeInfo
{ datatypeName = ''FamLocalDec1
, datatypeContext = []
, datatypeVars = []
, datatypeInstTypes = [ConT ''Int]
, datatypeVariant = DataInstance
, datatypeReturnKind = starK
, datatypeCons =
[ ConstructorInfo
{ constructorName = mkName "FamLocalDec1Int"
, constructorVars = []
, constructorContext = []
, constructorFields = [ConT ''Double]
, constructorStrictness = [notStrictAnnot]
, constructorVariant = RecordConstructor [mkName "mochi"] }]
}
)
famLocalDecTest2 :: IO ()
famLocalDecTest2 =
$(do [dec] <- [d| data instance FamLocalDec2 Int (a, b) a = FamLocalDec2Int { fm0 :: (b, a), fm1 :: Int } |]
info <- normalizeDec dec
let names = map mkName ["a", "b"]
[aTvb,bTvb] = map plainTV names
vars@[aVar,bVar] = map (VarT . mkName) ["a", "b"]
validateDI info
DatatypeInfo
{ datatypeName = ''FamLocalDec2
, datatypeContext = []
, datatypeVars = [aTvb,bTvb]
, datatypeInstTypes = [ConT ''Int, TupleT 2 `AppT` aVar `AppT` bVar, aVar]
, datatypeVariant = DataInstance
, datatypeReturnKind = starK
, datatypeCons =
[ ConstructorInfo
{ constructorName = mkName "FamLocalDec2Int"
, constructorVars = []
, constructorContext = []
, constructorFields = [TupleT 2 `AppT` bVar `AppT` aVar, ConT ''Int]
, constructorStrictness = [notStrictAnnot, notStrictAnnot]
, constructorVariant = RecordConstructor [mkName "fm0", mkName "fm1"] }]
}
)
recordFamTest :: IO ()
recordFamTest =
$(do info <- reifyRecord 'famRec1
validateCI info gadtRecFamCI)
t46Test :: IO ()
t46Test =
$(do info <- reifyDatatype 'MkT46
case info of
DatatypeInfo { datatypeCons = [ConstructorInfo { constructorContext = ctxt }]} ->
unless (null ctxt) (fail "regression test for ticket #46 failed")
_ -> fail "T46 should have exactly one constructor"
[| return () |])
t73Test :: IO ()
t73Test =
$(do info <- reifyDatatype 'MkT73
let b = mkName "b"
bTvb = kindedTV b starK
bVar = VarT b
validateDI info
DatatypeInfo
{ datatypeName = ''T73
, datatypeContext = []
, datatypeVars = [bTvb]
, datatypeInstTypes = [ConT ''Int, SigT bVar starK]
, datatypeVariant = DataInstance
, datatypeReturnKind = starK
, datatypeCons =
[ ConstructorInfo
{ constructorName = 'MkT73
, constructorVars = []
, constructorContext = []
, constructorFields = [bVar]
, constructorStrictness = [notStrictAnnot]
, constructorVariant = NormalConstructor }]
}
)
t95Test :: IO ()
t95Test =
$(do info <- reifyDatatype 'MkT95
let a = mkName "a"
aTvb = kindedTV a starK
aVar = VarT a
validateDI info
DatatypeInfo
{ datatypeName = ''T95
, datatypeContext = []
, datatypeVars = [aTvb]
, datatypeInstTypes = [AppT ListT aVar]
, datatypeVariant = DataInstance
, datatypeReturnKind = starK
, datatypeCons =
[ ConstructorInfo
{ constructorName = 'MkT95
, constructorVars = []
, constructorContext = []
, constructorFields = [aVar]
, constructorStrictness = [notStrictAnnot]
, constructorVariant = NormalConstructor }]
}
)
fixityLookupTest :: IO ()
fixityLookupTest =
$(do Just (Fixity 6 InfixR) <- reifyFixityCompat '(:**:)
[| return () |])
resolvePredSynonymsTest :: IO ()
resolvePredSynonymsTest =
$(do info <- reifyDatatype ''PredSynT
[cxt1,cxt2,cxt3] <- sequence $ map (mapM resolvePredSynonyms . constructorContext)
$ datatypeCons info
let mkTest = zipWithM_ (equateCxt "resolvePredSynonymsTest")
test1 = mkTest cxt1 [classPred ''Show [ConT ''Int]]
test2 = mkTest cxt2 [classPred ''Show [ConT ''Int]]
test3 = mkTest cxt3 [equalPred (ConT ''Int) (ConT ''Int)]
mapM_ (either fail return) [test1,test2,test3]
[| return () |])
reifyDatatypeWithConNameTest :: IO ()
reifyDatatypeWithConNameTest =
$(do info <- reifyDatatype 'Just
let a = mkName "a"
validateDI info
DatatypeInfo
{ datatypeContext = []
, datatypeName = ''Maybe
, datatypeVars = [kindedTV a starK]
, datatypeInstTypes = [SigT (VarT a) starK]
, datatypeVariant = Datatype
, datatypeReturnKind = starK
, datatypeCons =
[ ConstructorInfo
{ constructorName = 'Nothing
, constructorVars = []
, constructorContext = []
, constructorFields = []
, constructorStrictness = []
, constructorVariant = NormalConstructor
}
, justCI
]
}
)
reifyConstructorTest :: IO ()
reifyConstructorTest =
$(do info <- reifyConstructor 'Just
validateCI info justCI)
importedEqualityTest :: IO ()
importedEqualityTest =
$(do info <- reifyDatatype ''(:~:)
let names@[a,b] = map mkName ["a","b"]
[aVar,bVar] = map VarT names
k = mkName "k"
kKind = VarT k
validateDI info
DatatypeInfo
{ datatypeContext = []
, datatypeName = ''(:~:)
, datatypeVars = [ kindedTV k starK
, kindedTV a kKind
, kindedTV b kKind
]
, datatypeInstTypes = [SigT aVar kKind, SigT bVar kKind]
, datatypeVariant = Datatype
, datatypeReturnKind = starK
, datatypeCons =
[ ConstructorInfo
{ constructorName = 'Refl
, constructorVars = []
, constructorContext = [equalPred aVar bVar]
, constructorFields = []
, constructorStrictness = []
, constructorVariant = NormalConstructor } ]
}
)
kindSubstTest :: IO ()
kindSubstTest =
$(do k1 <- newName "k1"
k2 <- newName "k2"
a <- newName "a"
let ty = ForallT [kindedTVSpecified a (VarT k1)] [] (VarT a)
substTy = applySubstitution (Map.singleton k1 (VarT k2)) ty
checkFreeVars :: TH.Type -> [Name] -> Q ()
checkFreeVars t freeVars =
unless (freeVariables t == freeVars) $
fail $ "free variables of " ++ show t ++ " should be " ++ show freeVars
checkFreeVars ty [k1]
checkFreeVars substTy [k2]
[| return () |])
t59Test :: IO ()
t59Test =
$(do k <- newName "k"
a <- newName "a"
let proxyAK = ConT (mkName "Proxy") `AppT` SigT (VarT a) (VarT k)
-- Proxy (a :: k)
expected = ForallT
[plainTVSpecified k, kindedTVSpecified a (VarT k)]
[] proxyAK
actual = quantifyType proxyAK
unless (expected == actual) $
fail $ "quantifyType does not respect dependency order: "
++ unlines [ "Expected: " ++ pprint expected
, "Actual: " ++ pprint actual
]
[| return () |])
t61Test :: IO ()
t61Test =
$(do let test :: TH.Type -> TH.Type -> Q ()
test orig expected = do
actual <- resolveTypeSynonyms orig
unless (expected == actual) $
fail $ "Type synonym expansion failed: "
++ unlines [ "Expected: " ++ pprint expected
, "Actual: " ++ pprint actual
]
idAppT = (ConT ''Id `AppT`)
a = mkName "a"
test (SigT (idAppT $ ConT ''Int) (idAppT starK))
(SigT (ConT ''Int) starK)
test (ForallT [kindedTVSpecified a (idAppT starK)]
[idAppT (ConT ''Show `AppT` VarT a)]
(idAppT $ VarT a))
(ForallT [kindedTVSpecified a starK]
[ConT ''Show `AppT` VarT a]
(VarT a))
test (InfixT (idAppT $ ConT ''Int) ''Either (idAppT $ ConT ''Int))
(InfixT (ConT ''Int) ''Either (ConT ''Int))
test (ParensT (idAppT $ ConT ''Int))
(ConT ''Int)
#if MIN_VERSION_template_haskell(2,19,0)
test (PromotedInfixT (idAppT $ ConT ''Int) '(:^:) (idAppT $ ConT ''Int))
(PromotedInfixT (ConT ''Int) '(:^:) (ConT ''Int))
#endif
[| return () |])
t66Test :: IO ()
t66Test =
$(do [dec] <- [d| data Foo a b :: (* -> *) -> * -> * where
MkFoo :: a -> b -> f x -> Foo a b f x |]
info <- normalizeDec dec
let [a,b,f,x] = map mkName ["a","b","f","x"]
fKind = arrowKCompat starK starK
validateDI info
DatatypeInfo
{ datatypeName = mkName "Foo"
, datatypeContext = []
, datatypeVars = [ plainTV a, plainTV b
, kindedTV f fKind, kindedTV x starK ]
, datatypeInstTypes = [ VarT a, VarT b
, SigT (VarT f) fKind, SigT (VarT x) starK ]
, datatypeVariant = Datatype
, datatypeReturnKind = starK
, datatypeCons =
[ ConstructorInfo
{ constructorName = mkName "MkFoo"
, constructorVars = []
, constructorContext = []
, constructorFields = [VarT a, VarT b, VarT f `AppT` VarT x]
, constructorStrictness = [notStrictAnnot, notStrictAnnot, notStrictAnnot]
, constructorVariant = NormalConstructor } ]
}
)
t80Test :: IO ()
t80Test = do
let [k,a,b] = map mkName ["k","a","b"]
-- forall k (a :: k) (b :: k). ()
t = ForallT [ plainTVSpecified k
, kindedTVSpecified a (VarT k)
, kindedTVSpecified b (VarT k)
] [] (ConT ''())
expected, actual :: [Name]
expected = []
actual = freeVariables t
unless (expected == actual) $
fail $ "Bug in ForallT substitution: "
++ unlines [ "Expected: " ++ pprint expected
, "Actual: " ++ pprint actual
]
return ()
t79TestA :: IO ()
t79TestA =
$(do let [a,b,c] = map mkName ["a","b","c"]
t = ForallT [kindedTVSpecified a (UInfixT (VarT b) ''(:+:) (VarT c))] []
(ConT ''())
expected = ForallT [kindedTVSpecified a (ConT ''(:+:) `AppT` VarT b `AppT` VarT c)] []
(ConT ''())
actual <- resolveInfixT t
unless (expected == actual) $
fail $ "resolveInfixT does not recur into the kinds of "
++ "ForallT type variable binders: "
++ unlines [ "Expected: " ++ pprint expected
, "Actual: " ++ pprint actual
]
[| return () |])
#if MIN_VERSION_template_haskell(2,19,0)
t79TestB :: IO ()
t79TestB =
$(do let [a,b,c] = map mkName ["a","b","c"]
t = ForallT [kindedTVSpecified a (PromotedUInfixT (VarT b) '(:^:) (VarT c))] []
(ConT ''())
expected = ForallT [kindedTVSpecified a (PromotedT '(:^:) `AppT` VarT b `AppT` VarT c)] []
(ConT ''())
actual <- resolveInfixT t
unless (expected == actual) $
fail $ "resolveInfixT does not recur into the kinds of "
++ "ForallT type variable binders: "
++ unlines [ "Expected: " ++ pprint expected
, "Actual: " ++ pprint actual
]
[| return () |])
#endif
t37Test :: IO ()
t37Test =
$(do infoA <- reifyDatatype ''T37a
let names@[k,a] = map mkName ["k","a"]
[kVar,aVar] = map VarT names
kSig = SigT kVar starK
aSig = SigT aVar kVar
kTvb = kindedTV k starK
aTvb = kindedTV a kVar
validateDI infoA
DatatypeInfo
{ datatypeContext = []
, datatypeName = ''T37a
, datatypeVars = [kTvb, aTvb]
, datatypeInstTypes = [kSig, aSig]
, datatypeVariant = Datatype
, datatypeReturnKind = starK
, datatypeCons =
[ ConstructorInfo
{ constructorName = 'MkT37a
, constructorVars = []
, constructorContext = [equalPred kVar (ConT ''Bool)]
, constructorFields = []
, constructorStrictness = []
, constructorVariant = NormalConstructor } ]
}
infoB <- reifyDatatype ''T37b
validateDI infoB
DatatypeInfo
{ datatypeContext = []
, datatypeName = ''T37b
, datatypeVars = [kTvb, aTvb]
, datatypeInstTypes = [aSig]
, datatypeVariant = Datatype
, datatypeReturnKind = starK
, datatypeCons =
[ ConstructorInfo
{ constructorName = 'MkT37b
, constructorVars = []
, constructorContext = [equalPred kVar (ConT ''Bool)]
, constructorFields = []
, constructorStrictness = []
, constructorVariant = NormalConstructor } ]
}
infoC <- reifyDatatype ''T37c
validateDI infoC
DatatypeInfo
{ datatypeContext = []
, datatypeName = ''T37c
, datatypeVars = [kTvb, aTvb]
, datatypeInstTypes = [aSig]
, datatypeVariant = Datatype
, datatypeReturnKind = starK
, datatypeCons =
[ ConstructorInfo
{ constructorName = 'MkT37c
, constructorVars = []
, constructorContext = [equalPred aVar (ConT ''Bool)]
, constructorFields = []
, constructorStrictness = []
, constructorVariant = NormalConstructor } ]
}
)
polyKindedExTyvarTest :: IO ()
polyKindedExTyvarTest =
$(do info <- reifyDatatype ''T48
let [a,x] = map mkName ["a","x"]
aVar = VarT a
validateDI info
DatatypeInfo
{ datatypeContext = []
, datatypeName = ''T48
, datatypeVars = [kindedTV a starK]
, datatypeInstTypes = [SigT aVar starK]
, datatypeVariant = Datatype
, datatypeReturnKind = starK
, datatypeCons =
[ ConstructorInfo
{ constructorName = 'MkT48
, constructorVars = [kindedTV x aVar]
, constructorContext = []
, constructorFields = [ConT ''Prox `AppT` VarT x]
, constructorStrictness = [notStrictAnnot]
, constructorVariant = NormalConstructor } ]
}
-- Because validateCI uses a type variable substitution to normalize
-- away any alpha-renaming differences between constructors, it
-- unfortunately does not check if the uses of `a` in datatypeVars and
-- constructorVars are the same. We perform this check explicitly here.
case info of
DatatypeInfo { datatypeVars = [v1]
, datatypeCons =
[ConstructorInfo { constructorVars = [v2] }] }
| a1 <- tvName v1, starK == tvKind v1, VarT a2 <- tvKind v2
-> unless (a1 == a2) $
fail $ "Two occurrences of the same variable have different names: "
++ show [a1, a2]
[| return () |]
)
t75Test :: IO ()
t75Test =
$(do info <- reifyDatatype ''T75
case datatypeCons info of
[c] -> let datatypeVarTypes = map (VarT . tvName) $ datatypeVars info
constructorVarKinds = map tvKind $ constructorVars c in
unless (datatypeVarTypes == constructorVarKinds) $
fail $ "Mismatch between datatypeVars and constructorVars' kinds: "
++ unlines [ "datatypeVars: "
++ pprint datatypeVarTypes
, "constructorVars' kinds: "
++ pprint constructorVarKinds
]
cs -> fail $ "Unexpected number of constructors for T75: "
++ show (length cs)
[| return () |]
)
#if __GLASGOW_HASKELL__ >= 807
resolveTypeSynonymsVKATest :: IO ()
resolveTypeSynonymsVKATest =
$(do t <- [t| T37b @Bool True |]
t' <- resolveTypeSynonyms t
unless (t == t') $
fail $ "Type synonym expansion breaks with visible kind application: "
++ show [t, t']
[| return () |])
#endif
regressionTest44 :: IO ()
regressionTest44 =
$(do intToInt <- [t| Int -> Int |]
unified <- unifyTypes [intToInt, intToInt]
unless (Map.null unified) (fail "regression test for ticket #44 failed")
[| return () |])
t63Test :: IO ()
t63Test =
$(do a <- newName "a"
b <- newName "b"
t <- newName "T"
let tauType = ArrowT `AppT` VarT a `AppT` (ArrowT `AppT` VarT b
`AppT` (ConT t `AppT` VarT a))
sigmaType = ForallT [plainTVSpecified b] [] tauType
expected = ForallT [plainTVSpecified a, plainTVSpecified b] [] tauType
actual = quantifyType sigmaType
unless (expected == actual) $
fail $ "quantifyType does not collapse consecutive foralls: "
++ unlines [ "Expected: " ++ pprint expected
, "Actual: " ++ pprint actual
]
[| return () |])
t70Test :: IO ()
t70Test =
$(do a <- newName "a"
b <- newName "b"
let [aVar, bVar] = map VarT [a, b]
[aTvb, bTvb] = map plainTV [a, b]
let fvsABExpected = [aTvb, bTvb]
fvsABActual = freeVariablesWellScoped [aVar, bVar]
fvsBAExpected = [bTvb, aTvb]
fvsBAActual = freeVariablesWellScoped [bVar, aVar]
check expected actual =
unless (expected == actual) $
fail $ "freeVariablesWellScoped does not preserve left-to-right order: "
++ unlines [ "Expected: " ++ pprint expected
, "Actual: " ++ pprint actual
]
check fvsABExpected fvsABActual
check fvsBAExpected fvsBAActual
[| return () |])
t88Test :: IO ()
t88Test =
$(do let unexpandedType = ConT ''Id
expected = unexpandedType
actual <- resolveTypeSynonyms (ConT ''Id)
unless (expected == actual) $
fail $ "resolveTypeSynonyms incorrectly expands an undersaturated type synonym: "
++ unlines [ "Expected: " ++ pprint expected
, "Actual: " ++ pprint actual
]
[| return () |])
captureAvoidanceTest :: IO ()
captureAvoidanceTest = do
let a = mkName "a"
b = mkName "b"
subst = Map.singleton b (VarT a)
origTy = ForallT [plainTVSpecified a] [] (VarT b)
substTy = applySubstitution subst origTy
wrongTy = ForallT [plainTVSpecified a] [] (VarT a)
when (substTy == wrongTy) $
fail $ "applySubstitution captures during substitution"
#if MIN_VERSION_template_haskell(2,20,0)
t100Test :: IO ()
t100Test =
$(do let expectedInfo =
DatatypeInfo
{ datatypeName = ''T100
, datatypeContext = []
, datatypeVars = []
, datatypeInstTypes = []
, datatypeVariant = Datatype.TypeData
, datatypeReturnKind = starK
, datatypeCons =
[ ConstructorInfo
{ constructorName = ''MkT100
, constructorContext = []
, constructorVars = []
, constructorFields = []
, constructorStrictness = []
, constructorVariant = NormalConstructor }
]
}
t100Info <- reifyDatatype ''T100
validateDI t100Info expectedInfo
mkT100Info <- reifyDatatype ''MkT100
validateDI mkT100Info expectedInfo
)
#endif
#if MIN_VERSION_template_haskell(2,21,0)
t103Test :: IO ()
t103Test =
$(do [dec] <- [d| data T102 @k (a :: k) |]
info <- normalizeDec dec
let k = mkName "k"
a = mkName "a"
validateDI info
DatatypeInfo
{ datatypeName = mkName "T102"
, datatypeContext = []
, datatypeVars = [plainTV k, kindedTV a (VarT k)]
, datatypeInstTypes = [SigT (VarT a) (VarT k)]
, datatypeVariant = Datatype
, datatypeReturnKind = starK
, datatypeCons = []
}
)
#endif
#if __GLASGOW_HASKELL__ >= 810
t107Test :: IO ()
t107Test =
$(do info <- reifyDatatype ''T107
let r = mkName "r"
validateDI info
DatatypeInfo
{ datatypeName = mkName "T107"
, datatypeContext = []
, datatypeVars = [kindedTV r (ConT ''RuntimeRep)]
, datatypeInstTypes = []
, datatypeVariant = Newtype
, datatypeReturnKind = ConT ''TYPE `AppT` VarT r
, datatypeCons =
[ ConstructorInfo
{ constructorName = mkName "MkT107"
, constructorVars = []
, constructorContext = []
, constructorFields = [ConT ''Any `SigT` (ConT ''TYPE `AppT` VarT r)]
, constructorStrictness = [notStrictAnnot]
, constructorVariant = NormalConstructor
}
]
}
)
t108Test :: IO ()
t108Test =
$(do [dec] <- [d| data T108 :: forall k -> k -> Type where
MkT108 :: forall k (a :: k). T108 k a
|]
info <- normalizeDec dec
let k = mkName "k"
a = mkName "a"
validateDI info
DatatypeInfo
{ datatypeName = mkName "T108"
, datatypeContext = []
, datatypeVars = [plainTV k, kindedTV a (VarT k)]
, datatypeInstTypes = [VarT k, SigT (VarT a) (VarT k)]
, datatypeVariant = Datatype
, datatypeReturnKind = starK
, datatypeCons =
[ ConstructorInfo
{ constructorName = mkName "MkT108"
, constructorVars = []
, constructorContext = []
, constructorFields = []
, constructorStrictness = []
, constructorVariant = NormalConstructor
}
]
}
)
#endif
#if __GLASGOW_HASKELL__ >= 804
t110Test :: IO ()
t110Test =
$(do [dec] <- [d| data T110 :: forall k. k -> Type where
MkT110 :: forall k (a :: k). T110 a
|]
info <- normalizeDec dec
let k = mkName "k"
a = mkName "a"
validateDI info
DatatypeInfo
{ datatypeName = mkName "T110"
, datatypeContext = []
, datatypeVars = [plainTV k, kindedTV a (VarT k)]
, datatypeInstTypes = [SigT (VarT a) (VarT k)]
, datatypeVariant = Datatype
, datatypeReturnKind = starK
, datatypeCons =
[ ConstructorInfo
{ constructorName = mkName "MkT110"
, constructorVars = []
, constructorContext = []
, constructorFields = []
, constructorStrictness = []
, constructorVariant = NormalConstructor
}
]
}
)
#endif
#if MIN_VERSION_template_haskell(2,16,0)
unboxedTupleTest :: IO ()
unboxedTupleTest =
$(do k0 <- newName "k0"
k1 <- newName "k1"
a <- newName "a"
b <- newName "b"
tupleInfo <- reifyDatatype (unboxedTupleTypeName 2)
validateDI tupleInfo
DatatypeInfo
{ datatypeContext = []
, datatypeName = unboxedTupleTypeName 2
, datatypeVars = [kindedTV k0 starK
,kindedTV a (AppT (ConT ''TYPE) (VarT k0 ))
,kindedTV k1 starK
,kindedTV b (AppT (ConT ''TYPE) (VarT k1))]
, datatypeInstTypes = [SigT (VarT a) (AppT (ConT ''TYPE) (VarT k0))
,SigT (VarT b) (AppT (ConT ''TYPE) (VarT k1))]
, datatypeVariant = Datatype
, datatypeReturnKind =
AppT
(ConT ''TYPE)
(AppT
(PromotedT 'TupleRep)
(AppT
(AppT PromotedConsT (VarT k0))
(AppT
(AppT PromotedConsT (VarT k1))
(SigT PromotedNilT (AppT ListT (ConT ''RuntimeRep))))))
, datatypeCons =
[ ConstructorInfo
{ constructorName = unboxedTupleDataName 2
, constructorVars = []
, constructorContext = []
, constructorFields = [VarT a, VarT b]
, constructorStrictness = [notStrictAnnot, notStrictAnnot]
, constructorVariant = NormalConstructor}]
}
)
#endif
#if MIN_VERSION_template_haskell(2,18,0)
unliftedGADTDecTest :: IO ()
unliftedGADTDecTest =
$(do a <- newName "a"
s <- newName "s"
[dec] <- [d| data UnliftedGADT a :: UnliftedType where
UnliftedGADT :: Show s => s -> a -> UnliftedGADT a
|]
info <- normalizeDec dec
validateDI info
DatatypeInfo
{ datatypeContext = []
, datatypeName = mkName "UnliftedGADT"
, datatypeVars = [plainTV a]
, datatypeInstTypes = [VarT a]
, datatypeVariant = Datatype
, datatypeReturnKind = ConT ''TYPE `AppT` (PromotedT 'BoxedRep `AppT` PromotedT 'Unlifted)
, datatypeCons =
[ConstructorInfo
{constructorName = mkName "UnliftedGADT"
, constructorVars = [plainTV s]
, constructorContext = [AppT (ConT ''Show) (VarT s)]
, constructorFields = [VarT s,VarT a]
, constructorStrictness = [notStrictAnnot, notStrictAnnot]
, constructorVariant = NormalConstructor}
]
}
)
#endif
primTyConTest :: IO ()
primTyConTest =
$(do l <- newName "l"
a <- newName "a"
info <- reifyDatatype ''Array#
validateDI info
DatatypeInfo
{ datatypeContext = []
, datatypeName = mkName "Array#"
#if MIN_VERSION_template_haskell(2,19,0)
, datatypeVars = [kindedTV l (ConT ''Levity)
, kindedTV a (ConT ''TYPE `AppT` (PromotedT 'BoxedRep `AppT` VarT l))
]
, datatypeInstTypes = [SigT (VarT a) (ConT ''TYPE `AppT` (PromotedT 'BoxedRep `AppT` VarT l))]
, datatypeReturnKind = ConT ''TYPE `AppT` (PromotedT 'BoxedRep `AppT` PromotedT 'Unlifted)
#elif MIN_VERSION_template_haskell(2,18,0)
, datatypeVars = [ kindedTV a StarT]
, datatypeInstTypes = [SigT (VarT a) StarT]
, datatypeReturnKind = ConT ''TYPE `AppT` (PromotedT 'BoxedRep `AppT` PromotedT 'Unlifted)
#elif MIN_VERSION_template_haskell(2,16,0)
, datatypeVars = [kindedTV a starK]
, datatypeInstTypes = [SigT (VarT a) starK]
, datatypeReturnKind = ConT ''TYPE `AppT` PromotedT 'UnliftedRep
#else
, datatypeVars = [kindedTV a starK]
, datatypeInstTypes = [SigT (VarT a) starK]
, datatypeReturnKind = starK
#endif
, datatypeVariant = Datatype
, datatypeCons = []
}
)