diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,6 +1,14 @@ # Revision history for th-abstraction -## 0.1.3.0 -- 2016-05-27 +## 0.2.0.0 -- 2017-06-03 + +* Added `reifyFixityCompat` +* Added `constructorStrictness` field to `ConstructorInfo` +* Infer more kind signatures when missing on old GHCs +* Added parameter to `normalizeCon` +* Support GHC back to 7.0.4 + +## 0.1.3.0 -- 2017-05-27 * Added `resolveInfixT` which uses reified fixity information to resolve `UInfixT` * Added `asEqualPred` and `asClassPred` 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 @@ -1,5 +1,10 @@ -{-# Language CPP, DeriveGeneric, DeriveDataTypeable #-} +{-# Language CPP, DeriveDataTypeable #-} +#if MIN_VERSION_base(4,4,0) +#define HAS_GENERICS +{-# Language DeriveGeneric #-} +#endif + {-| Module : Language.Haskell.TH.Datatype Description : Backwards-compatible interface to reified information about datatypes. @@ -17,22 +22,27 @@ 'DatatypeInfo' { 'datatypeContext' = [] , 'datatypeName' = GHC.Base.Maybe - , 'datatypeVars' = [ 'VarT' a_3530822107858468866 ] + , 'datatypeVars' = [ 'SigT' ('VarT' a_3530822107858468866) 'StarT' ] , 'datatypeVariant' = 'Datatype' , 'datatypeCons' = [ 'ConstructorInfo' - { 'constructorName' = GHC.Base.Nothing - , 'constructorVars' = [] - , 'constructorContext' = [] - , 'constructorFields' = [] - , 'constructorVariant' = 'NormalConstructor' + { 'constructorName' = GHC.Base.Nothing + , 'constructorVars' = [] + , 'constructorContext' = [] + , 'constructorFields' = [] + , 'constructorStrictness' = [] + , 'constructorVariant' = 'NormalConstructor' } , 'ConstructorInfo' - { 'constructorName' = GHC.Base.Just - , 'constructorVars' = [] - , 'constructorContext' = [] - , 'constructorFields' = [ 'VarT' a_3530822107858468866 ] - , 'constructorVariant' = 'NormalConstructor' + { 'constructorName' = GHC.Base.Just + , 'constructorVars' = [] + , 'constructorContext' = [] + , 'constructorFields' = [ 'VarT' a_3530822107858468866 ] + , 'constructorStrictness' = [ 'FieldStrictness' + 'UnspecifiedUnpackedness' + 'Lazy' + ] + , 'constructorVariant' = 'NormalConstructor' } ] } @@ -49,6 +59,7 @@ , ConstructorInfo(..) , DatatypeVariant(..) , ConstructorVariant(..) + , FieldStrictness(..) -- * Normalization functions , reifyDatatype @@ -71,16 +82,24 @@ , dataDCompat , arrowKCompat + -- * Strictness annotations + , isStrictAnnot + , notStrictAnnot + , unpackedAnnot + -- * Type simplification , resolveTypeSynonyms , resolveInfixT + -- * Fixities + , reifyFixityCompat + , showFixity + , showFixityDirection + -- * Convenience functions , unifyTypes , tvName , datatypeType - , showFixity - , showFixityDirection ) where import Data.Data (Typeable, Data) @@ -88,19 +107,30 @@ import Data.List (find, union, (\\)) import Data.Map (Map) import qualified Data.Map as Map -import Data.Maybe (fromMaybe) -import Control.Monad (foldM) -import GHC.Generics (Generic) +import Data.Maybe +import qualified Data.Traversable as T +import Control.Monad import Language.Haskell.TH +#if MIN_VERSION_template_haskell(2,11,0) + hiding (Extension(..)) +#endif import Language.Haskell.TH.Datatype.Internal -import Language.Haskell.TH.Lib (arrowK) -- needed for th-2.4 +import Language.Haskell.TH.Lib (arrowK, starK) -- needed for th-2.4 +#ifdef HAS_GENERICS +import GHC.Generics (Generic) +#endif + #if !MIN_VERSION_base(4,8,0) import Control.Applicative (Applicative(..), (<$>)) -import Data.Traversable (traverse, sequenceA) #endif -- | Normalized information about newtypes and data types. +-- +-- 'datatypeVars' types will have an outermost 'SigT' to indicate the +-- parameter's kind. These types will be simple variables for /ADT/s +-- declared with @data@ and @newtype@, but can be more complex for +-- types declared with @data instance@ and @newtype instance@. data DatatypeInfo = DatatypeInfo { datatypeContext :: Cxt -- ^ Data type context (deprecated) , datatypeName :: Name -- ^ Type constructor @@ -108,34 +138,114 @@ , datatypeVariant :: DatatypeVariant -- ^ Extra information , datatypeCons :: [ConstructorInfo] -- ^ Normalize constructor information } - deriving (Show, Eq, Typeable, Data, Generic) + deriving (Show, Eq, Typeable, Data +#ifdef HAS_GENERICS + ,Generic +#endif + ) -- | Possible variants of data type declarations. data DatatypeVariant - = Datatype -- ^ Type declared with @data@ - | Newtype -- ^ Type declared with @newtype@ - | DataInstance -- ^ Type declared with @data instance@ + = Datatype -- ^ Type declared with @data@ + | Newtype -- ^ Type declared with @newtype@ + | DataInstance -- ^ Type declared with @data instance@ | NewtypeInstance -- ^ Type declared with @newtype instance@ - deriving (Show, Read, Eq, Ord, Typeable, Data, Generic) + deriving (Show, Read, Eq, Ord, Typeable, Data +#ifdef HAS_GENERICS + ,Generic +#endif + ) -- | Normalized information about constructors associated with newtypes and -- data types. data ConstructorInfo = ConstructorInfo - { constructorName :: Name -- ^ Constructor name - , constructorVars :: [TyVarBndr] -- ^ Constructor type parameters - , constructorContext :: Cxt -- ^ Constructor constraints - , constructorFields :: [Type] -- ^ Constructor fields - , constructorVariant :: ConstructorVariant -- ^ Extra information + { constructorName :: Name -- ^ Constructor name + , constructorVars :: [TyVarBndr] -- ^ Constructor type parameters + , constructorContext :: Cxt -- ^ Constructor constraints + , constructorFields :: [Type] -- ^ Constructor fields + , constructorStrictness :: [FieldStrictness] -- ^ Constructor fields' strictness + -- (Invariant: has the same length + -- as constructorFields) + , constructorVariant :: ConstructorVariant -- ^ Extra information } - deriving (Show, Eq, Typeable, Data, Generic) + deriving (Show, Eq, Typeable, Data +#ifdef HAS_GENERICS + ,Generic +#endif + ) -- | Possible variants of data constructors. data ConstructorVariant = NormalConstructor -- ^ Constructor without field names + | InfixConstructor -- ^ Constructor without field names that is + -- declared infix | RecordConstructor [Name] -- ^ Constructor with field names - deriving (Show, Eq, Ord, Typeable, Data, Generic) + deriving (Show, Eq, Ord, Typeable, Data +#ifdef HAS_GENERICS + ,Generic +#endif + ) +-- | Normalized information about a constructor field's @UNPACK@ and +-- strictness annotations. +-- +-- Note that the interface for reifying strictness in Template Haskell changed +-- considerably in GHC 8.0. The presentation in this library mirrors that which +-- can be found in GHC 8.0 or later, whereas previously, unpackedness and +-- strictness were represented with a single data type: +-- +-- @ +-- data Strict +-- = IsStrict +-- | NotStrict +-- | Unpacked -- On GHC 7.4 or later +-- @ +-- +-- For backwards compatibility, we retrofit these constructors onto the +-- following three values, respectively: +-- +-- @ +-- 'isStrictAnnot' = 'FieldStrictness' 'UnspecifiedUnpackedness' 'Strict' +-- 'notStrictAnnot' = 'FieldStrictness' 'UnspecifiedUnpackedness' 'UnspecifiedStrictness' +-- 'unpackedAnnot' = 'FieldStrictness' 'Unpack' 'Strict' +-- @ +data FieldStrictness = FieldStrictness + { fieldUnpackedness :: Unpackedness + , fieldStrictness :: Strictness + } + deriving (Show, Eq, Ord, Typeable, Data +#ifdef HAS_GENERICS + ,Generic +#endif + ) +-- | Information about a constructor field's unpackedness annotation. +data Unpackedness + = UnspecifiedUnpackedness -- ^ No annotation whatsoever + | NoUnpack -- ^ Annotated with @{\-\# NOUNPACK \#-\}@ + | Unpack -- ^ Annotated with @{\-\# UNPACK \#-\}@ + deriving (Show, Eq, Ord, Typeable, Data +#ifdef HAS_GENERICS + ,Generic +#endif + ) + +-- | Information about a constructor field's strictness annotation. +data Strictness + = UnspecifiedStrictness -- ^ No annotation whatsoever + | Lazy -- ^ Annotated with @~@ + | Strict -- ^ Annotated with @!@ + deriving (Show, Eq, Ord, Typeable, Data +#ifdef HAS_GENERICS + ,Generic +#endif + ) + +isStrictAnnot, notStrictAnnot, unpackedAnnot :: FieldStrictness +isStrictAnnot = FieldStrictness UnspecifiedUnpackedness Strict +notStrictAnnot = FieldStrictness UnspecifiedUnpackedness UnspecifiedStrictness +unpackedAnnot = FieldStrictness Unpack Strict + -- | Construct a Type using the datatype's type constructor and type -- parameters. Kind signatures are removed. datatypeType :: DatatypeInfo -> Type @@ -146,36 +256,74 @@ -- | Compute a normalized view of the metadata about a data type or newtype --- given a type constructor. +-- given a constructor. +-- +-- 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/. +-- +-- GADT constructors are normalized into datatypes with explicit equality +-- constraints. +-- +-- This function will apply various bug-fixes to the output of the underlying +-- @template-haskell@ library in order to provide a view of datatypes in +-- as uniform a way as possible. reifyDatatype :: - Name {- ^ type constructor -} -> + Name {- ^ constructor -} -> Q DatatypeInfo -reifyDatatype n = normalizeInfo =<< reify n +reifyDatatype n = normalizeInfo' "reifyDatatype" =<< reify n -- | Normalize 'Info' for a newtype or datatype into a 'DatatypeInfo'. -- Fail in 'Q' otherwise. normalizeInfo :: Info -> Q DatatypeInfo -normalizeInfo (TyConI dec) = normalizeDec dec -# if MIN_VERSION_template_haskell(2,11,0) -normalizeInfo (DataConI name ty parent) = reifyParent name ty parent -# else -normalizeInfo (DataConI name ty parent _) = reifyParent name ty parent -# endif -normalizeInfo _ = fail "reifyDatatype: Expected a type constructor" +normalizeInfo = normalizeInfo' "normalizeInfo" +normalizeInfo' :: String -> Info -> Q DatatypeInfo +normalizeInfo' entry i = + case i of + PrimTyConI{} -> bad "Primitive type not supported" + ClassI{} -> bad "Class not supported" +#if MIN_VERSION_template_haskell(2,11,0) + FamilyI DataFamilyD{} _ -> +#elif MIN_VERSION_template_haskell(2,7,0) + FamilyI (FamilyD DataFam _ _ _) _ -> +#else + TyConI (FamilyD DataFam _ _ _) -> +#endif + bad "Use a value constructor to reify a data family instance" +#if MIN_VERSION_template_haskell(2,7,0) + FamilyI _ _ -> bad "Type families not supported" +#endif + TyConI dec -> normalizeDec dec +#if MIN_VERSION_template_haskell(2,11,0) + DataConI name _ parent -> reifyParent name parent +#elif MIN_VERSION_template_haskell(2,7,0) + DataConI name _ parent _ -> reifyParent name parent +#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" +#endif + _ -> bad "Expected a type constructor" + where + bad msg = fail (entry ++ ": " ++ msg) -reifyParent :: Name -> Type -> Name -> Q DatatypeInfo -reifyParent con ty parent = + +reifyParent :: Name -> Name -> Q DatatypeInfo +reifyParent con parent = do info <- reify parent case info of TyConI dec -> normalizeDec dec +#if MIN_VERSION_template_haskell(2,7,0) FamilyI dec instances -> - do let instances1 = map (repairInstance dec ty) instances - instances2 <- traverse normalizeDec instances1 + do let instances1 = map (repairDataFam dec) instances + instances2 <- mapM normalizeDec instances1 case find p instances2 of Just inst -> return inst Nothing -> fail "PANIC: reifyParent lost the instance" +#endif _ -> fail "PANIC: reifyParent unexpected parent" where p info = con `elem` map constructorName (datatypeCons info) @@ -184,66 +332,120 @@ 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 + -- A version of repairVarKindsWith that does much more extra work to + -- (1) eta-expand missing type patterns, and (2) ensure that the kind + -- signatures for these new type patterns match accordingly. + repairVarKindsWith' :: [TyVarBndr] -> [Type] -> [Type] + repairVarKindsWith' dvars ts = + let nparams = length dvars + kparams = kindVars dvars + (tsKinds,tsNoKinds) = splitAt (length kparams) ts + tsKinds' = map sanitizeStars tsKinds + extraTys = drop (length tsNoKinds) (bndrParams dvars) + ts' = tsNoKinds ++ extraTys -- eta-expand + in applySubstitution (Map.fromList (zip kparams tsKinds')) $ + repairVarKindsWith dvars ts' + + -- A GHC 7.6-specific bug requires us to replace all occurrences of + -- (ConT GHC.Prim.*) with StarT, or else Template Haskell will reject it. + -- Luckily, (ConT GHC.Prim.*) only seems to occur in this one spot. + sanitizeStars :: Kind -> Kind + sanitizeStars = go + where + go :: Kind -> Kind + go (AppT t1 t2) = AppT (go t1) (go t2) + go (SigT t k) = SigT (go t) (go k) + go (ConT n) | n == starKindName = StarT + go t = t + + kindVars = freeVariables . map kindPart + + -- Sadly, Template Haskell's treatment of data family instances leaves much + -- to be desired. Here are some problems that we have to work around: + -- + -- 1. On all versions of GHC, TH leaves off the kind signatures on the + -- type patterns of data family instances where a kind signature isn't + -- specified explicitly. Here, we can use the parent data family's + -- type variable binders to reconstruct the kind signatures if they + -- are missing. + -- 2. On GHC 7.6 and 7.8, TH will eta-reduce data instances. We can find + -- the missing type variables on the data constructor. + -- + -- We opt to avoid propagating these new type variables through to the + -- constructor now, but we will return to this task in normalizeCon. + repairDataFam (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 + NewtypeInstD cx n (repairVarKindsWith' dvars ts) con deriv + repairDataFam (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)) + DataInstD cx n (repairVarKindsWith' dvars ts) cons deriv +#else + repairDataFam famD instD +# if MIN_VERSION_template_haskell(2,11,0) + | DataFamilyD _ dvars _ <- famD + , NewtypeInstD cx n ts k c deriv <- instD + = NewtypeInstD cx n (repairVarKindsWith dvars ts) k c deriv + + | DataFamilyD _ dvars _ <- famD + , DataInstD cx n ts k c deriv <- instD + = DataInstD cx n (repairVarKindsWith dvars ts) k c deriv +# else + | FamilyD _ _ dvars _ <- famD + , NewtypeInstD cx n ts c deriv <- instD + = NewtypeInstD cx n (repairVarKindsWith dvars ts) c deriv + + | FamilyD _ _ dvars _ <- famD + , DataInstD cx n ts c deriv <- instD + = DataInstD cx n (repairVarKindsWith dvars ts) c deriv +# endif #endif - repairInstance _ _ x = x + repairDataFam _ instD = instD +repairVarKindsWith :: [TyVarBndr] -> [Type] -> [Type] +repairVarKindsWith = zipWith stealKindForType +-- If a VarT is missing an explicit kind signature, steal it from a TyVarBndr. +stealKindForType :: TyVarBndr -> Type -> Type +stealKindForType tvb t@VarT{} = SigT t (tvbKind tvb) +stealKindForType _ t = t + -- | Normalize 'Dec' for a newtype or datatype into a 'DatatypeInfo'. -- Fail in 'Q' otherwise. normalizeDec :: Dec -> Q DatatypeInfo #if MIN_VERSION_template_haskell(2,12,0) normalizeDec (NewtypeD context name tyvars _kind con _derives) = - normalizeDec' context name (bndrParams tyvars) [con] Newtype + giveTypesStarKinds <$> normalizeDec' context name (bndrParams tyvars) [con] Newtype normalizeDec (DataD context name tyvars _kind cons _derives) = - normalizeDec' context name (bndrParams tyvars) cons Datatype + giveTypesStarKinds <$> normalizeDec' context name (bndrParams tyvars) cons Datatype normalizeDec (NewtypeInstD context name params _kind con _derives) = - repair13618 =<< + repair13618 . giveTypesStarKinds =<< normalizeDec' context name params [con] NewtypeInstance normalizeDec (DataInstD context name params _kind cons _derives) = - repair13618 =<< + repair13618 . giveTypesStarKinds =<< normalizeDec' context name params cons DataInstance #elif MIN_VERSION_template_haskell(2,11,0) normalizeDec (NewtypeD context name tyvars _kind con _derives) = - normalizeDec' context name (bndrParams tyvars) [con] Newtype + giveTypesStarKinds <$> normalizeDec' context name (bndrParams tyvars) [con] Newtype normalizeDec (DataD context name tyvars _kind cons _derives) = - normalizeDec' context name (bndrParams tyvars) cons Datatype + giveTypesStarKinds <$> normalizeDec' context name (bndrParams tyvars) cons Datatype normalizeDec (NewtypeInstD context name params _kind con _derives) = - repair13618 =<< + repair13618 . giveTypesStarKinds =<< normalizeDec' context name params [con] NewtypeInstance normalizeDec (DataInstD context name params _kind cons _derives) = - repair13618 =<< + repair13618 . giveTypesStarKinds =<< normalizeDec' context name params cons DataInstance #else normalizeDec (NewtypeD context name tyvars con _derives) = - normalizeDec' context name (bndrParams tyvars) [con] Newtype + giveTypesStarKinds <$> normalizeDec' context name (bndrParams tyvars) [con] Newtype normalizeDec (DataD context name tyvars cons _derives) = - normalizeDec' context name (bndrParams tyvars) cons Datatype + giveTypesStarKinds <$> normalizeDec' context name (bndrParams tyvars) cons Datatype normalizeDec (NewtypeInstD context name params con _derives) = - repair13618 =<< + repair13618 . giveTypesStarKinds =<< normalizeDec' context name params [con] NewtypeInstance normalizeDec (DataInstD context name params cons _derives) = - repair13618 =<< + repair13618 . giveTypesStarKinds =<< normalizeDec' context name params cons DataInstance #endif normalizeDec _ = fail "reifyDatatype: DataD or NewtypeD required" @@ -254,6 +456,10 @@ KindedTV t k -> SigT (VarT t) k PlainTV t -> VarT t +-- | Extract the kind from a 'TyVarBndr'. Assumes 'PlainTV' has kind @*@. +tvbKind :: TyVarBndr -> Kind +tvbKind (PlainTV _) = starK +tvbKind (KindedTV _ k) = k -- | Remove the outermost 'SigT'. stripSigT :: Type -> Type @@ -269,8 +475,8 @@ DatatypeVariant {- ^ Extra information -} -> Q DatatypeInfo normalizeDec' context name params cons variant = - do cons' <- concat <$> traverse (normalizeCon name params) cons - pure DatatypeInfo + do cons' <- concat <$> mapM (normalizeCon name params variant) cons + return DatatypeInfo { datatypeContext = context , datatypeName = name , datatypeVars = params @@ -279,49 +485,195 @@ } -- | Normalize a 'Con' into a 'ConstructorInfo'. This requires knowledge of --- the type and parameters of the constructor as extracted from the outer +-- the type and parameters of the constructor, as well as whether the constructor +-- is for a data family instance, as extracted from the outer -- 'Dec'. normalizeCon :: - Name {- ^ Type constructor -} -> - [Type] {- ^ Type parameters -} -> - Con {- ^ Constructor -} -> + Name {- ^ Type constructor -} -> + [Type] {- ^ Type parameters -} -> + DatatypeVariant {- ^ Extra information -} -> + Con {- ^ Constructor -} -> Q [ConstructorInfo] -normalizeCon typename params = go [] [] +normalizeCon typename params variant = fmap (map giveTyVarBndrsStarKinds) . dispatch where - go tyvars context c = - case c of - NormalC n xs -> - pure [ConstructorInfo n tyvars context (map snd xs) NormalConstructor] - InfixC l n r -> - pure [ConstructorInfo n tyvars context [snd l,snd r] NormalConstructor] - RecC n xs -> - let fns = takeFieldNames xs in - pure [ConstructorInfo n tyvars context - (takeFieldTypes xs) (RecordConstructor fns)] - ForallC tyvars' context' c' -> - go (tyvars'++tyvars) (context'++context) c' + -- A GADT constructor is declared infix when: + -- + -- 1. Its name uses operator syntax (e.g., (:*:)) + -- 2. It has exactly two fields + -- 3. It has a programmer-supplied fixity declaration + checkGadtFixity :: [Type] -> Name -> Q ConstructorVariant + checkGadtFixity ts n = do +#if MIN_VERSION_template_haskell(2,11,0) + mbFi <- reifyFixity n + let userSuppliedFixity = isJust mbFi +#else + -- On old GHCs, there is a bug where infix GADT constructors will + -- mistakenly be marked as (ForallC (NormalC ...)) instead of + -- (ForallC (InfixC ...)). This is especially annoying since on these + -- versions of GHC, Template Haskell doesn't grant the ability to query + -- whether a constructor was given a user-supplied fixity declaration. + -- Rather, you can only check the fixity that GHC ultimately decides on + -- for a constructor, regardless of whether it was a default fixity or + -- it was user-supplied. + -- + -- We can approximate whether a fixity was user-supplied by checking if + -- it is not equal to defaultFixity (infixl 9). Unfortunately, + -- there is no way to distinguish between a user-supplied fixity of + -- infixl 9 and the fixity that GHC defaults to, so we cannot properly + -- handle that case. + DataConI _ _ _ fi <- reify n + let userSuppliedFixity = fi /= defaultFixity +#endif + return $ if isInfixDataCon (nameBase n) + && length ts == 2 + && userSuppliedFixity + then InfixConstructor + else NormalConstructor + -- Checks if a String names a valid Haskell infix data + -- constructor (i.e., does it begin with a colon?). + isInfixDataCon :: String -> Bool + isInfixDataCon (':':_) = True + isInfixDataCon _ = False + + dispatch :: Con -> Q [ConstructorInfo] + dispatch = + let defaultCase :: Con -> Q [ConstructorInfo] + defaultCase = go [] [] False + where + go :: [TyVarBndr] + -> Cxt + -> Bool -- Is this a GADT? (see the documentation for + -- for checkGadtFixity) + -> Con + -> Q [ConstructorInfo] + go tyvars context gadt c = + case c of + NormalC n xs -> do + let (bangs, ts) = unzip xs + stricts = map normalizeStrictness bangs + fi <- if gadt + then checkGadtFixity ts n + else return NormalConstructor + return [ConstructorInfo n tyvars context ts stricts fi] + InfixC l n r -> + let (bangs, ts) = unzip [l,r] + stricts = map normalizeStrictness bangs in + return [ConstructorInfo n tyvars context ts stricts + InfixConstructor] + RecC n xs -> + let fns = takeFieldNames xs + stricts = takeFieldStrictness xs in + return [ConstructorInfo n tyvars context + (takeFieldTypes xs) stricts (RecordConstructor fns)] + ForallC tyvars' context' c' -> + go (tyvars'++tyvars) (context'++context) True c' #if MIN_VERSION_template_haskell(2,11,0) - GadtC ns xs innerType -> - gadtCase ns innerType (map snd xs) NormalConstructor - RecGadtC ns xs innerType -> - let fns = takeFieldNames xs in - gadtCase ns innerType (takeFieldTypes xs) (RecordConstructor fns) - where - gadtCase = normalizeGadtC typename params tyvars context + GadtC ns xs innerType -> + let (bangs, ts) = unzip xs + stricts = map normalizeStrictness bangs in + gadtCase ns innerType ts stricts (checkGadtFixity ts) + RecGadtC ns xs innerType -> + let fns = takeFieldNames xs + stricts = takeFieldStrictness xs in + gadtCase ns innerType (takeFieldTypes xs) stricts + (const $ return $ RecordConstructor fns) + where + gadtCase = normalizeGadtC typename params tyvars context +#endif +#if MIN_VERSION_template_haskell(2,8,0) && (!MIN_VERSION_template_haskell(2,10,0)) + dataFamCompatCase :: Con -> Q [ConstructorInfo] + dataFamCompatCase = go [] + where + go tyvars c = + case c of + NormalC n xs -> + let stricts = map (normalizeStrictness . fst) xs in + dataFamCase' n tyvars stricts NormalConstructor + InfixC l n r -> + let stricts = map (normalizeStrictness . fst) [l,r] in + dataFamCase' n tyvars stricts InfixConstructor + RecC n xs -> + let stricts = takeFieldStrictness xs in + dataFamCase' n tyvars stricts + (RecordConstructor (takeFieldNames xs)) + ForallC tyvars' context' c' -> + go (tyvars'++tyvars) c' + dataFamCase' :: Name -> [TyVarBndr] -> [FieldStrictness] + -> ConstructorVariant + -> Q [ConstructorInfo] + dataFamCase' n tyvars stricts variant = do + info <- reify n + case info of + DataConI _ ty _ _ -> do + let (context, argTys :|- returnTy) = uncurryType ty + returnTy' <- resolveTypeSynonyms returnTy + -- Notice that we've ignored the Cxt and argument Types from the + -- Con argument above, as they might be scoped over eta-reduced + -- variables. Instead of trying to figure out what the + -- eta-reduced variables should be substituted with post facto, + -- we opt for the simpler approach of using the context and + -- argument types from the reified constructor Info, which will + -- at least be correctly scoped. This will make the task of + -- substituting those types with the variables we put in + -- place of the eta-reduced variables (in normalizeDec) + -- much easier. + normalizeGadtC typename params tyvars context [n] + returnTy' argTys stricts (const $ return variant) + _ -> fail "normalizeCon: impossible" + 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. + DataInstance -> dataFamCompatCase + NewtypeInstance -> dataFamCompatCase + Datatype -> defaultCase + Newtype -> defaultCase +#else + in defaultCase +#endif + +#if MIN_VERSION_template_haskell(2,11,0) +normalizeStrictness :: Bang -> FieldStrictness +normalizeStrictness (Bang upk str) = + FieldStrictness (normalizeSourceUnpackedness upk) + (normalizeSourceStrictness str) + where + normalizeSourceUnpackedness :: SourceUnpackedness -> Unpackedness + normalizeSourceUnpackedness NoSourceUnpackedness = UnspecifiedUnpackedness + normalizeSourceUnpackedness SourceNoUnpack = NoUnpack + normalizeSourceUnpackedness SourceUnpack = Unpack + + normalizeSourceStrictness :: SourceStrictness -> Strictness + normalizeSourceStrictness NoSourceStrictness = UnspecifiedStrictness + normalizeSourceStrictness SourceLazy = Lazy + normalizeSourceStrictness SourceStrict = Strict +#else +normalizeStrictness :: Strict -> FieldStrictness +normalizeStrictness IsStrict = isStrictAnnot +normalizeStrictness NotStrict = notStrictAnnot +# if MIN_VERSION_template_haskell(2,7,0) +normalizeStrictness Unpacked = unpackedAnnot +# endif +#endif + normalizeGadtC :: - Name {- ^ Type constructor -} -> - [Type] {- ^ Type parameters -} -> - [TyVarBndr] {- ^ Constructor parameters -} -> - Cxt {- ^ Constructor context -} -> - [Name] {- ^ Constructor names -} -> - Type {- ^ Declared type of constructor -} -> - [Type] {- ^ Constructor field types -} -> - ConstructorVariant {- ^ Constructor variant -} -> + Name {- ^ Type constructor -} -> + [Type] {- ^ Type parameters -} -> + [TyVarBndr] {- ^ Constructor parameters -} -> + Cxt {- ^ Constructor context -} -> + [Name] {- ^ Constructor names -} -> + Type {- ^ Declared type of constructor -} -> + [Type] {- ^ Constructor field types -} -> + [FieldStrictness] {- ^ Constructor field strictness -} -> + (Name -> Q ConstructorVariant) + {- ^ Determine a constructor variant + from its 'Name' -} -> Q [ConstructorInfo] -normalizeGadtC typename params tyvars context names innerType fields variant = +normalizeGadtC typename params tyvars context names innerType + fields stricts getVariant = do innerType' <- resolveTypeSynonyms innerType case decomposeType innerType' of ConT innerTyCon :| ts | typename == innerTyCon -> @@ -332,8 +684,11 @@ context2 = applySubstitution subst (context1 ++ context) fields' = applySubstitution subst fields - in pure [ConstructorInfo name tyvars' context2 fields' variant - | name <- names] + in sequence [ ConstructorInfo name tyvars' context2 + fields' stricts <$> variantQ + | name <- names + , let variantQ = getVariant name + ] _ -> fail "normalizeGadtC: Expected type constructor application" @@ -352,17 +707,16 @@ aux (VarT n,p) (subst, context) = case p of VarT m | Map.notMember m subst -> (Map.insert m n subst, context) - _ -> (subst, EqualityT `AppT` VarT n `AppT` p : context) + _ -> (subst, equalPred (VarT n) p : context) aux _ sc = sc -#endif -- | Expand all of the type synonyms in a type. resolveTypeSynonyms :: Type -> Q Type resolveTypeSynonyms t = let f :| xs = decomposeType t - notTypeSynCase = foldl AppT f <$> traverse resolveTypeSynonyms xs in + notTypeSynCase = foldl AppT f <$> mapM resolveTypeSynonyms xs in case f of ConT n -> @@ -395,20 +749,38 @@ -- 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, +-- and return types. For instance, this +-- +-- (Show a, b ~ Int) => (a -> b) -> Char -> Int +-- +-- becomes +-- +-- ([Show a, b ~ Int], [a -> b, Char] :|- Int) +uncurryType :: Type -> (Cxt, NonEmptySnoc Type) +uncurryType = go [] [] + where + 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 -- contain unresolved infix applications. resolveInfixT :: Type -> Q Type #if MIN_VERSION_template_haskell(2,11,0) -resolveInfixT (ForallT vs cx t) = forallT vs (traverse resolveInfixT cx) (resolveInfixT t) +resolveInfixT (ForallT vs cx t) = forallT vs (mapM resolveInfixT cx) (resolveInfixT t) resolveInfixT (f `AppT` x) = resolveInfixT f `appT` resolveInfixT x resolveInfixT (ParensT t) = resolveInfixT t resolveInfixT (InfixT l o r) = conT o `appT` resolveInfixT l `appT` resolveInfixT r resolveInfixT (SigT t k) = SigT <$> resolveInfixT t <*> resolveInfixT k resolveInfixT t@UInfixT{} = resolveInfixT =<< resolveInfixT1 (gatherUInfixT t) -resolveInfixT t = pure t +resolveInfixT t = return t gatherUInfixT :: Type -> InfixList gatherUInfixT (UInfixT l o r) = ilAppend (gatherUInfixT l) o (gatherUInfixT r) @@ -419,7 +791,7 @@ resolveInfixT1 = go [] where go :: [(Type,Name,Fixity)] -> InfixList -> TypeQ - go ts (ILNil u) = pure (foldl (\acc (l,o,_) -> ConT o `AppT` l `AppT` acc) u ts) + go ts (ILNil u) = return (foldl (\acc (l,o,_) -> ConT o `AppT` l `AppT` acc) u ts) go ts (ILCons l o r) = do ofx <- fromMaybe defaultFixity <$> reifyFixity o let push = go ((l,o,ofx):ts) r @@ -455,7 +827,7 @@ #else -- older template-haskell packages don't have UInfixT -resolveInfixT = pure +resolveInfixT = return #endif @@ -484,6 +856,13 @@ takeFieldNames :: [(Name,a,b)] -> [Name] takeFieldNames xs = [a | (a,_,_) <- xs] +#if MIN_VERSION_template_haskell(2,11,0) +takeFieldStrictness :: [(a,Bang,b)] -> [FieldStrictness] +#else +takeFieldStrictness :: [(a,Strict,b)] -> [FieldStrictness] +#endif +takeFieldStrictness xs = [normalizeStrictness a | (_,a,_) <- xs] + takeFieldTypes :: [(a,b,Type)] -> [Type] takeFieldTypes xs = [a | (_,_,a) <- xs] @@ -506,7 +885,7 @@ freshenFreeVariables :: Type -> Q Type freshenFreeVariables t = do let xs = [ (n, VarT <$> newName (nameBase n)) | n <- freeVariables t] - subst <- sequenceA (Map.fromList xs) + subst <- T.sequence (Map.fromList xs) return (applySubstitution subst t) @@ -591,9 +970,9 @@ -- | Compute the type variable substitution that unifies a list of types, -- or fail in 'Q'. unifyTypes :: [Type] -> Q (Map Name Type) -unifyTypes [] = pure Map.empty +unifyTypes [] = return Map.empty unifyTypes (t:ts) = - do t':ts' <- traverse resolveTypeSynonyms (t:ts) + do t':ts' <- mapM resolveTypeSynonyms (t:ts) let aux sub u = do sub' <- unify' (applySubstitution sub t') (applySubstitution sub u) @@ -675,6 +1054,30 @@ ------------------------------------------------------------------------ +-- 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 +-- manually on any types without a signature. + +giveTypesStarKinds :: DatatypeInfo -> DatatypeInfo +giveTypesStarKinds info = + info { datatypeVars = annotateVars (datatypeVars info) } + where + annotateVars :: [Type] -> [Type] + annotateVars = map $ \t -> + case t of + VarT n -> SigT (VarT n) starK + _ -> t + +giveTyVarBndrsStarKinds :: ConstructorInfo -> ConstructorInfo +giveTyVarBndrsStarKinds info = + info { constructorVars = annotateVars (constructorVars info) } + where + annotateVars :: [TyVarBndr] -> [TyVarBndr] + annotateVars = map $ \tvb -> + case tvb of + PlainTV n -> KindedTV n starK + _ -> tvb + -- | Prior to GHC 8.2.1, reify was broken for data instances and newtype -- instances. This code attempts to detect the problem and repair it if -- possible. @@ -693,7 +1096,7 @@ -- https://ghc.haskell.org/trac/ghc/ticket/13618 repair13618 :: DatatypeInfo -> Q DatatypeInfo repair13618 info = - do s <- sequenceA (Map.fromList substList) + do s <- T.sequence (Map.fromList substList) return info { datatypeCons = applySubstitution s (datatypeCons info) } where @@ -728,7 +1131,7 @@ #elif MIN_VERSION_template_haskell(2,11,0) dataDCompat c n ts cs ds = dataD c n ts Nothing cs - (pure (map ConT ds)) + (return (map ConT ds)) #else dataDCompat = dataD #endif @@ -738,4 +1141,28 @@ arrowKCompat x y = arrowK `appK` x `appK` y #else arrowKCompat = arrowK +#endif + +------------------------------------------------------------------------ + +-- | Backwards compatibility wrapper for 'Fixity' lookup. +-- +-- In @template-haskell-2.11.0.0@ and later, the answer will always +-- be 'Just' of a fixity. +-- +-- Before @template-haskell-2.11.0.0@ it was only possible to determine +-- fixity information for variables, class methods, and data constructors. +-- In this case for type operators the answer could be 'Nothing', which +-- indicates that the answer is unavailable. +reifyFixityCompat :: Name -> Q (Maybe Fixity) +#if MIN_VERSION_template_haskell(2,11,0) +reifyFixityCompat n = (`mplus` Just defaultFixity) <$> reifyFixity n +#else +reifyFixityCompat n = + do info <- reify n + return $! case info of + ClassOpI _ _ _ fixity -> Just fixity + DataConI _ _ _ fixity -> Just fixity + VarI _ _ _ fixity -> Just fixity + _ -> Nothing #endif 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 @@ -14,3 +14,7 @@ eqTypeName :: Name eqTypeName = mkNameG_tc "base" "Data.Type.Equality" "~" + +-- This is only needed for GHC 7.6-specific bug +starKindName :: Name +starKindName = mkNameG_tc "ghc-prim" "GHC.Prim" "*" diff --git a/test/Harness.hs b/test/Harness.hs --- a/test/Harness.hs +++ b/test/Harness.hs @@ -1,4 +1,4 @@ -{-# Language TemplateHaskell #-} +{-# Language CPP, TemplateHaskell #-} {-| Module : Harness @@ -12,20 +12,17 @@ up to alpha renaming. -} -module Harness (validate) where +module Harness (validate, varKCompat) where import Control.Monad import qualified Data.Map as Map import Language.Haskell.TH import Language.Haskell.TH.Datatype +import Language.Haskell.TH.Lib (starK) 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 () @@ -38,29 +35,34 @@ let sub = Map.fromList (zip (freeVariables (datatypeVars dat2)) (map VarT (freeVariables (datatypeVars dat1)))) - check "datatypeContext" id + zipWithM_ (equateCxt "datatypeContext") (datatypeContext dat1) (applySubstitution sub (datatypeContext dat2)) check "datatypeVars" id - (map stripOuterSigT (datatypeVars dat1)) + (datatypeVars dat1) (applySubstitution sub (datatypeVars dat2)) zipWithM_ equateCI (datatypeCons dat1) (applySubstitution sub (datatypeCons dat2)) +equateCxt :: String -> Pred -> Pred -> Either String () +equateCxt lbl pred1 pred2 = + do check (lbl ++ " class") asClassPred pred1 pred2 + check (lbl ++ " equality") asEqualPred pred1 pred2 + -- | If the arguments are equal up to renaming return @'Right' ()@, -- otherwise return a string exlaining the mismatch. equateCI :: ConstructorInfo -> ConstructorInfo -> Either String () equateCI con1 con2 = - do check "constructorName" constructorName con1 con2 - check "constructorVariant" constructorVariant con1 con2 + do check "constructorName" constructorName con1 con2 + check "constructorVariant" constructorVariant con1 con2 let sub = Map.fromList (zip (map tvName (constructorVars con2)) (map VarT (map tvName (constructorVars con1)))) - check "constructorContext" id + zipWithM_ (equateCxt "constructorContext") (constructorContext con1) (applySubstitution sub (constructorContext con2)) @@ -68,7 +70,35 @@ (constructorFields con1) (applySubstitution sub (constructorFields con2)) + zipWithM_ equateStrictness + (constructorStrictness con1) + (constructorStrictness con2) + +equateStrictness :: FieldStrictness -> FieldStrictness -> Either String () +equateStrictness fs1 fs2 = + check "constructorStrictness" oldGhcHack fs1 fs2 + where +#if MIN_VERSION_template_haskell(2,7,0) + oldGhcHack = id +#else + -- GHC 7.0 and 7.2 didn't have an Unpacked TH constructor, so as a + -- simple workaround, we will treat unpackedAnnot as isStrictAnnot + -- (the closest equivalent). + oldGhcHack fs + | fs == unpackedAnnot = isStrictAnnot + | otherwise = fs +#endif + check :: (Show b, Eq b) => String -> (a -> b) -> a -> a -> Either String () check lbl f x y | f x == f y = Right () | otherwise = Left (lbl ++ ":\n\n" ++ show (f x) ++ "\n\n" ++ show (f y)) + +-- If on a recent-enough version of Template Haskell, construct a kind variable. +-- Otherwise, default to starK. +varKCompat :: Name -> Kind +#if MIN_VERSION_template_haskell(2,8,0) +varKCompat = VarT +#else +varKCompat _ = starK +#endif diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,5 +1,9 @@ -{-# Language CPP, PolyKinds, TypeFamilies, KindSignatures, TemplateHaskell, GADTs #-} +{-# Language CPP, TypeFamilies, KindSignatures, TemplateHaskell, GADTs #-} +#if MIN_VERSION_template_haskell(2,8,0) +{-# Language PolyKinds #-} +#endif + {-| Module : Main Description : Test cases for the th-abstraction package @@ -16,14 +20,18 @@ 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 + 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 @@ -43,20 +51,43 @@ 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,9,0) +# if MIN_VERSION_template_haskell(2,8,0) data family DF1 (a :: k) -#elif MIN_VERSION_template_haskell(2,8,0) -data family DF1 a -#else +# else data family DF1 (a :: *) -#endif +# endif data instance DF1 b = DF1 b -data VoidStoS (f :: * -> *) +# 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 :&&: + +#endif + return [] -- segment type declarations above from refiy below -- | Test entry point. Tests will pass or fail at compile time. @@ -69,21 +100,28 @@ equalTest showableTest recordTest + voidstosTest + strictDemoTest +#if MIN_VERSION_template_haskell(2,7,0) dataFamilyTest ghc78bugTest - voidstosTest + polyTest + gadtFamTest +#endif + fixityLookupTest adt1Test :: IO () adt1Test = $(do info <- reifyDatatype ''Adt1 - let [a,b] = map (VarT . mkName) ["a","b"] + let vars@[a,b] = map (VarT . mkName) ["a","b"] + [aSig,bSig] = map (\v -> SigT v starK) vars validate info DatatypeInfo { datatypeName = ''Adt1 , datatypeContext = [] - , datatypeVars = [a, b] + , datatypeVars = [aSig, bSig] , datatypeVariant = Datatype , datatypeCons = [ ConstructorInfo @@ -91,13 +129,15 @@ , constructorContext = [] , constructorVars = [] , constructorFields = [AppT (AppT (TupleT 2) a) b] + , constructorStrictness = [notStrictAnnot] , constructorVariant = NormalConstructor } , ConstructorInfo { constructorName = 'Adtc2 , constructorContext = [] , constructorVars = [] , constructorFields = [ConT ''Bool, ConT ''Int] - , constructorVariant = NormalConstructor } + , constructorStrictness = [notStrictAnnot, notStrictAnnot] + , constructorVariant = InfixConstructor } ] } ) @@ -112,7 +152,7 @@ DatatypeInfo { datatypeName = ''Gadt1 , datatypeContext = [] - , datatypeVars = [a] + , datatypeVars = [SigT a starK] , datatypeVariant = Datatype , datatypeCons = [ ConstructorInfo @@ -120,13 +160,29 @@ , constructorVars = [] , constructorContext = [equalPred a (ConT ''Int)] , constructorFields = [ConT ''Int] + , constructorStrictness = [notStrictAnnot] , constructorVariant = NormalConstructor } , ConstructorInfo { constructorName = 'Gadtc2 , constructorVars = [] , constructorContext = [] , constructorFields = [AppT (AppT (TupleT 2) a) a] + , constructorStrictness = [notStrictAnnot] , constructorVariant = NormalConstructor } + , ConstructorInfo + { constructorName = '(:**:) + , constructorVars = [] + , constructorContext = [equalPred a (TupleT 0)] + , constructorFields = [ConT ''Bool, ConT ''Char] + , constructorStrictness = [notStrictAnnot, notStrictAnnot] + , constructorVariant = InfixConstructor } + , ConstructorInfo + { constructorName = '(:!!:) + , constructorVars = [] + , constructorContext = [equalPred a (ConT ''Double)] + , constructorFields = [ConT ''Char, ConT ''Bool] + , constructorStrictness = [notStrictAnnot, notStrictAnnot] + , constructorVariant = NormalConstructor } ] } ) @@ -135,22 +191,24 @@ gadtrec1Test = $(do info <- reifyDatatype ''Gadtrec1 - let a = VarT (mkName "a") - let [v1,v2] = map mkName ["v1","v2"] + 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 = [PlainTV v1, PlainTV v2] - , constructorContext = + { constructorName = 'Gadtrecc1 + , constructorVars = [v1K, v2K] + , constructorContext = [equalPred a (AppT (AppT (TupleT 2) (VarT v1)) (VarT v2))] - , constructorFields = [VarT v1, VarT v2] - , constructorVariant = RecordConstructor ['gadtrec1a, 'gadtrec1b] } + , constructorFields = [VarT v1, VarT v2] + , constructorStrictness = [notStrictAnnot, notStrictAnnot] + , constructorVariant = RecordConstructor ['gadtrec1a, 'gadtrec1b] } validate info DatatypeInfo { datatypeName = ''Gadtrec1 , datatypeContext = [] - , datatypeVars = [a] + , datatypeVars = [SigT a starK] , datatypeVariant = Datatype , datatypeCons = [ con, con { constructorName = 'Gadtrecc2 } ] @@ -161,23 +219,26 @@ equalTest = $(do info <- reifyDatatype ''Equal - let [a,b,c] = map (VarT . mkName) ["a","b","c"] + let vars@[a,b,c] = map (VarT . mkName) ["a","b","c"] + [aSig,bSig,cSig] = map (\v -> SigT v starK) vars validate info DatatypeInfo { datatypeName = ''Equal , datatypeContext = [] - , datatypeVars = [a, b, c] + , datatypeVars = [aSig, bSig, cSig] , datatypeVariant = Datatype , datatypeCons = [ ConstructorInfo - { constructorName = 'Equalc - , constructorVars = [] - , constructorContext = + { constructorName = 'Equalc + , constructorVars = [] + , constructorContext = [equalPred a c, equalPred b c, classPred ''Read [c], classPred ''Show [c] ] - , constructorFields = + , constructorFields = [ListT `AppT` c, ConT ''Maybe `AppT` c] - , constructorVariant = NormalConstructor } + , constructorStrictness = + [notStrictAnnot, notStrictAnnot] + , constructorVariant = NormalConstructor } ] } ) @@ -196,11 +257,12 @@ , datatypeVariant = Datatype , datatypeCons = [ ConstructorInfo - { constructorName = 'Showable - , constructorVars = [PlainTV a] - , constructorContext = [classPred ''Show [VarT a]] - , constructorFields = [VarT a] - , constructorVariant = NormalConstructor } + { constructorName = 'Showable + , constructorVars = [PlainTV a] + , constructorContext = [classPred ''Show [VarT a]] + , constructorFields = [VarT a] + , constructorStrictness = [notStrictAnnot] + , constructorVariant = NormalConstructor } ] } ) @@ -216,11 +278,12 @@ , datatypeVariant = Datatype , datatypeCons = [ ConstructorInfo - { constructorName = 'R1 - , constructorVars = [] - , constructorContext = [] - , constructorFields = [ConT ''Int, ConT ''Int] - , constructorVariant = RecordConstructor ['field1, 'field2] } + { constructorName = 'R1 + , constructorVars = [] + , constructorContext = [] + , constructorFields = [ConT ''Int, ConT ''Int] + , constructorStrictness = [notStrictAnnot, notStrictAnnot] + , constructorVariant = RecordConstructor ['field1, 'field2] } ] } ) @@ -228,19 +291,21 @@ gadt2Test :: IO () gadt2Test = $(do info <- reifyDatatype ''Gadt2 - let [a,b] = map (VarT . mkName) ["a","b"] + let vars@[a,b] = map (VarT . mkName) ["a","b"] + [aSig,bSig] = map (\v -> SigT v starK) vars x = mkName "x" con = ConstructorInfo - { constructorName = undefined - , constructorVars = [] - , constructorContext = [] - , constructorFields = [] - , constructorVariant = NormalConstructor } + { constructorName = undefined + , constructorVars = [] + , constructorContext = [] + , constructorFields = [] + , constructorStrictness = [] + , constructorVariant = NormalConstructor } validate info DatatypeInfo { datatypeName = ''Gadt2 , datatypeContext = [] - , datatypeVars = [a, b] + , datatypeVars = [aSig, bSig] , datatypeVariant = Datatype , datatypeCons = [ con { constructorName = 'Gadt2c1 @@ -248,13 +313,51 @@ , con { constructorName = 'Gadt2c2 , constructorContext = [equalPred a (AppT ListT b)] } , con { constructorName = 'Gadt2c3 - , constructorVars = [PlainTV x] + , constructorVars = [KindedTV x starK] , constructorContext = [equalPred a (AppT ListT (VarT x)) ,equalPred b (AppT ListT (VarT x))] } ] } ) +voidstosTest :: IO () +voidstosTest = + $(do info <- reifyDatatype ''VoidStoS + let g = mkName "g" + validate info + DatatypeInfo + { datatypeName = ''VoidStoS + , datatypeContext = [] + , datatypeVars = [SigT (VarT g) (arrowKCompat starK starK)] + , datatypeVariant = Datatype + , datatypeCons = [] + } + ) + +strictDemoTest :: IO () +strictDemoTest = + $(do info <- reifyDatatype ''StrictDemo + validate info + DatatypeInfo + { datatypeName = ''StrictDemo + , datatypeContext = [] + , datatypeVars = [] + , datatypeVariant = Datatype + , datatypeCons = + [ ConstructorInfo + { constructorName = 'StrictDemo + , constructorVars = [] + , constructorContext = [] + , constructorFields = [ConT ''Int, ConT ''Int, ConT ''Int] + , constructorStrictness = [ notStrictAnnot + , isStrictAnnot + , unpackedAnnot + ] + , constructorVariant = NormalConstructor } ] + } + ) + +#if MIN_VERSION_template_haskell(2,7,0) dataFamilyTest :: IO () dataFamilyTest = $(do info <- reifyDatatype 'DFMaybe @@ -267,44 +370,117 @@ , datatypeVariant = DataInstance , datatypeCons = [ ConstructorInfo - { constructorName = 'DFMaybe - , constructorVars = [] - , constructorContext = [] - , constructorFields = [ConT ''Int, ListT `AppT` VarT a] - , constructorVariant = NormalConstructor } ] + { 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" + let c = VarT (mkName "c") validate info DatatypeInfo { datatypeName = ''DF1 , datatypeContext = [] - , datatypeVars = [VarT c] + , datatypeVars = [SigT c starK] , datatypeVariant = DataInstance , datatypeCons = [ ConstructorInfo - { constructorName = 'DF1 - , constructorVars = [] - , constructorContext = [] - , constructorFields = [VarT c] - , constructorVariant = NormalConstructor } ] + { constructorName = 'DF1 + , constructorVars = [] + , constructorContext = [] + , constructorFields = [c] + , constructorStrictness = [notStrictAnnot] + , constructorVariant = NormalConstructor } ] } ) -voidstosTest :: IO () -voidstosTest = - $(do info <- reifyDatatype ''VoidStoS - let g = mkName "g" +polyTest :: IO () +polyTest = + $(do info <- reifyDatatype 'MkPoly + let [a,k] = map mkName ["a","k"] validate info DatatypeInfo - { datatypeName = ''VoidStoS + { datatypeName = ''Poly , datatypeContext = [] - , datatypeVars = [VarT g] - , datatypeVariant = Datatype - , datatypeCons = [] + , datatypeVars = [SigT (VarT a) (varKCompat k)] + , datatypeVariant = DataInstance + , 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"] + [cTy,dTy,eTy,qTy] = map VarT names + [cSig,dSig] = map (\v -> SigT v starK) [cTy,dTy] + validate info + DatatypeInfo + { datatypeName = ''GadtFam + , datatypeContext = [] + , datatypeVars = [cSig,dSig] + , datatypeVariant = DataInstance + , datatypeCons = + [ ConstructorInfo + { constructorName = 'MkGadtFam1 + , constructorVars = [] + , constructorContext = [] + , constructorFields = [dTy,cTy] + , constructorStrictness = [notStrictAnnot, notStrictAnnot] + , constructorVariant = NormalConstructor } + , ConstructorInfo + { constructorName = '(:&&:) + , constructorVars = [PlainTV e] + , 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 } + , ConstructorInfo + { constructorName = 'MkGadtFam4 + , constructorVars = [] + , constructorContext = [ equalPred cTy dTy + , equalPred (ConT ''Int) dTy + ] + , constructorFields = [dTy] + , constructorStrictness = [notStrictAnnot] + , constructorVariant = NormalConstructor } + , ConstructorInfo + { constructorName = 'MkGadtFam5 + , constructorVars = [PlainTV q] + , constructorContext = [ equalPred cTy (ConT ''Bool) + , equalPred dTy (ConT ''Bool) + , equalPred qTy (ConT ''Char) + ] + , constructorFields = [qTy] + , constructorStrictness = [notStrictAnnot] + , constructorVariant = NormalConstructor } ] + } + ) +#endif + +fixityLookupTest :: IO () +fixityLookupTest = + $(do Just (Fixity 6 InfixR) <- reifyFixityCompat '(:**:) + [| return () |]) 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.3.0 +version: 0.2.0.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 @@ -17,7 +17,7 @@ build-type: Simple extra-source-files: ChangeLog.md cabal-version: >=1.10 -tested-with: GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2 +tested-with: GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2, GHC==7.2.2, GHC==7.0.4 source-repository head type: git @@ -26,9 +26,9 @@ library exposed-modules: Language.Haskell.TH.Datatype other-modules: Language.Haskell.TH.Datatype.Internal - build-depends: base >=4.5 && <5, + build-depends: base >=4.3 && <5, ghc-prim, - template-haskell >=2.7 && <2.13, + template-haskell >=2.5 && <2.13, containers >=0.4 && <0.6 hs-source-dirs: src default-language: Haskell2010