diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,6 +1,12 @@ # Revision history for th-abstraction -## 0.1.1.0 -- +## 0.1.2.0 -- 2017-05-21 + +* Added `arrowKCompat` +* Added workaround for GHC 7.8 data instance eta reduction bug +* Added kind signatures to datatypeVars + +## 0.1.1.0 -- 2017-05-20 * Better matching of constraints generated for GADTs across GHC versions * Added `dataDCompat` diff --git a/src/Language/Haskell/TH/Datatype.hs b/src/Language/Haskell/TH/Datatype.hs --- a/src/Language/Haskell/TH/Datatype.hs +++ b/src/Language/Haskell/TH/Datatype.hs @@ -67,6 +67,7 @@ -- * Backward compatible data definitions , dataDCompat + , arrowKCompat -- * Convenience functions , resolveTypeSynonyms @@ -83,6 +84,7 @@ import Control.Monad (foldM) import GHC.Generics (Generic) import Language.Haskell.TH +import Language.Haskell.TH.Lib (arrowK) -- needed for th-2.4 #if !MIN_VERSION_base(4,8,0) import Control.Applicative (Applicative(..), (<$>)) @@ -146,27 +148,57 @@ normalizeInfo :: Info -> Q DatatypeInfo normalizeInfo (TyConI dec) = normalizeDec dec # if MIN_VERSION_template_haskell(2,11,0) -normalizeInfo (DataConI name _ parent) = reifyParent name parent +normalizeInfo (DataConI name ty parent) = reifyParent name ty parent # else -normalizeInfo (DataConI name _ parent _) = reifyParent name parent +normalizeInfo (DataConI name ty parent _) = reifyParent name ty parent # endif normalizeInfo _ = fail "reifyDatatype: Expected a type constructor" -reifyParent :: Name -> Name -> Q DatatypeInfo -reifyParent con parent = +reifyParent :: Name -> Type -> Name -> Q DatatypeInfo +reifyParent con ty parent = do info <- reify parent case info of TyConI dec -> normalizeDec dec - FamilyI _ instances -> - do instances' <- traverse normalizeDec instances - case find p instances' of - Nothing -> fail "PANIC: reifyParent lost the instance" - Just dec -> return dec + FamilyI dec instances -> + do let instances1 = map (repairInstance dec ty) instances + instances2 <- traverse normalizeDec instances1 + case find p instances2 of + Just inst -> return inst + Nothing -> fail "PANIC: reifyParent lost the instance" + _ -> fail "PANIC: reifyParent unexpected parent" where p info = con `elem` map constructorName (datatypeCons info) +#if (!MIN_VERSION_template_haskell(2,10,0)) && MIN_VERSION_template_haskell(2,9,0) + kindPart (KindedTV _ k) = [k] + kindPart (PlainTV _ ) = [] + countKindVars = length . freeVariables . map kindPart + -- GHC 7.8.4 will eta-reduce data instances. We can find the missing + -- type variables on the data constructor. + repairInstance + (FamilyD _ _ dvars _) + (ForallT tvars _ _) + (NewtypeInstD cx n ts con deriv) = + NewtypeInstD cx n ts' con deriv + where + nparams = length dvars + kparams = countKindVars dvars + ts' = take nparams (drop kparams (ts ++ bndrParams tvars)) + repairInstance + (FamilyD _ _ dvars _) + (ForallT tvars _ _) + (DataInstD cx n ts cons deriv) = + DataInstD cx n ts' cons deriv + where + nparams = length dvars + kparams = countKindVars dvars + ts' = take nparams (drop kparams (ts ++ bndrParams tvars)) +#endif + repairInstance _ _ x = x + + -- | Normalize 'Dec' for a newtype or datatype into a 'DatatypeInfo'. -- Fail in 'Q' otherwise. normalizeDec :: Dec -> Q DatatypeInfo @@ -207,7 +239,10 @@ normalizeDec _ = fail "reifyDatatype: DataD or NewtypeD required" bndrParams :: [TyVarBndr] -> [Type] -bndrParams = map (VarT . tvName) +bndrParams = map $ \bndr -> + case bndr of + KindedTV t k -> SigT (VarT t) k + PlainTV t -> VarT t normalizeDec' :: @@ -580,4 +615,11 @@ (pure (map ConT ds)) #else dataDCompat = dataD +#endif + +arrowKCompat :: Kind -> Kind -> Kind +#if MIN_VERSION_template_haskell(2,8,0) +arrowKCompat x y = arrowK `appK` x `appK` y +#else +arrowKCompat = arrowK #endif diff --git a/test/Harness.hs b/test/Harness.hs --- a/test/Harness.hs +++ b/test/Harness.hs @@ -22,6 +22,10 @@ validate :: DatatypeInfo -> DatatypeInfo -> ExpQ validate x y = either fail (\_ -> [| return () |]) (equateDI x y) +stripOuterSigT :: Type -> Type +stripOuterSigT (SigT t _) = t +stripOuterSigT t = t + -- | If the arguments are equal up to renaming return @'Right' ()@, -- otherwise return a string exlaining the mismatch. equateDI :: DatatypeInfo -> DatatypeInfo -> Either String () @@ -39,7 +43,7 @@ (applySubstitution sub (datatypeContext dat2)) check "datatypeVars" id - (datatypeVars dat1) + (map stripOuterSigT (datatypeVars dat1)) (applySubstitution sub (datatypeVars dat2)) zipWithM_ equateCI diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,4 +1,4 @@ -{-# Language TypeFamilies, KindSignatures, TemplateHaskell, GADTs #-} +{-# Language CPP, PolyKinds, TypeFamilies, KindSignatures, TemplateHaskell, GADTs #-} {-| Module : Main @@ -14,7 +14,6 @@ -} module Main (main) where -import Control.Monad import Language.Haskell.TH import Language.Haskell.TH.Datatype @@ -22,11 +21,11 @@ type Gadt1Int = Gadt1 Int -data Gadt1 a where +data Gadt1 (a :: *) where Gadtc1 :: Int -> Gadt1Int Gadtc2 :: (a,a) -> Gadt1 a -data Adt1 a b = Adtc1 (a,b) | Bool `Adtc2` Int +data Adt1 (a :: *) (b :: *) = Adtc1 (a,b) | Bool `Adtc2` Int data Gadtrec1 a where Gadtrecc1, Gadtrecc2 :: { gadtrec1a :: a, gadtrec1b :: b } -> Gadtrec1 (a,b) @@ -44,9 +43,20 @@ Gadt2c2 :: Gadt2 [a] a Gadt2c3 :: Gadt2 [a] [a] -data family DF a +data family DF (a :: *) data instance DF (Maybe a) = DFMaybe Int [a] +#if MIN_VERSION_template_haskell(2,9,0) +data family DF1 (a :: k) +#elif MIN_VERSION_template_haskell(2,8,0) +data family DF1 a +#else +data family DF1 (a :: *) +#endif +data instance DF1 b = DF1 b + +data VoidStoS (f :: * -> *) + return [] -- segment type declarations above from refiy below -- | Test entry point. Tests will pass or fail at compile time. @@ -54,11 +64,14 @@ main = do adt1Test gadt1Test + gadt2Test gadtrec1Test equalTest showableTest recordTest dataFamilyTest + ghc78bugTest + voidstosTest adt1Test :: IO () adt1Test = @@ -154,7 +167,7 @@ DatatypeInfo { datatypeName = ''Equal , datatypeContext = [] - , datatypeVars = [a,b,c] + , datatypeVars = [a, b, c] , datatypeVariant = Datatype , datatypeCons = [ ConstructorInfo @@ -227,7 +240,7 @@ DatatypeInfo { datatypeName = ''Gadt2 , datatypeContext = [] - , datatypeVars = [a,b] + , datatypeVars = [a, b] , datatypeVariant = Datatype , datatypeCons = [ con { constructorName = 'Gadt2c1 @@ -259,5 +272,39 @@ , constructorContext = [] , constructorFields = [ConT ''Int, ListT `AppT` VarT a] , constructorVariant = NormalConstructor } ] + } + ) + +ghc78bugTest :: IO () +ghc78bugTest = + $(do info <- reifyDatatype 'DF1 + let c = mkName "c" + validate info + DatatypeInfo + { datatypeName = ''DF1 + , datatypeContext = [] + , datatypeVars = [VarT c] + , datatypeVariant = DataInstance + , datatypeCons = + [ ConstructorInfo + { constructorName = 'DF1 + , constructorVars = [] + , constructorContext = [] + , constructorFields = [VarT c] + , constructorVariant = NormalConstructor } ] + } + ) + +voidstosTest :: IO () +voidstosTest = + $(do info <- reifyDatatype ''VoidStoS + let g = mkName "g" + validate info + DatatypeInfo + { datatypeName = ''VoidStoS + , datatypeContext = [] + , datatypeVars = [VarT g] + , datatypeVariant = Datatype + , datatypeCons = [] } ) diff --git a/th-abstraction.cabal b/th-abstraction.cabal --- a/th-abstraction.cabal +++ b/th-abstraction.cabal @@ -1,5 +1,5 @@ name: th-abstraction -version: 0.1.1.0 +version: 0.1.2.0 synopsis: Nicer interface for reified information about data types description: This package normalizes variations in the interface for inspecting datatype information via Template Haskell