{-# Language CPP, FlexibleContexts, TypeFamilies, KindSignatures, TemplateHaskell, GADTs, RankNTypes, MagicHash #-} #if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE ConstraintKinds #-} #endif #if __GLASGOW_HASKELL__ >= 800 && __GLASGOW_HASKELL__ < 806 {-# Language TypeInType #-} #endif #if __GLASGOW_HASKELL__ >= 807 {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeApplications #-} #endif #if MIN_VERSION_template_haskell(2,8,0) {-# Language PolyKinds #-} #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 #if __GLASGOW_HASKELL__ >= 704 import Control.Monad (zipWithM_) #endif import Control.Monad (unless, when) import qualified Data.Map as Map #if __GLASGOW_HASKELL__ >= 800 import Data.Kind #endif #if MIN_VERSION_base(4,7,0) import Data.Type.Equality ((:~:)(..)) #endif #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 #if MIN_VERSION_template_haskell(2,6,0) t43Test t58Test #endif #if MIN_VERSION_template_haskell(2,7,0) dataFamilyTest ghc78bugTest quotedTest polyTest gadtFamTest famLocalDecTest1 famLocalDecTest2 recordFamTest t46Test t73Test t95Test #endif fixityLookupTest #if __GLASGOW_HASKELL__ >= 704 resolvePredSynonymsTest #endif reifyDatatypeWithConNameTest reifyConstructorTest #if MIN_VERSION_base(4,7,0) importedEqualityTest #endif #if MIN_VERSION_template_haskell(2,8,0) kindSubstTest t59Test t61Test t66Test t80Test #endif #if MIN_VERSION_template_haskell(2,11,0) t79TestA #endif #if MIN_VERSION_template_haskell(2,19,0) t79TestB #endif #if __GLASGOW_HASKELL__ >= 800 t37Test polyKindedExTyvarTest #endif #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) #if MIN_VERSION_template_haskell(2,6,0) 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 } ] } ) #endif #if MIN_VERSION_template_haskell(2,7,0) 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 = varKCompat k validateDI info DatatypeInfo { datatypeName = ''Poly , datatypeContext = [] , datatypeVars = [ #if __GLASGOW_HASKELL__ >= 800 kindedTV k starK, #endif 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 }] } ) #endif fixityLookupTest :: IO () fixityLookupTest = $(do Just (Fixity 6 InfixR) <- reifyFixityCompat '(:**:) [| return () |]) #if __GLASGOW_HASKELL__ >= 704 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 () |]) #endif 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) #if MIN_VERSION_base(4,7,0) importedEqualityTest :: IO () importedEqualityTest = $(do info <- reifyDatatype ''(:~:) let names@[a,b] = map mkName ["a","b"] [aVar,bVar] = map VarT names k = mkName "k" kKind = varKCompat k validateDI info DatatypeInfo { datatypeContext = [] , datatypeName = ''(:~:) , datatypeVars = [ #if __GLASGOW_HASKELL__ >= 800 kindedTV k starK, #endif 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 } ] } ) #endif #if MIN_VERSION_template_haskell(2,8,0) 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 #if __GLASGOW_HASKELL__ >= 800 [plainTVSpecified k, kindedTVSpecified a (VarT k)] #else [kindedTVSpecified a (VarT k)] #endif [] 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) #if MIN_VERSION_template_haskell(2,10,0) 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)) #endif #if MIN_VERSION_template_haskell(2,11,0) test (InfixT (idAppT $ ConT ''Int) ''Either (idAppT $ ConT ''Int)) (InfixT (ConT ''Int) ''Either (ConT ''Int)) test (ParensT (idAppT $ ConT ''Int)) (ConT ''Int) #endif #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 () #endif #if MIN_VERSION_template_haskell(2,11,0) 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 () |]) #endif #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 #if __GLASGOW_HASKELL__ >= 800 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 () |] ) #endif #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 = [] } )