diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,22 @@ # Revision history for th-abstraction +## 0.2.3.0 -- 2017-06-26 + +* Add `resolvePredSynonyms` +* Add `reifyConstructor`, which allows reification of `ConstructorInfo` from + a constructor name, and `lookupByConstructorName`, which allows directly + looking up a `ConstructorInfo` from a `DatatypeInfo` value for a given + constructor `Name`. +* Augment `reifyDatatype` to be able to look up `DatatypeInfo` from the `Name` + of a record selector for one of its constructors. Also add `reifyRecord` for + reification of of `ConstructorInfo` from a record name, and + `lookupByRecordName`, which allows directly looking up a `ConstructorInfo` + from a `DatatypeInfo` value for a given record `Name`. +* Fix bug that caused `th-abstraction` to fail on GHC 7.0 and 7.2 when passing + a vanilla constructor name to `reifyDatatype` +* Make `normalizeDec` and `normalizeCon` more robust with respect to + data family instances on GHC 7.6 and 7.8 + ## 0.2.2.0 -- 2017-06-10 * Fix `freeVariables` on lists not not produce duplicates. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -6,9 +6,9 @@ This package provides a consistent interface to a subset of Template Haskell. Currently the package provides a consistent view of the reified declaration -information about datatypes, newtypes, data families, and newtype families. -These interfaces abstract away the differences in the normal and GADT syntax -used to define these types. +information about datatypes, newtypes, and data family instances. These +interfaces abstract away the differences in the normal and GADT syntax used to +define these types. Contact Information ------------------- 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 @@ -63,10 +63,16 @@ -- * Normalization functions , reifyDatatype + , reifyConstructor + , reifyRecord , normalizeInfo , normalizeDec , normalizeCon + -- * 'DatatypeInfo' lookup functions + , lookupByConstructorName + , lookupByRecordName + -- * Type variable manipulation , TypeSubstitution(..) , quantifyType @@ -89,6 +95,7 @@ -- * Type simplification , resolveTypeSynonyms + , resolvePredSynonyms , resolveInfixT -- * Fixities @@ -260,8 +267,13 @@ -- -- This function will accept any constructor (value or type) for a type -- declared with newtype or data. Value constructors must be used to --- lookup datatype information about /data instances/ and /newtype instances/. +-- lookup datatype information about /data instances/ and /newtype instances/, +-- as giving the type constructor of a data family is often not enough to +-- determine a particular data family instance. -- +-- In addition, this function will also accept a record selector for a +-- data type with a constructor which uses that record. +-- -- GADT constructors are normalized into datatypes with explicit equality -- constraints. Note that no effort is made to distinguish between equalities of -- the same (homogeneous) kind and equalities between different (heterogeneous) @@ -281,7 +293,7 @@ -- @ -- -- But only the first equality constraint is well kinded, since in the second --- constraint, the kinds of (a :: k -> *) and (Maybe :: * -> *) are different. +-- constraint, the kinds of @(a :: k -> *)@ and @(Maybe :: * -> *)@ are different. -- Trying to categorize which constraints need homogeneous or heterogeneous -- equality is tricky, so we leave that task to users of this library. -- @@ -289,18 +301,61 @@ -- @template-haskell@ library in order to provide a view of datatypes in -- as uniform a way as possible. reifyDatatype :: - Name {- ^ constructor -} -> + Name {- ^ data type or constructor name -} -> Q DatatypeInfo -reifyDatatype n = normalizeInfo' "reifyDatatype" =<< reify n +reifyDatatype n = normalizeInfo' "reifyDatatype" isReified =<< reify n +-- | Compute a normalized view of the metadata about a constructor given its +-- 'Name'. This is useful for scenarios when you don't care about the info for +-- the enclosing data type. +reifyConstructor :: + Name {- ^ constructor name -} -> + Q ConstructorInfo +reifyConstructor conName = do + dataInfo <- reifyDatatype conName + return $ lookupByConstructorName conName dataInfo +-- | Compute a normalized view of the metadata about a constructor given the +-- 'Name' of one of its record selectors. This is useful for scenarios when you +-- don't care about the info for the enclosing data type. +reifyRecord :: + Name {- ^ record name -} -> + Q ConstructorInfo +reifyRecord recordName = do + dataInfo <- reifyDatatype recordName + return $ lookupByRecordName recordName dataInfo + +-- | Given a 'DatatypeInfo', find the 'ConstructorInfo' corresponding to the +-- 'Name' of one of its constructors. +lookupByConstructorName :: + Name {- ^ constructor name -} -> + DatatypeInfo {- ^ info for the datatype which has that constructor -} -> + ConstructorInfo +lookupByConstructorName conName dataInfo = + case find ((== conName) . constructorName) (datatypeCons dataInfo) of + Just conInfo -> conInfo + Nothing -> error $ "Datatype " ++ nameBase (datatypeName dataInfo) + ++ " does not have a constructor named " ++ nameBase conName +-- | Given a 'DatatypeInfo', find the 'ConstructorInfo' corresponding to the +-- 'Name' of one of its constructors. +lookupByRecordName :: + Name {- ^ record name -} -> + DatatypeInfo {- ^ info for the datatype which has that constructor -} -> + ConstructorInfo +lookupByRecordName recordName dataInfo = + case find (conHasRecord recordName) (datatypeCons dataInfo) of + Just conInfo -> conInfo + Nothing -> error $ "Datatype " ++ nameBase (datatypeName dataInfo) + ++ " does not have any constructors with a " + ++ "record selector named " ++ nameBase recordName + -- | Normalize 'Info' for a newtype or datatype into a 'DatatypeInfo'. -- Fail in 'Q' otherwise. normalizeInfo :: Info -> Q DatatypeInfo -normalizeInfo = normalizeInfo' "normalizeInfo" +normalizeInfo = normalizeInfo' "normalizeInfo" isn'tReified -normalizeInfo' :: String -> Info -> Q DatatypeInfo -normalizeInfo' entry i = +normalizeInfo' :: String -> IsReifiedDec -> Info -> Q DatatypeInfo +normalizeInfo' entry reifiedDec i = case i of PrimTyConI{} -> bad "Primitive type not supported" ClassI{} -> bad "Class not supported" @@ -315,16 +370,22 @@ #if MIN_VERSION_template_haskell(2,7,0) FamilyI _ _ -> bad "Type families not supported" #endif - TyConI dec -> normalizeDec dec + TyConI dec -> normalizeDecFor reifiedDec dec #if MIN_VERSION_template_haskell(2,11,0) DataConI name _ parent -> reifyParent name parent -#elif MIN_VERSION_template_haskell(2,7,0) + -- NB: We do not pass the IsReifiedDec information here + -- because there's no point. We have no choice but to + -- call reify here, since we need to determine the + -- parent data type/family. +#else DataConI name _ parent _ -> reifyParent name parent +#endif +#if MIN_VERSION_template_haskell(2,11,0) + VarI recName recTy _ -> reifyRecordType recName recTy + -- NB: Similarly, we do not pass the IsReifiedDec + -- information here. #else - -- Give a sensible error message if you try to look up a data family - -- instance constructor in GHC 7.0 or 7.2 - DataConI{} -> bad $ "Data family instances can only " ++ - "be reified with GHC 7.4 or later" + VarI recName recTy _ _ -> reifyRecordType recName recTy #endif _ -> bad "Expected a type constructor" where @@ -332,22 +393,66 @@ reifyParent :: Name -> Name -> Q DatatypeInfo -reifyParent con parent = - do info <- reify parent +reifyParent con = reifyParentWith "reifyParent" p + where + p :: DatatypeInfo -> Bool + p info = con `elem` map constructorName (datatypeCons info) + +reifyRecordType :: Name -> Type -> Q DatatypeInfo +reifyRecordType recName recTy = + let (_, argTys :|- _) = uncurryType recTy + in case argTys of + dataTy:_ -> decomposeDataType dataTy + _ -> notRecSelFailure + where + decomposeDataType :: Type -> Q DatatypeInfo + decomposeDataType ty = + do case decomposeType ty of + ConT parent :| _ -> reifyParentWith "reifyRecordType" p parent + _ -> notRecSelFailure + + notRecSelFailure :: Q a + notRecSelFailure = fail $ + "reifyRecordType: Not a record selector type: " ++ + nameBase recName ++ " :: " ++ show recTy + + p :: DatatypeInfo -> Bool + p info = any (conHasRecord recName) (datatypeCons info) + +reifyParentWith :: + String {- ^ prefix for error messages -} -> + (DatatypeInfo -> Bool) {- ^ predicate for finding the right + data family instance -} -> + Name {- ^ parent data type name -} -> + Q DatatypeInfo +reifyParentWith prefix p n = + do info <- reify n case info of - TyConI dec -> normalizeDec dec +#if !(MIN_VERSION_template_haskell(2,11,0)) + -- This unusual combination of Info and Dec is only possible to reify on + -- GHC 7.0 and 7.2, when you try to reify a data family. Because there's + -- no way to reify the data family *instances* on these versions of GHC, + -- we have no choice but to fail. + TyConI FamilyD{} -> dataFamiliesOnOldGHCsError +#endif + TyConI dec -> normalizeDecFor isReified dec #if MIN_VERSION_template_haskell(2,7,0) FamilyI dec instances -> do let instances1 = map (repairDataFam dec) instances - instances2 <- mapM normalizeDec instances1 + instances2 <- mapM (normalizeDecFor isReified) instances1 case find p instances2 of Just inst -> return inst - Nothing -> fail "PANIC: reifyParent lost the instance" + Nothing -> panic "lost the instance" #endif - _ -> fail "PANIC: reifyParent unexpected parent" + _ -> panic "unexpected parent" where - p info = con `elem` map constructorName (datatypeCons info) + dataFamiliesOnOldGHCsError :: Q a + dataFamiliesOnOldGHCsError = fail $ + prefix ++ ": Data family instances can only be reified with GHC 7.4 or later" + panic :: String -> Q a + panic message = fail $ "PANIC: " ++ prefix ++ " " ++ message + #if MIN_VERSION_template_haskell(2,8,0) && (!MIN_VERSION_template_haskell(2,10,0)) -- A GHC 7.6-specific bug requires us to replace all occurrences of @@ -443,51 +548,61 @@ -- Beware: 'normalizeDec' can have surprising behavior when it comes to fixity. -- For instance, if you have this quasiquoted data declaration: -- +-- @ -- [d| infix 5 :^^: -- data Foo where -- (:^^:) :: Int -> Int -> Foo |] +-- @ -- -- Then if you pass the 'Dec' for @Foo@ to 'normalizeDec' without splicing it --- in a previous Template Haskell splice, then @(:^^:) will be labeled a 'NormalConstructor' +-- in a previous Template Haskell splice, then @(:^^:)@ will be labeled a 'NormalConstructor' -- instead of an 'InfixConstructor'. This is because Template Haskell has no way to -- reify the fixity declaration for @(:^^:)@, so it must assume there isn't one. To -- work around this behavior, use 'reifyDatatype' instead. normalizeDec :: Dec -> Q DatatypeInfo +normalizeDec = normalizeDecFor isn'tReified + +normalizeDecFor :: IsReifiedDec -> Dec -> Q DatatypeInfo +normalizeDecFor isReified dec = + case dec of #if MIN_VERSION_template_haskell(2,12,0) -normalizeDec (NewtypeD context name tyvars _kind con _derives) = - giveTypesStarKinds <$> normalizeDec' context name (bndrParams tyvars) [con] Newtype -normalizeDec (DataD context name tyvars _kind cons _derives) = - giveTypesStarKinds <$> normalizeDec' context name (bndrParams tyvars) cons Datatype -normalizeDec (NewtypeInstD context name params _kind con _derives) = - repair13618 . giveTypesStarKinds =<< - normalizeDec' context name params [con] NewtypeInstance -normalizeDec (DataInstD context name params _kind cons _derives) = - repair13618 . giveTypesStarKinds =<< - normalizeDec' context name params cons DataInstance + NewtypeD context name tyvars _kind con _derives -> + giveTypesStarKinds <$> normalizeDec' isReified context name (bndrParams tyvars) [con] Newtype + DataD context name tyvars _kind cons _derives -> + giveTypesStarKinds <$> normalizeDec' isReified context name (bndrParams tyvars) cons Datatype + NewtypeInstD context name params _kind con _derives -> + repair13618' . giveTypesStarKinds =<< + normalizeDec' isReified context name params [con] NewtypeInstance + DataInstD context name params _kind cons _derives -> + repair13618' . giveTypesStarKinds =<< + normalizeDec' isReified context name params cons DataInstance #elif MIN_VERSION_template_haskell(2,11,0) -normalizeDec (NewtypeD context name tyvars _kind con _derives) = - giveTypesStarKinds <$> normalizeDec' context name (bndrParams tyvars) [con] Newtype -normalizeDec (DataD context name tyvars _kind cons _derives) = - giveTypesStarKinds <$> normalizeDec' context name (bndrParams tyvars) cons Datatype -normalizeDec (NewtypeInstD context name params _kind con _derives) = - repair13618 . giveTypesStarKinds =<< - normalizeDec' context name params [con] NewtypeInstance -normalizeDec (DataInstD context name params _kind cons _derives) = - repair13618 . giveTypesStarKinds =<< - normalizeDec' context name params cons DataInstance + NewtypeD context name tyvars _kind con _derives -> + giveTypesStarKinds <$> normalizeDec' isReified context name (bndrParams tyvars) [con] Newtype + DataD context name tyvars _kind cons _derives -> + giveTypesStarKinds <$> normalizeDec' isReified context name (bndrParams tyvars) cons Datatype + NewtypeInstD context name params _kind con _derives -> + repair13618' . giveTypesStarKinds =<< + normalizeDec' isReified context name params [con] NewtypeInstance + DataInstD context name params _kind cons _derives -> + repair13618' . giveTypesStarKinds =<< + normalizeDec' isReified context name params cons DataInstance #else -normalizeDec (NewtypeD context name tyvars con _derives) = - giveTypesStarKinds <$> normalizeDec' context name (bndrParams tyvars) [con] Newtype -normalizeDec (DataD context name tyvars cons _derives) = - giveTypesStarKinds <$> normalizeDec' context name (bndrParams tyvars) cons Datatype -normalizeDec (NewtypeInstD context name params con _derives) = - repair13618 . giveTypesStarKinds =<< - normalizeDec' context name params [con] NewtypeInstance -normalizeDec (DataInstD context name params cons _derives) = - repair13618 . giveTypesStarKinds =<< - normalizeDec' context name params cons DataInstance + NewtypeD context name tyvars con _derives -> + giveTypesStarKinds <$> normalizeDec' isReified context name (bndrParams tyvars) [con] Newtype + DataD context name tyvars cons _derives -> + giveTypesStarKinds <$> normalizeDec' isReified context name (bndrParams tyvars) cons Datatype + NewtypeInstD context name params con _derives -> + repair13618' . giveTypesStarKinds =<< + normalizeDec' isReified context name params [con] NewtypeInstance + DataInstD context name params cons _derives -> + repair13618' . giveTypesStarKinds =<< + normalizeDec' isReified context name params cons DataInstance #endif -normalizeDec _ = fail "reifyDatatype: DataD or NewtypeD required" + _ -> fail "normalizeDecFor: DataD or NewtypeD required" + where + repair13618' | isReified = repair13618 + | otherwise = return bndrParams :: [TyVarBndr] -> [Type] bndrParams = map $ \bndr -> @@ -507,14 +622,15 @@ normalizeDec' :: - Cxt {- ^ Datatype context -} -> - Name {- ^ Type constructor -} -> - [Type] {- ^ Type parameters -} -> - [Con] {- ^ Constructors -} -> - DatatypeVariant {- ^ Extra information -} -> + IsReifiedDec {- ^ Is this a reified 'Dec'? -} -> + Cxt {- ^ Datatype context -} -> + Name {- ^ Type constructor -} -> + [Type] {- ^ Type parameters -} -> + [Con] {- ^ Constructors -} -> + DatatypeVariant {- ^ Extra information -} -> Q DatatypeInfo -normalizeDec' context name params cons variant = - do cons' <- concat <$> mapM (normalizeCon name params variant) cons +normalizeDec' reifiedDec context name params cons variant = + do cons' <- concat <$> mapM (normalizeConFor reifiedDec name params variant) cons return DatatypeInfo { datatypeContext = context , datatypeName = name @@ -533,7 +649,16 @@ DatatypeVariant {- ^ Extra information -} -> Con {- ^ Constructor -} -> Q [ConstructorInfo] -normalizeCon typename params variant = fmap (map giveTyVarBndrsStarKinds) . dispatch +normalizeCon = normalizeConFor isn'tReified + +normalizeConFor :: + IsReifiedDec {- ^ Is this a reified 'Dec'? -} -> + Name {- ^ Type constructor -} -> + [Type] {- ^ Type parameters -} -> + DatatypeVariant {- ^ Extra information -} -> + Con {- ^ Constructor -} -> + Q [ConstructorInfo] +normalizeConFor reifiedDec typename params variant = fmap (map giveTyVarBndrsStarKinds) . dispatch where -- A GADT constructor is declared infix when: -- @@ -702,12 +827,12 @@ in case variant of -- On GHC 7.6 and 7.8, there's quite a bit of post-processing that -- needs to be performed to work around an old bug that eta-reduces the - -- type patterns of data families. + -- type patterns of data families (but only for reified data family instances). DataInstance - | mightHaveBeenEtaReduced params + | reifiedDec, mightHaveBeenEtaReduced params -> dataFamCompatCase NewtypeInstance - | mightHaveBeenEtaReduced params + | reifiedDec, mightHaveBeenEtaReduced params -> dataFamCompatCase _ -> defaultCase #else @@ -802,16 +927,58 @@ do info <- reifyRecover n $ fail "resolveTypeSynonyms: Cannot reify type synonym information" case info of - TyConI (TySynD _ synvars def) -> - let argNames = map tvName synvars - (args,rest) = splitAt (length argNames) xs - subst = Map.fromList (zip argNames args) - t' = foldl AppT (applySubstitution subst def) rest - in resolveTypeSynonyms t' - + TyConI (TySynD _ synvars def) + -> resolveTypeSynonyms $ expandSynonymRHS synvars xs def _ -> notTypeSynCase _ -> notTypeSynCase +expandSynonymRHS :: + [TyVarBndr] {- ^ Substitute these variables... -} -> + [Type] {- ^ ...with these types... -} -> + Type {- ^ ...inside of this type. -} -> + Type +expandSynonymRHS synvars ts def = + let argNames = map tvName synvars + (args,rest) = splitAt (length argNames) ts + subst = Map.fromList (zip argNames args) + in foldl AppT (applySubstitution subst def) rest + +-- | Expand all of the type synonyms in a 'Pred'. +resolvePredSynonyms :: Pred -> Q Pred +#if MIN_VERSION_template_haskell(2,10,0) +resolvePredSynonyms = resolveTypeSynonyms +#else +resolvePredSynonyms (ClassP n ts) = do + info <- reifyRecover n $ fail + "resolvePredSynonyms: Cannot reify type synonym information" + case info of + TyConI (TySynD _ synvars def) + -> resolvePredSynonyms $ typeToPred $ expandSynonymRHS synvars ts def + _ -> ClassP n <$> mapM resolveTypeSynonyms ts +resolvePredSynonyms (EqualP t1 t2) = do + t1' <- resolveTypeSynonyms t1 + t2' <- resolveTypeSynonyms t2 + return (EqualP t1' t2') + +typeToPred :: Type -> Pred +typeToPred t = + let f :| xs = decomposeType t in + case f of + ConT n + | n == eqTypeName +# if __GLASGOW_HASKELL__ == 704 + -- There's an unfortunate bug in GHC 7.4 where the (~) type is reified + -- with an explicit kind argument. To work around this, we ignore it. + , [_,t1,t2] <- xs +# else + , [t1,t2] <- xs +# endif + -> EqualP t1 t2 + | otherwise + -> ClassP n xs + _ -> error $ "typeToPred: Can't handle type " ++ show t +#endif + -- | Decompose a type into a list of it's outermost applications. This process -- forgets about infix application and explicit parentheses. -- @@ -829,7 +996,6 @@ -- saves dependencies for supporting older GHCs data NonEmpty a = a :| [a] -#if MIN_VERSION_template_haskell(2,8,0) && (!MIN_VERSION_template_haskell(2,10,0)) data NonEmptySnoc a = [a] :|- a -- Decompose a function type into its context, argument types, @@ -846,7 +1012,6 @@ go ctxt args (AppT (AppT ArrowT t1) t2) = go ctxt (t1:args) t2 go ctxt args (ForallT _ ctxt' t) = go (ctxt++ctxt') args t go ctxt args t = (ctxt, reverse args :|- t) -#endif -- | Resolve any infix type application in a type using the fixities that -- are currently available. Starting in `template-haskell-2.11` types could @@ -946,6 +1111,13 @@ takeFieldTypes :: [(a,b,Type)] -> [Type] takeFieldTypes xs = [a | (_,_,a) <- xs] +conHasRecord :: Name -> ConstructorInfo -> Bool +conHasRecord recName info = + case constructorVariant info of + NormalConstructor -> False + InfixConstructor -> False + RecordConstructor fields -> recName `elem` fields + ------------------------------------------------------------------------ -- | Add universal quantifier for all free variables in the type. This is @@ -1133,6 +1305,15 @@ #endif ------------------------------------------------------------------------ + +-- | If we are working with a 'Dec' obtained via 'reify' (as opposed to one +-- created from, say, [d| ... |] quotes), then we need to apply more hacks than +-- we otherwise would to sanitize the 'Dec'. See #28. +type IsReifiedDec = Bool + +isReified, isn'tReified :: IsReifiedDec +isReified = True +isn'tReified = False -- On old versions of GHC, reify would not give you kind signatures for -- GADT type variables of kind *. To work around this, we insert the kinds diff --git a/src/Language/Haskell/TH/Datatype/Internal.hs b/src/Language/Haskell/TH/Datatype/Internal.hs --- a/src/Language/Haskell/TH/Datatype/Internal.hs +++ b/src/Language/Haskell/TH/Datatype/Internal.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + {-| Module : Language.Haskell.TH.Datatype.Internal Description : Backwards-compatible interface to reified information about datatypes. @@ -13,7 +15,11 @@ import Language.Haskell.TH.Syntax eqTypeName :: Name +#if MIN_VERSION_base(4,9,0) eqTypeName = mkNameG_tc "base" "Data.Type.Equality" "~" +#else +eqTypeName = mkNameG_tc "ghc-prim" "GHC.Types" "~" +#endif -- This is only needed for GHC 7.6-specific bug starKindName :: Name diff --git a/test/Harness.hs b/test/Harness.hs --- a/test/Harness.hs +++ b/test/Harness.hs @@ -13,8 +13,11 @@ -} module Harness - ( validate - , equateDI + ( validateDI + , validateCI + , equateCxt + + -- * Utilities , varKCompat ) where @@ -24,9 +27,15 @@ import Language.Haskell.TH.Datatype import Language.Haskell.TH.Lib (starK) -validate :: DatatypeInfo -> DatatypeInfo -> ExpQ -validate x y = either fail (\_ -> [| return () |]) (equateDI x y) +validateDI :: DatatypeInfo -> DatatypeInfo -> ExpQ +validateDI = validate equateDI +validateCI :: ConstructorInfo -> ConstructorInfo -> ExpQ +validateCI = validate equateCI + +validate :: (a -> a -> Either String ()) -> a -> a -> ExpQ +validate equate x y = either fail (\_ -> [| return () |]) (equate x y) + -- | If the arguments are equal up to renaming return @'Right' ()@, -- otherwise return a string exlaining the mismatch. equateDI :: DatatypeInfo -> DatatypeInfo -> Either String () @@ -49,7 +58,8 @@ zipWithM_ equateCI (datatypeCons dat1) - (applySubstitution sub (datatypeCons dat2)) + (datatypeCons dat2) -- Don't bother applying the substitution here, as + -- equateCI takes care of this for us equateCxt :: String -> Pred -> Pred -> Either String () equateCxt lbl pred1 pred2 = @@ -63,8 +73,11 @@ do check "constructorName" (nameBase . constructorName) con1 con2 check "constructorVariant" constructorVariantBase con1 con2 - let sub = Map.fromList (zip (map tvName (constructorVars con2)) - (map VarT (map tvName (constructorVars con1)))) + let sub1 = Map.fromList (zip (map tvName (constructorVars con2)) + (map VarT (map tvName (constructorVars con1)))) + sub2 = Map.fromList (zip (freeVariables con2) + (map VarT (freeVariables con1))) + sub = sub1 `Map.union` sub2 zipWithM_ (equateCxt "constructorContext") (constructorContext con1) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,5 +1,9 @@ -{-# Language CPP, TypeFamilies, KindSignatures, TemplateHaskell, GADTs #-} +{-# Language CPP, FlexibleContexts, TypeFamilies, KindSignatures, TemplateHaskell, GADTs #-} +#if __GLASGOW_HASKELL__ >= 704 +{-# LANGUAGE ConstraintKinds #-} +#endif + #if MIN_VERSION_template_haskell(2,8,0) {-# Language PolyKinds #-} #endif @@ -18,79 +22,16 @@ -} module Main (main) where +#if __GLASGOW_HASKELL__ >= 704 +import Control.Monad (zipWithM_) +#endif + import Language.Haskell.TH import Language.Haskell.TH.Datatype import Language.Haskell.TH.Lib (starK) import Harness - -type Gadt1Int = Gadt1 Int - -infixr 6 :**: -data Gadt1 (a :: *) where - Gadtc1 :: Int -> Gadt1Int - Gadtc2 :: (a,a) -> Gadt1 a - (:**:) :: Bool -> Char -> Gadt1 () -- This is declared infix - (:!!:) :: Char -> Bool -> Gadt1 Double -- This is not - -data Adt1 (a :: *) (b :: *) = Adtc1 (a,b) | Bool `Adtc2` Int - -data Gadtrec1 a where - Gadtrecc1, Gadtrecc2 :: { gadtrec1a :: a, gadtrec1b :: b } -> Gadtrec1 (a,b) - -data Equal :: * -> * -> * -> * where - Equalc :: (Read a, Show a) => [a] -> Maybe a -> Equal a a a - -data Showable :: * where - Showable :: Show a => a -> Showable - -data R = R1 { field1, field2 :: Int } - -data Gadt2 :: * -> * -> * where - Gadt2c1 :: Gadt2 a [a] - Gadt2c2 :: Gadt2 [a] a - Gadt2c3 :: Gadt2 [a] [a] - -data VoidStoS (f :: * -> *) - -data StrictDemo = StrictDemo Int !Int {-# UNPACK #-} !Int - -#if MIN_VERSION_template_haskell(2,7,0) - --- Data families - -data family DF (a :: *) -data instance DF (Maybe a) = DFMaybe Int [a] - -# if MIN_VERSION_template_haskell(2,8,0) -data family DF1 (a :: k) -# else -data family DF1 (a :: *) -# endif -data instance DF1 b = DF1 b - - -# if MIN_VERSION_template_haskell(2,8,0) -data family Poly (a :: k) -# else -data family Poly (a :: *) -# endif -data instance Poly a = MkPoly - -data family GadtFam (a :: *) (b :: *) -data instance GadtFam c d where - MkGadtFam1 :: x -> y -> GadtFam y x - (:&&:) :: e -> f -> GadtFam [e] f -- This is declard infix - (:^^:) :: Int -> Int -> GadtFam Int Int -- This is not - MkGadtFam4 :: (Int ~ z) => z -> GadtFam z z - MkGadtFam5 :: (q ~ Char) => q -> GadtFam Bool Bool -infixl 3 :&&: - -data family FamLocalDec1 a -data family FamLocalDec2 a b c -#endif - -return [] -- segment type declarations above from refiy below +import Types -- | Test entry point. Tests will pass or fail at compile time. main :: IO () @@ -104,15 +45,23 @@ recordTest voidstosTest strictDemoTest + recordVanillaTest #if MIN_VERSION_template_haskell(2,7,0) dataFamilyTest ghc78bugTest + quotedTest polyTest gadtFamTest famLocalDecTest1 famLocalDecTest2 + recordFamTest #endif fixityLookupTest +#if __GLASGOW_HASKELL__ >= 704 + resolvePredSynonymsTest +#endif + reifyDatatypeWithConNameTest + reifyConstructorTest adt1Test :: IO () adt1Test = @@ -121,7 +70,7 @@ let vars@[a,b] = map (VarT . mkName) ["a","b"] [aSig,bSig] = map (\v -> SigT v starK) vars - validate info + validateDI info DatatypeInfo { datatypeName = ''Adt1 , datatypeContext = [] @@ -152,7 +101,7 @@ let a = VarT (mkName "a") - validate info + validateDI info DatatypeInfo { datatypeName = ''Gadt1 , datatypeContext = [] @@ -195,24 +144,13 @@ gadtrec1Test = $(do info <- reifyDatatype ''Gadtrec1 - let a = VarT (mkName "a") - names@[v1,v2] = map mkName ["v1","v2"] - [v1K,v2K] = map (\n -> KindedTV n starK) names - - let con = ConstructorInfo - { constructorName = 'Gadtrecc1 - , constructorVars = [v1K, v2K] - , constructorContext = - [equalPred a (AppT (AppT (TupleT 2) (VarT v1)) (VarT v2))] - , constructorFields = [VarT v1, VarT v2] - , constructorStrictness = [notStrictAnnot, notStrictAnnot] - , constructorVariant = RecordConstructor ['gadtrec1a, 'gadtrec1b] } + let con = gadtRecVanillaCI - validate info + validateDI info DatatypeInfo { datatypeName = ''Gadtrec1 , datatypeContext = [] - , datatypeVars = [SigT a starK] + , datatypeVars = [SigT (VarT (mkName "a")) starK] , datatypeVariant = Datatype , datatypeCons = [ con, con { constructorName = 'Gadtrecc2 } ] @@ -226,7 +164,7 @@ let vars@[a,b,c] = map (VarT . mkName) ["a","b","c"] [aSig,bSig,cSig] = map (\v -> SigT v starK) vars - validate info + validateDI info DatatypeInfo { datatypeName = ''Equal , datatypeContext = [] @@ -253,7 +191,7 @@ let a = mkName "a" - validate info + validateDI info DatatypeInfo { datatypeName = ''Showable , datatypeContext = [] @@ -274,7 +212,7 @@ recordTest :: IO () recordTest = $(do info <- reifyDatatype ''R - validate info + validateDI info DatatypeInfo { datatypeName = ''R , datatypeContext = [] @@ -305,7 +243,7 @@ , constructorFields = [] , constructorStrictness = [] , constructorVariant = NormalConstructor } - validate info + validateDI info DatatypeInfo { datatypeName = ''Gadt2 , datatypeContext = [] @@ -328,7 +266,7 @@ voidstosTest = $(do info <- reifyDatatype ''VoidStoS let g = mkName "g" - validate info + validateDI info DatatypeInfo { datatypeName = ''VoidStoS , datatypeContext = [] @@ -341,7 +279,7 @@ strictDemoTest :: IO () strictDemoTest = $(do info <- reifyDatatype ''StrictDemo - validate info + validateDI info DatatypeInfo { datatypeName = ''StrictDemo , datatypeContext = [] @@ -361,12 +299,17 @@ } ) +recordVanillaTest :: IO () +recordVanillaTest = + $(do info <- reifyRecord 'gadtrec1a + validateCI info gadtRecVanillaCI) + #if MIN_VERSION_template_haskell(2,7,0) dataFamilyTest :: IO () dataFamilyTest = $(do info <- reifyDatatype 'DFMaybe let a = mkName "a" - validate info + validateDI info DatatypeInfo { datatypeName = ''DF , datatypeContext = [] @@ -387,7 +330,7 @@ ghc78bugTest = $(do info <- reifyDatatype 'DF1 let c = VarT (mkName "c") - validate info + validateDI info DatatypeInfo { datatypeName = ''DF1 , datatypeContext = [] @@ -404,11 +347,33 @@ } ) +quotedTest :: IO () +quotedTest = + $(do [dec] <- [d| data instance Quoted a = MkQuoted a |] + info <- normalizeDec dec + let a = VarT (mkName "a") + validateDI info + DatatypeInfo + { datatypeName = mkName "Quoted" + , datatypeContext = [] + , datatypeVars = [SigT a starK] + , datatypeVariant = DataInstance + , datatypeCons = + [ ConstructorInfo + { constructorName = mkName "MkQuoted" + , constructorVars = [] + , constructorContext = [] + , constructorFields = [a] + , constructorStrictness = [notStrictAnnot] + , constructorVariant = NormalConstructor } ] + } + ) + polyTest :: IO () polyTest = $(do info <- reifyDatatype 'MkPoly let [a,k] = map mkName ["a","k"] - validate info + validateDI info DatatypeInfo { datatypeName = ''Poly , datatypeContext = [] @@ -431,7 +396,7 @@ let names@[c,d,e,q] = map mkName ["c","d","e","q"] [cTy,dTy,eTy,qTy] = map VarT names [cSig,dSig] = map (\v -> SigT v starK) [cTy,dTy] - validate info + validateDI info DatatypeInfo { datatypeName = ''GadtFam , datatypeContext = [] @@ -461,6 +426,7 @@ , constructorFields = [ConT ''Int, ConT ''Int] , constructorStrictness = [notStrictAnnot, notStrictAnnot] , constructorVariant = NormalConstructor } + , gadtRecFamCI , ConstructorInfo { constructorName = 'MkGadtFam4 , constructorVars = [] @@ -487,7 +453,7 @@ famLocalDecTest1 = $(do [dec] <- [d| data instance FamLocalDec1 Int = FamLocalDec1Int { mochi :: Double } |] info <- normalizeDec dec - validate info + validateDI info DatatypeInfo { datatypeName = ''FamLocalDec1 , datatypeContext = [] @@ -510,7 +476,7 @@ info <- normalizeDec dec let tys@[a,b] = map (VarT . mkName) ["a", "b"] [aSig,bSig] = map (\v -> SigT v starK) tys - validate info + validateDI info DatatypeInfo { datatypeName = ''FamLocalDec2 , datatypeContext = [] @@ -526,9 +492,57 @@ , constructorVariant = RecordConstructor [mkName "fm0", mkName "fm1"] }] } ) + +recordFamTest :: IO () +recordFamTest = + $(do info <- reifyRecord 'famRec1 + validateCI info gadtRecFamCI) #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 = VarT (mkName "a") + validateDI info + DatatypeInfo + { datatypeContext = [] + , datatypeName = ''Maybe + , datatypeVars = [SigT (VarT (mkName "a")) starK] + , datatypeVariant = Datatype + , datatypeCons = + [ ConstructorInfo + { constructorName = 'Nothing + , constructorVars = [] + , constructorContext = [] + , constructorFields = [] + , constructorStrictness = [] + , constructorVariant = NormalConstructor + } + , justCI + ] + } + ) + +reifyConstructorTest :: IO () +reifyConstructorTest = + $(do info <- reifyConstructor 'Just + validateCI info justCI) diff --git a/test/Types.hs b/test/Types.hs new file mode 100644 --- /dev/null +++ b/test/Types.hs @@ -0,0 +1,153 @@ +{-# Language CPP, FlexibleContexts, TypeFamilies, KindSignatures, TemplateHaskell, GADTs #-} + +#if __GLASGOW_HASKELL__ >= 704 +{-# LANGUAGE ConstraintKinds #-} +#endif + +#if MIN_VERSION_template_haskell(2,8,0) +{-# Language PolyKinds #-} +#endif + +{-| +Module : Types +Description : Test cases for the th-abstraction package +Copyright : Eric Mertens 2017 +License : ISC +Maintainer : emertens@gmail.com + +This module defined types used for testing features of @th-abstraction@ +on various versions of GHC. + +-} +module Types where + +#if __GLASGOW_HASKELL__ >= 704 +import GHC.Exts (Constraint) +#endif + +import Language.Haskell.TH +import Language.Haskell.TH.Datatype +import Language.Haskell.TH.Lib (starK) + +type Gadt1Int = Gadt1 Int + +infixr 6 :**: +data Gadt1 (a :: *) where + Gadtc1 :: Int -> Gadt1Int + Gadtc2 :: (a,a) -> Gadt1 a + (:**:) :: Bool -> Char -> Gadt1 () -- This is declared infix + (:!!:) :: Char -> Bool -> Gadt1 Double -- This is not + +data Adt1 (a :: *) (b :: *) = Adtc1 (a,b) | Bool `Adtc2` Int + +data Gadtrec1 a where + Gadtrecc1, Gadtrecc2 :: { gadtrec1a :: a, gadtrec1b :: b } -> Gadtrec1 (a,b) + +data Equal :: * -> * -> * -> * where + Equalc :: (Read a, Show a) => [a] -> Maybe a -> Equal a a a + +data Showable :: * where + Showable :: Show a => a -> Showable + +data R = R1 { field1, field2 :: Int } + +data Gadt2 :: * -> * -> * where + Gadt2c1 :: Gadt2 a [a] + Gadt2c2 :: Gadt2 [a] a + Gadt2c3 :: Gadt2 [a] [a] + +data VoidStoS (f :: * -> *) + +data StrictDemo = StrictDemo Int !Int {-# UNPACK #-} !Int + +#if MIN_VERSION_template_haskell(2,7,0) + +-- Data families + +data family DF (a :: *) +data instance DF (Maybe a) = DFMaybe Int [a] + +# if MIN_VERSION_template_haskell(2,8,0) +data family DF1 (a :: k) +# else +data family DF1 (a :: *) +# endif +data instance DF1 b = DF1 b + +data family Quoted (a :: *) + +# if MIN_VERSION_template_haskell(2,8,0) +data family Poly (a :: k) +# else +data family Poly (a :: *) +# endif +data instance Poly a = MkPoly + +data family GadtFam (a :: *) (b :: *) +data instance GadtFam c d where + MkGadtFam1 :: x -> y -> GadtFam y x + (:&&:) :: e -> f -> GadtFam [e] f -- This is declard infix + (:^^:) :: Int -> Int -> GadtFam Int Int -- This is not + (:#%:) :: { famRec1, famRec2 :: Bool } -> GadtFam Bool Bool -- Nor is this + MkGadtFam4 :: (Int ~ z) => z -> GadtFam z z + MkGadtFam5 :: (q ~ Char) => q -> GadtFam Bool Bool +infixl 3 :&&:, :#%: + +data family FamLocalDec1 a +data family FamLocalDec2 a b c +#endif + +#if __GLASGOW_HASKELL__ >= 704 +type Konst (a :: Constraint) (b :: Constraint) = a +type PredSyn1 a b = Konst (Show a) (Read b) +type PredSyn2 a b = Konst (PredSyn1 a b) (Show a) +type PredSyn3 c = Int ~ c + +data PredSynT = + PredSyn1 Int Int => MkPredSynT1 Int + | PredSyn2 Int Int => MkPredSynT2 Int + | PredSyn3 Int => MkPredSynT3 Int +#endif + +-- We must define these here due to Template Haskell staging restrictions +justCI :: ConstructorInfo +justCI = + ConstructorInfo + { constructorName = 'Just + , constructorVars = [] + , constructorContext = [] + , constructorFields = [VarT (mkName "a")] + , constructorStrictness = [notStrictAnnot] + , constructorVariant = NormalConstructor + } + +gadtRecVanillaCI :: ConstructorInfo +gadtRecVanillaCI = + ConstructorInfo + { constructorName = 'Gadtrecc1 + , constructorVars = [v1K, v2K] + , constructorContext = + [equalPred a (AppT (AppT (TupleT 2) (VarT v1)) (VarT v2))] + , constructorFields = [VarT v1, VarT v2] + , constructorStrictness = [notStrictAnnot, notStrictAnnot] + , constructorVariant = RecordConstructor ['gadtrec1a, 'gadtrec1b] } + where + a = VarT (mkName "a") + names@[v1,v2] = map mkName ["v1","v2"] + [v1K,v2K] = map (\n -> KindedTV n starK) names + +#if MIN_VERSION_template_haskell(2,7,0) +gadtRecFamCI :: ConstructorInfo +gadtRecFamCI = + ConstructorInfo + { constructorName = '(:#%:) + , constructorVars = [] + , constructorContext = [ equalPred cTy (ConT ''Bool) + , equalPred dTy (ConT ''Bool) + ] + , constructorFields = [ConT ''Bool, ConT ''Bool] + , constructorStrictness = [notStrictAnnot, notStrictAnnot] + , constructorVariant = RecordConstructor ['famRec1, 'famRec2] } + where + [cTy,dTy] = map (VarT . mkName) ["c", "d"] +#endif 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.2.2.0 +version: 0.2.3.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 @@ -35,6 +35,7 @@ test-suite unit-tests other-modules: Harness + Types type: exitcode-stdio-1.0 main-is: Main.hs build-depends: th-abstraction, base, containers, template-haskell