th-abstraction 0.2.2.0 → 0.2.3.0
raw patch · 8 files changed
+565/−180 lines, 8 filesnew-uploaderPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ Language.Haskell.TH.Datatype: lookupByConstructorName :: Name -> DatatypeInfo -> ConstructorInfo
+ Language.Haskell.TH.Datatype: lookupByRecordName :: Name -> DatatypeInfo -> ConstructorInfo
+ Language.Haskell.TH.Datatype: reifyConstructor :: Name -> Q ConstructorInfo
+ Language.Haskell.TH.Datatype: reifyRecord :: Name -> Q ConstructorInfo
+ Language.Haskell.TH.Datatype: resolvePredSynonyms :: Pred -> Q Pred
Files
- ChangeLog.md +17/−0
- README.md +3/−3
- src/Language/Haskell/TH/Datatype.hs +253/−72
- src/Language/Haskell/TH/Datatype/Internal.hs +6/−0
- test/Harness.hs +20/−7
- test/Main.hs +111/−97
- test/Types.hs +153/−0
- th-abstraction.cabal +2/−1
ChangeLog.md view
@@ -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.
README.md view
@@ -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 -------------------
src/Language/Haskell/TH/Datatype.hs view
@@ -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
src/Language/Haskell/TH/Datatype/Internal.hs view
@@ -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
test/Harness.hs view
@@ -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)
test/Main.hs view
@@ -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)
+ test/Types.hs view
@@ -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
th-abstraction.cabal view
@@ -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