diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,189 @@ # Revision history for th-abstraction +## 0.7.2.0 -- 2026.01.03 +* Support GHC 9.14. + +## 0.7.1.0 -- 2024.12.05 +* Drop support for pre-8.0 versions of GHC. + +## 0.7.0.0 -- 2024.03.17 +* `DatatypeInfo` now has an additional `datatypeReturnKind` field. Most of the + time, this will be `StarT`, but this can also be more exotic kinds such as + `ConT ''UnliftedType` if dealing with primitive types, `UnliftedDatatypes`, + or `UnliftedNewtypes`. +* `reifyDatatype` and related functions now support primitive types such as + `Int#`. These will be reified as `DatatypeInfo`s with no `ConstructorInfo`s + and with `Datatype` as the `datatypeVariant`. +* `normalizeCon` now takes a `Kind` argument representing the return kind of + the parent data type. (This is sometimes necessary to determine which type + variables in the data constructor are universal or existential, depending + on if the variables appear in the return kind.) +* Fix a couple of bugs in which `normalizeDec` would return incorrect results + for GADTs that use `forall`s in their return kind. + +## 0.6.0.0 -- 2023.07.31 +* Support building with `template-haskell-2.21.0.0` (GHC 9.8). +* Adapt to `TyVarBndr`s for type-level declarations changing their type from + `TyVarBndr ()` to `TyVarBndr BndrVis` in `template-haskell`: + + * `Language.Haskell.TH.Datatype.TyVarBndr` now backports `type BndrVis = ()`, + as well as `BndrReq` and `BndrInvis` pattern synonyms. These make it + possible to write code involving `BndrVis` that is somewhat backwards + compatible (but do see the caveats in the Haddocks for `BndrInvis`). + * `Language.Haskell.TH.Datatype.TyVarBndr` also backports the following + definitions: + * The `type TyVarBndrVis = TyVarBndr BndrVis` type synonym. + * The `DefaultBndrFlag` class, which can be used to write code that is + polymorphic over `TyVarBndr` flags while still allowing the code to return + a reasonable default value for the flag. + * The `bndrReq` and `bndrInvis` definitions, which behave identically to + `BndrReq` and `BndrInvis`. + * `Language.Haskell.TH.Datatype.TyVarBndr` now defines the following utility + functions, which are not present in `template-haskell`: + * `plainTVReq`, `plainTVInvis`, `kindedTVReq`, and `kindedTVInvis` + functions, which construct `PlainTV`s and `KindedTV`s with particular + `BndrVis` flags. + * An `elimTVFlag`, which behaves like `elimTV`, but where the continuation + arguments also take a `flag` argument. (Note that the type of this + function is slightly different on old versions of `template-haskell`. + See the Haddocks for more.) + * A `tvFlag` function, which extracts the `flag` from a `TyVarBndr`. (Note + that the type of this function is slightly different on old versions of + `template-haskell`. See the Haddocks for more.) + * The types of the `dataDCompat` and `newtypeDCompat` functions have had + their `[TyVarBndrUnit]` arguments changed to `[TyVarBndrVis]`, matching + similar changes to `DataD` and `NewtypeD` in `template-haskell`. + + Because `BndrVis` is a synonym for `()` on pre-9.8 versions of GHC, this + change is unlikely to break any existing code, provided that you build it + with GHC 9.6 or earlier. If you build with GHC 9.8 or later, on the other + hand, it is likely that you will need to update your existing code. Here are + some possible ways that your code might fail to compile with GHC 9.8, along + with some migration strategies: + + * Your code passes a `TyVarBndrUnit` in a place where a `TyVarBndrVis` is now + expected in GHC 9.8, such as in the arguments to `dataDCompat`: + + ```hs + import "template-haskell" Language.Haskell.TH + import "th-abstraction" Language.Haskell.TH.Datatype (dataDCompat) + + dec :: DecQ + dec = dataDCompat (pure []) d [PlainTV a ()] [] [] + where + d = mkName "d" + a = mkName "a" + ``` + + With GHC 9.8, this will fail to compile with: + + ``` + error: [GHC-83865] + • Couldn't match expected type ‘BndrVis’ with actual type ‘()’ + • In the second argument of ‘PlainTV’, namely ‘()’ + In the expression: PlainTV a () + In the third argument of ‘dataDCompat’, namely ‘[PlainTV a ()]’ + | + | dec = dataDCompat (pure []) d [PlainTV a ()] [] [] + | ^^ + ``` + + Some possible ways to migrate this code include: + + * Use the `bndrReq` function or `BndrReq` pattern synonym in place of `()`, + making sure to import them from `Language.Haskell.TH.Datatype.TyVarBndr`: + + ```hs + ... + import "th-abstraction" Language.Haskell.TH.Datatype.TyVarBndr + + dec :: DecQ + dec = dataDCompat (pure []) d [PlainTV a bndrReq] [] [] + -- Or, alternatively: + {- + dec = dataDCompat (pure []) d [PlainTV a BndrReq] [] [] + -} + where + ... + ``` + * Use the `plainTV` function from `Language.Haskell.TH.Datatype.TyVarBndr`, + which is now sufficiently polymorphic to work as both a `TyVarBndrUnit` + and a `TyVarBndrVis`: + + ```hs + ... + import Language.Haskell.TH.Datatype.TyVarBndr + + dec :: DecQ + dec = dataDCompat (pure []) d [plainTV a] [] [] + where + ... + ``` + * You may have to replace some uses of `TyVarBndrUnit` with `TyVarBndrVis` + in your code. For instance, this will no longer typecheck in GHC 9.8 for + similar reasons to the previous example: + + ```hs + import "template-haskell" Language.Haskell.TH + import "th-abstraction" Language.Haskell.TH.Datatype (dataDCompat) + + dec :: DecQ + dec = dataDCompat (pure []) d tvbs [] [] + where + tvbs :: [TyVarBndrUnit] + tvbs = [plainTV a] + + d = mkName "d" + a = mkName "a" + ``` + + Here is a version that will typecheck with GHC 9.8 and earlier: + + ```hs + ... + import "th-abstraction" Language.Haskell.TH.Datatype.TyVarBndr + + dec :: DecQ + dec = dataDCompat (pure []) d tvbs [] [] + where + tvbs :: [TyVarBndrVis] + tvbs = [plainTV a] + + ... + ``` + * In some cases, the `TyVarBndrUnit`s might come from another place in the + code, e.g., + + ```hs + import "template-haskell" Language.Haskell.TH + import "th-abstraction" Language.Haskell.TH.Datatype (dataDCompat) + + dec :: [TyVarBndrUnit] -> DecQ + dec tvbs = dataDCompat (pure []) d tvbs [] [] + where + d = mkName "d" + ``` + + If it is not straightforward to change `dec`'s type to accept + `[TyVarBndrVis]` as an argument, another viable option is to use the + `changeTVFlags` function: + + ```hs + ... + import "th-abstraction" Language.Haskell.TH.Datatype.TyVarBndr + + dec :: [TyVarBndrUnit] -> DecQ + dec tvbs = dataDCompat (pure []) d tvbs' [] [] + where + tvbs' :: [TyVarBndrVis] + tvbs' = changeTVFlags bndrReq tvbs + + ... + ``` + + This guide, while not comprehensive, should cover most of the common cases one + will encounter when migrating their `th-abstraction` code to support GHC 9.8. + ## 0.5.0.0 -- 2023.02.27 * Support the `TypeData` language extension added in GHC 9.6. The `DatatypeVariant` data type now has a separate `TypeData` constructor to 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,2272 +1,2277 @@ -{-# Language CPP, DeriveDataTypeable #-} - -#if MIN_VERSION_base(4,4,0) -#define HAS_GENERICS -{-# Language DeriveGeneric #-} -#endif - -#if MIN_VERSION_template_haskell(2,12,0) -{-# Language Safe #-} -#elif __GLASGOW_HASKELL__ >= 702 -{-# Language Trustworthy #-} -#endif - -{-| -Module : Language.Haskell.TH.Datatype -Description : Backwards-compatible interface to reified information about datatypes. -Copyright : Eric Mertens 2017-2020 -License : ISC -Maintainer : emertens@gmail.com - -This module provides a flattened view of information about data types -and newtypes that can be supported uniformly across multiple versions -of the @template-haskell@ package. - -Sample output for @'reifyDatatype' ''Maybe@ - -@ -'DatatypeInfo' - { 'datatypeContext' = [] - , 'datatypeName' = GHC.Base.Maybe - , 'datatypeVars' = [ 'KindedTV' a_3530822107858468866 () 'StarT' ] - , 'datatypeInstTypes' = [ 'SigT' ('VarT' a_3530822107858468866) 'StarT' ] - , 'datatypeVariant' = 'Datatype' - , 'datatypeCons' = - [ 'ConstructorInfo' - { 'constructorName' = GHC.Base.Nothing - , 'constructorVars' = [] - , 'constructorContext' = [] - , 'constructorFields' = [] - , 'constructorStrictness' = [] - , 'constructorVariant' = 'NormalConstructor' - } - , 'ConstructorInfo' - { 'constructorName' = GHC.Base.Just - , 'constructorVars' = [] - , 'constructorContext' = [] - , 'constructorFields' = [ 'VarT' a_3530822107858468866 ] - , 'constructorStrictness' = [ 'FieldStrictness' - 'UnspecifiedUnpackedness' - 'Lazy' - ] - , 'constructorVariant' = 'NormalConstructor' - } - ] - } -@ - -Datatypes declared with GADT syntax are normalized to constructors with existentially -quantified type variables and equality constraints. - --} -module Language.Haskell.TH.Datatype - ( - -- * Types - DatatypeInfo(..) - , ConstructorInfo(..) - , DatatypeVariant(..) - , ConstructorVariant(..) - , FieldStrictness(..) - , Unpackedness(..) - , Strictness(..) - - -- * Normalization functions - , reifyDatatype - , reifyConstructor - , reifyRecord - , normalizeInfo - , normalizeDec - , normalizeCon - - -- * 'DatatypeInfo' lookup functions - , lookupByConstructorName - , lookupByRecordName - - -- * Type variable manipulation - , TypeSubstitution(..) - , quantifyType - , freeVariablesWellScoped - , freshenFreeVariables - - -- * 'Pred' functions - , equalPred - , classPred - , asEqualPred - , asClassPred - - -- * Backward compatible data definitions - , dataDCompat - , newtypeDCompat - , tySynInstDCompat - , pragLineDCompat - , arrowKCompat - - -- * Strictness annotations - , isStrictAnnot - , notStrictAnnot - , unpackedAnnot - - -- * Type simplification - , resolveTypeSynonyms - , resolveKindSynonyms - , resolvePredSynonyms - , resolveInfixT - - -- * Fixities - , reifyFixityCompat - , showFixity - , showFixityDirection - - -- * Convenience functions - , unifyTypes - , tvName - , tvKind - , datatypeType - ) where - -import Data.Data (Typeable, Data) -import Data.Foldable (foldMap, foldl') -import Data.List (mapAccumL, nub, find, union, (\\)) -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Maybe -import qualified Data.Set as Set -import Data.Set (Set) -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.Datatype.TyVarBndr -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.Monoid (Monoid(..)) -#endif - --- | Normalized information about newtypes and data types. --- --- 'DatatypeInfo' contains two fields, 'datatypeVars' and 'datatypeInstTypes', --- which encode information about the argument types. The simplest explanation --- is that 'datatypeVars' contains all the type /variables/ bound by the data --- type constructor, while 'datatypeInstTypes' contains the type /arguments/ --- to the data type constructor. To be more precise: --- --- * For ADTs declared with @data@ and @newtype@, it will likely be the case --- that 'datatypeVars' and 'datatypeInstTypes' coincide. For instance, given --- @newtype Id a = MkId a@, in the 'DatatypeInfo' for @Id@ we would --- have @'datatypeVars' = ['KindedTV' a () 'StarT']@ and --- @'datatypeInstVars' = ['SigT' ('VarT' a) 'StarT']@. --- --- ADTs that leverage @PolyKinds@ may have more 'datatypeVars' than --- 'datatypeInstTypes'. For instance, given @data Proxy (a :: k) = MkProxy@, --- in the 'DatatypeInfo' for @Proxy@ we would have --- @'datatypeVars' = ['KindedTV' k () 'StarT', 'KindedTV' a () ('VarT' k)]@ --- (since there are two variables, @k@ and @a@), whereas --- @'datatypeInstTypes' = ['SigT' ('VarT' a) ('VarT' k)]@, since there is --- only one explicit type argument to @Proxy@. --- --- * For @data instance@s and @newtype instance@s of data families, --- 'datatypeVars' and 'datatypeInstTypes' can be quite different. Here is --- an example to illustrate the difference: --- --- @ --- data family F a b --- data instance F (Maybe c) (f x) = MkF c (f x) --- @ --- --- Then in the 'DatatypeInfo' for @F@'s data instance, we would have: --- --- @ --- 'datatypeVars' = [ 'KindedTV' c () 'StarT' --- , 'KindedTV' f () 'StarT' --- , 'KindedTV' x () 'StarT' ] --- 'datatypeInstTypes' = [ 'AppT' ('ConT' ''Maybe) ('VarT' c) --- , 'AppT' ('VarT' f) ('VarT' x) ] --- @ -data DatatypeInfo = DatatypeInfo - { datatypeContext :: Cxt -- ^ Data type context (deprecated) - , datatypeName :: Name -- ^ Type constructor - , datatypeVars :: [TyVarBndrUnit] -- ^ Type parameters - , datatypeInstTypes :: [Type] -- ^ Argument types - , datatypeVariant :: DatatypeVariant -- ^ Extra information - , datatypeCons :: [ConstructorInfo] -- ^ Normalize constructor information - } - 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@. - -- - -- A 'DatatypeInfo' that uses 'Newtype' will uphold the - -- invariant that there will be exactly one - -- 'ConstructorInfo' in the 'datatypeCons'. - | DataInstance -- ^ Type declared with @data instance@. - | NewtypeInstance -- ^ Type declared with @newtype instance@. - -- - -- A 'DatatypeInfo' that uses 'NewtypeInstance' will - -- uphold the invariant that there will be exactly one - -- 'ConstructorInfo' in the 'datatypeCons'. - | TypeData -- ^ Type declared with @type data@. - -- - -- A 'DatatypeInfo' that uses 'TypeData' will uphold the - -- following invariants: - -- - -- * The 'datatypeContext' will be empty. - -- - -- * None of the 'constructorVariant's in any of the - -- 'datatypeCons' will be 'RecordConstructor'. - -- - -- * Each of the 'constructorStrictness' values in each - -- of the 'datatypeCons' will be equal to - -- 'notStrictAnnot'. - 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 :: [TyVarBndrUnit] -- ^ 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 -#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 -#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 -datatypeType di - = foldl AppT (ConT (datatypeName di)) - $ map stripSigT - $ datatypeInstTypes di - - --- | Compute a normalized view of the metadata about a data type or newtype --- 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/, --- 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) --- kinds. For instance, the following GADT's constructors: --- --- @ --- data T (a :: k -> *) where --- MkT1 :: T Proxy --- MkT2 :: T Maybe --- @ --- --- will be normalized to the following equality constraints: --- --- @ --- AppT (AppT EqualityT (VarT a)) (ConT Proxy) -- MkT1 --- AppT (AppT EqualityT (VarT a)) (ConT Maybe) -- MkT2 --- @ --- --- But only the first equality constraint is well kinded, since in the second --- 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. --- --- 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 {- ^ data type or constructor name -} -> - Q DatatypeInfo -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" isn'tReified - -normalizeInfo' :: String -> IsReifiedDec -> Info -> Q DatatypeInfo -normalizeInfo' entry reifiedDec 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 -> normalizeDecFor reifiedDec dec -#if MIN_VERSION_template_haskell(2,11,0) - DataConI name _ parent -> reifyParent name parent - -- 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 - VarI recName recTy _ _ -> reifyRecordType recName recTy -#endif - _ -> bad "Expected a type constructor" - where - bad msg = fail (entry ++ ": " ++ msg) - - -reifyParent :: Name -> Name -> Q DatatypeInfo -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 -#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 instances1 <- mapM (repairDataFam dec) instances - instances2 <- mapM (normalizeDecFor isReified) instances1 - case find p instances2 of - Just inst -> return inst - Nothing -> panic "lost the instance" -#endif - _ -> panic "unexpected parent" - where - 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 --- (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 - --- 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' :: [TyVarBndrUnit] -> Maybe Kind -> [Type] -> Q [Type] -repairVarKindsWith' dvars dkind ts = - let kindVars = freeVariables . map kindPart - kindPart (KindedTV _ k) = [k] - kindPart (PlainTV _ ) = [] - - 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 fmap (applySubstitution (Map.fromList (zip kparams tsKinds'))) $ - repairVarKindsWith dvars dkind ts' - - --- 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 :: - Dec {- ^ family declaration -} -> - Dec {- ^ instance declaration -} -> - Q Dec {- ^ instance declaration -} - -repairDataFam - (FamilyD _ _ dvars dk) - (NewtypeInstD cx n ts con deriv) = do - ts' <- repairVarKindsWith' dvars dk ts - return $ NewtypeInstD cx n ts' con deriv -repairDataFam - (FamilyD _ _ dvars dk) - (DataInstD cx n ts cons deriv) = do - ts' <- repairVarKindsWith' dvars dk ts - return $ DataInstD cx n ts' cons deriv -#else -repairDataFam famD instD -# if MIN_VERSION_template_haskell(2,15,0) - | DataFamilyD _ dvars dk <- famD - , NewtypeInstD cx mbInstVars nts k c deriv <- instD - , con :| ts <- decomposeType nts - = do ts' <- repairVarKindsWith dvars dk ts - return $ NewtypeInstD cx mbInstVars (foldl' AppT con ts') k c deriv - - | DataFamilyD _ dvars dk <- famD - , DataInstD cx mbInstVars nts k c deriv <- instD - , con :| ts <- decomposeType nts - = do ts' <- repairVarKindsWith dvars dk ts - return $ DataInstD cx mbInstVars (foldl' AppT con ts') k c deriv -# elif MIN_VERSION_template_haskell(2,11,0) - | DataFamilyD _ dvars dk <- famD - , NewtypeInstD cx n ts k c deriv <- instD - = do ts' <- repairVarKindsWith dvars dk ts - return $ NewtypeInstD cx n ts' k c deriv - - | DataFamilyD _ dvars dk <- famD - , DataInstD cx n ts k c deriv <- instD - = do ts' <- repairVarKindsWith dvars dk ts - return $ DataInstD cx n ts' k c deriv -# else - | FamilyD _ _ dvars dk <- famD - , NewtypeInstD cx n ts c deriv <- instD - = do ts' <- repairVarKindsWith dvars dk ts - return $ NewtypeInstD cx n ts' c deriv - - | FamilyD _ _ dvars dk <- famD - , DataInstD cx n ts c deriv <- instD - = do ts' <- repairVarKindsWith dvars dk ts - return $ DataInstD cx n ts' c deriv -# endif -#endif -repairDataFam _ instD = return instD - --- | @'repairVarKindsWith' tvbs mbKind ts@ returns @ts@, but where each element --- has an explicit kind signature taken from a 'TyVarBndr' in the corresponding --- position in @tvbs@, or from the corresponding kind argument in 'mbKind' if --- there aren't enough 'TyVarBndr's available. An example where @tvbs@ can be --- shorter than @ts@ can be found in this example from #95: --- --- @ --- data family F :: Type -> Type --- data instance F a = C --- @ --- --- The @F@ has no type variable binders in its @data family@ declaration, and --- it has a return kind of @Type -> Type@. As a result, we pair up @Type@ with --- @VarT a@ to get @SigT a (ConT ''Type)@. -repairVarKindsWith :: [TyVarBndrUnit] -> Maybe Kind -> [Type] -> Q [Type] -repairVarKindsWith tvbs mbKind ts = do - extra_tvbs <- mkExtraKindBinders $ fromMaybe starK mbKind - -- This list should be the same length as @ts@. If it isn't, something has - -- gone terribly wrong. - let tvbs' = tvbs ++ extra_tvbs - return $ zipWith stealKindForType tvbs' ts - --- If a VarT is missing an explicit kind signature, steal it from a TyVarBndr. -stealKindForType :: TyVarBndr_ flag -> Type -> Type -stealKindForType tvb t@VarT{} = SigT t (tvKind tvb) -stealKindForType _ t = t - --- | Normalize 'Dec' for a newtype or datatype into a 'DatatypeInfo'. --- Fail in 'Q' otherwise. --- --- 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' --- 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,20,0) - TypeDataD name tyvars mbKind cons -> - normalizeDataD [] name tyvars mbKind cons TypeData -#endif -#if MIN_VERSION_template_haskell(2,12,0) - NewtypeD context name tyvars mbKind con _derives -> - normalizeDataD context name tyvars mbKind [con] Newtype - DataD context name tyvars mbKind cons _derives -> - normalizeDataD context name tyvars mbKind cons Datatype -# if MIN_VERSION_template_haskell(2,15,0) - NewtypeInstD context mbTyvars nameInstTys mbKind con _derives -> - normalizeDataInstDPostTH2'15 "newtype" context mbTyvars nameInstTys - mbKind [con] NewtypeInstance - DataInstD context mbTyvars nameInstTys mbKind cons _derives -> - normalizeDataInstDPostTH2'15 "data" context mbTyvars nameInstTys - mbKind cons DataInstance -# else - NewtypeInstD context name instTys mbKind con _derives -> - normalizeDataInstDPreTH2'15 context name instTys mbKind [con] NewtypeInstance - DataInstD context name instTys mbKind cons _derives -> - normalizeDataInstDPreTH2'15 context name instTys mbKind cons DataInstance -# endif -#elif MIN_VERSION_template_haskell(2,11,0) - NewtypeD context name tyvars mbKind con _derives -> - normalizeDataD context name tyvars mbKind [con] Newtype - DataD context name tyvars mbKind cons _derives -> - normalizeDataD context name tyvars mbKind cons Datatype - NewtypeInstD context name instTys mbKind con _derives -> - normalizeDataInstDPreTH2'15 context name instTys mbKind [con] NewtypeInstance - DataInstD context name instTys mbKind cons _derives -> - normalizeDataInstDPreTH2'15 context name instTys mbKind cons DataInstance -#else - NewtypeD context name tyvars con _derives -> - normalizeDataD context name tyvars Nothing [con] Newtype - DataD context name tyvars cons _derives -> - normalizeDataD context name tyvars Nothing cons Datatype - NewtypeInstD context name instTys con _derives -> - normalizeDataInstDPreTH2'15 context name instTys Nothing [con] NewtypeInstance - DataInstD context name instTys cons _derives -> - normalizeDataInstDPreTH2'15 context name instTys Nothing cons DataInstance -#endif - _ -> fail "normalizeDecFor: DataD or NewtypeD required" - where - -- We only need to repair reified declarations for data family instances. - repair13618' :: DatatypeInfo -> Q DatatypeInfo - repair13618' di@DatatypeInfo{datatypeVariant = variant} - | isReified && isFamInstVariant variant - = repair13618 di - | otherwise - = return di - - -- Given a data type's instance types and kind, compute its free variables. - datatypeFreeVars :: [Type] -> Maybe Kind -> [TyVarBndrUnit] - datatypeFreeVars instTys mbKind = - freeVariablesWellScoped $ instTys ++ -#if MIN_VERSION_template_haskell(2,8,0) - maybeToList mbKind -#else - [] -- No kind variables -#endif - - normalizeDataD :: Cxt -> Name -> [TyVarBndrUnit] -> Maybe Kind - -> [Con] -> DatatypeVariant -> Q DatatypeInfo - normalizeDataD context name tyvars mbKind cons variant = - let params = bndrParams tyvars in - normalize' context name (datatypeFreeVars params mbKind) - params mbKind cons variant - - normalizeDataInstDPostTH2'15 - :: String -> Cxt -> Maybe [TyVarBndrUnit] -> Type -> Maybe Kind - -> [Con] -> DatatypeVariant -> Q DatatypeInfo - normalizeDataInstDPostTH2'15 what context mbTyvars nameInstTys - mbKind cons variant = - case decomposeType nameInstTys of - ConT name :| instTys -> - normalize' context name - (fromMaybe (datatypeFreeVars instTys mbKind) mbTyvars) - instTys mbKind cons variant - _ -> fail $ "Unexpected " ++ what ++ " instance head: " ++ pprint nameInstTys - - normalizeDataInstDPreTH2'15 - :: Cxt -> Name -> [Type] -> Maybe Kind - -> [Con] -> DatatypeVariant -> Q DatatypeInfo - normalizeDataInstDPreTH2'15 context name instTys mbKind cons variant = - normalize' context name (datatypeFreeVars instTys mbKind) - instTys mbKind cons variant - - -- The main worker of this function. - normalize' :: Cxt -> Name -> [TyVarBndrUnit] -> [Type] -> Maybe Kind - -> [Con] -> DatatypeVariant -> Q DatatypeInfo - normalize' context name tvbs instTys mbKind cons variant = do - extra_tvbs <- mkExtraKindBinders $ fromMaybe starK mbKind - let tvbs' = tvbs ++ extra_tvbs - instTys' = instTys ++ bndrParams extra_tvbs - dec <- normalizeDec' isReified context name tvbs' instTys' cons variant - repair13618' $ giveDIVarsStarKinds isReified dec - --- | Create new kind variable binder names corresponding to the return kind of --- a data type. This is useful when you have a data type like: --- --- @ --- data Foo :: forall k. k -> Type -> Type where ... --- @ --- --- But you want to be able to refer to the type @Foo a b@. --- 'mkExtraKindBinders' will take the kind @forall k. k -> Type -> Type@, --- discover that is has two visible argument kinds, and return as a result --- two new kind variable binders @[a :: k, b :: Type]@, where @a@ and @b@ --- are fresh type variable names. --- --- This expands kind synonyms if necessary. -mkExtraKindBinders :: Kind -> Q [TyVarBndrUnit] -mkExtraKindBinders kind = do - kind' <- resolveKindSynonyms kind - let (_, _, args :|- _) = uncurryKind kind' - names <- replicateM (length args) (newName "x") - return $ zipWith kindedTV names args - --- | Is a declaration for a @data instance@ or @newtype instance@? -isFamInstVariant :: DatatypeVariant -> Bool -isFamInstVariant dv = - case dv of - Datatype -> False - Newtype -> False - DataInstance -> True - NewtypeInstance -> True - TypeData -> False - -bndrParams :: [TyVarBndr_ flag] -> [Type] -bndrParams = map $ elimTV VarT (\n k -> SigT (VarT n) k) - --- | Remove the outermost 'SigT'. -stripSigT :: Type -> Type -stripSigT (SigT t _) = t -stripSigT t = t - - -normalizeDec' :: - IsReifiedDec {- ^ Is this a reified 'Dec'? -} -> - Cxt {- ^ Datatype context -} -> - Name {- ^ Type constructor -} -> - [TyVarBndrUnit] {- ^ Type parameters -} -> - [Type] {- ^ Argument types -} -> - [Con] {- ^ Constructors -} -> - DatatypeVariant {- ^ Extra information -} -> - Q DatatypeInfo -normalizeDec' reifiedDec context name params instTys cons variant = - do cons' <- concat <$> mapM (normalizeConFor reifiedDec name params instTys variant) cons - return DatatypeInfo - { datatypeContext = context - , datatypeName = name - , datatypeVars = params - , datatypeInstTypes = instTys - , datatypeCons = cons' - , datatypeVariant = variant - } - --- | Normalize a 'Con' into a 'ConstructorInfo'. This requires knowledge of --- 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 -} -> - [TyVarBndrUnit] {- ^ Type parameters -} -> - [Type] {- ^ Argument types -} -> - DatatypeVariant {- ^ Extra information -} -> - Con {- ^ Constructor -} -> - Q [ConstructorInfo] -normalizeCon = normalizeConFor isn'tReified - -normalizeConFor :: - IsReifiedDec {- ^ Is this a reified 'Dec'? -} -> - Name {- ^ Type constructor -} -> - [TyVarBndrUnit] {- ^ Type parameters -} -> - [Type] {- ^ Argument types -} -> - DatatypeVariant {- ^ Extra information -} -> - Con {- ^ Constructor -} -> - Q [ConstructorInfo] -normalizeConFor reifiedDec typename params instTys variant = - fmap (map (giveCIVarsStarKinds reifiedDec)) . dispatch - where - -- 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) - -- Don't call reifyFixityCompat here! We need to be able to distinguish - -- between a default fixity and an explicit @infixl 9@. - mbFi <- return Nothing `recover` 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. - mbFi <- reifyFixityCompat n - let userSuppliedFixity = isJust mbFi && mbFi /= Just 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 :: [TyVarBndrUnit] - -> 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 (changeTVFlags () tyvars'++tyvars) (context'++context) True c' -#if MIN_VERSION_template_haskell(2,11,0) - 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 instTys 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 stricts NormalConstructor - InfixC l n r -> - let stricts = map (normalizeStrictness . fst) [l,r] in - dataFamCase' n stricts InfixConstructor - RecC n xs -> - let stricts = takeFieldStrictness xs in - dataFamCase' n stricts - (RecordConstructor (takeFieldNames xs)) - ForallC tyvars' context' c' -> - go (tyvars'++tyvars) c' - - dataFamCase' :: Name -> [FieldStrictness] - -> ConstructorVariant - -> Q [ConstructorInfo] - dataFamCase' n stricts variant = do - mbInfo <- reifyMaybe n - case mbInfo of - Just (DataConI _ ty _ _) -> do - let (tyvars, context, argTys :|- returnTy) = uncurryType ty - returnTy' <- resolveTypeSynonyms returnTy - -- Notice that we've ignored the TyVarBndrs, 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 instTys tyvars context [n] - returnTy' argTys stricts (const $ return variant) - _ -> fail $ unlines - [ "normalizeCon: Cannot reify constructor " ++ nameBase n - , "You are likely calling normalizeDec on GHC 7.6 or 7.8 on a data family" - , "whose type variables have been eta-reduced due to GHC Trac #9692." - , "Unfortunately, without being able to reify the constructor's type," - , "there is no way to recover the eta-reduced type variables in general." - , "A recommended workaround is to use reifyDatatype instead." - ] - - -- A very ad hoc way of determining if we need to perform some extra passes - -- to repair an eta-reduction bug for data family instances that only occurs - -- with GHC 7.6 and 7.8. We want to avoid doing these passes if at all possible, - -- since they require reifying extra information, and reifying during - -- normalization can be problematic for locally declared Template Haskell - -- splices (see ##22). - mightHaveBeenEtaReduced :: [Type] -> Bool - mightHaveBeenEtaReduced ts = - case unsnoc ts of - Nothing -> False - Just (initTs :|- lastT) -> - case varTName lastT of - Nothing -> False - Just n -> not (n `elem` freeVariables initTs) - - -- If the list is empty returns 'Nothing', otherwise returns the - -- 'init' and the 'last'. - unsnoc :: [a] -> Maybe (NonEmptySnoc a) - unsnoc [] = Nothing - unsnoc (x:xs) = case unsnoc xs of - Just (a :|- b) -> Just ((x:a) :|- b) - Nothing -> Just ([] :|- x) - - -- If a Type is a VarT, find Just its Name. Otherwise, return Nothing. - varTName :: Type -> Maybe Name - varTName (SigT t _) = varTName t - varTName (VarT n) = Just n - varTName _ = Nothing - - 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 (but only for reified data family instances). - DataInstance - | reifiedDec, mightHaveBeenEtaReduced instTys - -> dataFamCompatCase - NewtypeInstance - | reifiedDec, mightHaveBeenEtaReduced instTys - -> dataFamCompatCase - _ -> 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 -} -> - [TyVarBndrUnit] {- ^ Type parameters -} -> - [Type] {- ^ Argument types -} -> - [TyVarBndrUnit] {- ^ 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 instTys tyvars context names innerType - fields stricts getVariant = - do -- It's possible that the constructor has implicitly quantified type - -- variables, such as in the following example (from #58): - -- - -- [d| data Foo where - -- MkFoo :: a -> Foo |] - -- - -- normalizeGadtC assumes that all type variables have binders, however, - -- so we use freeVariablesWellScoped to obtain the implicit type - -- variables' binders before proceeding. - let implicitTyvars = freeVariablesWellScoped - [curryType (changeTVFlags SpecifiedSpec tyvars) - context fields innerType] - allTyvars = implicitTyvars ++ tyvars - - -- Due to GHC Trac #13885, it's possible that the type variables bound by - -- a GADT constructor will shadow those that are bound by the data type. - -- This function assumes this isn't the case in certain parts (e.g., when - -- mergeArguments is invoked), so we do an alpha-renaming of the - -- constructor-bound variables before proceeding. See #36 for an example - -- of what can go wrong if this isn't done. - let conBoundNames = - concatMap (\tvb -> tvName tvb:freeVariables (tvKind tvb)) allTyvars - conSubst <- T.sequence $ Map.fromList [ (n, newName (nameBase n)) - | n <- conBoundNames ] - let conSubst' = fmap VarT conSubst - renamedTyvars = - map (elimTV (\n -> plainTV (conSubst Map.! n)) - (\n k -> kindedTV (conSubst Map.! n) - (applySubstitution conSubst' k))) allTyvars - renamedContext = applySubstitution conSubst' context - renamedInnerType = applySubstitution conSubst' innerType - renamedFields = applySubstitution conSubst' fields - - innerType' <- resolveTypeSynonyms renamedInnerType - case decomposeType innerType' of - ConT innerTyCon :| ts | typename == innerTyCon -> - - let (substName, context1) = - closeOverKinds (kindsOfFVsOfTvbs renamedTyvars) - (kindsOfFVsOfTvbs params) - (mergeArguments instTys ts) - subst = VarT <$> substName - exTyvars = [ tv | tv <- renamedTyvars, Map.notMember (tvName tv) subst ] - - -- The use of substTyVarBndrKinds below will never capture, as the - -- range of the substitution will always use distinct names from - -- exTyvars due to the alpha-renaming pass above. - exTyvars' = substTyVarBndrKinds subst exTyvars - context2 = applySubstitution subst (context1 ++ renamedContext) - fields' = applySubstitution subst renamedFields - in sequence [ ConstructorInfo name exTyvars' context2 - fields' stricts <$> variantQ - | name <- names - , let variantQ = getVariant name - ] - - _ -> fail "normalizeGadtC: Expected type constructor application" - -{- -Extend a type variable renaming subtitution and a list of equality -predicates by looking into kind information as much as possible. - -Why is this necessary? Consider the following example: - - data (a1 :: k1) :~: (b1 :: k1) where - Refl :: forall k2 (a2 :: k2). a2 :~: a2 - -After an initial call to mergeArguments, we will have the following -substitution and context: - -* Substitution: [a2 :-> a1] -* Context: (a2 ~ b1) - -We shouldn't stop there, however! We determine the existentially quantified -type variables of a constructor by filtering out those constructor-bound -variables which do not appear in the substitution that mergeArguments -returns. In this example, Refl's bound variables are k2 and a2. a2 appears -in the returned substitution, but k2 does not, which means that we would -mistakenly conclude that k2 is existential! - -Although we don't have the full power of kind inference to guide us here, we -can at least do the next best thing. Generally, the datatype-bound type -variables and the constructor type variable binders contain all of the kind -information we need, so we proceed as follows: - -1. Construct a map from each constructor-bound variable to its kind. (Do the - same for each datatype-bound variable). These maps are the first and second - arguments to closeOverKinds, respectively. -2. Call mergeArguments once on the GADT return type and datatype-bound types, - and pass that in as the third argument to closeOverKinds. -3. For each name-name pair in the supplied substitution, check if the first and - second names map to kinds in the first and second kind maps in - closeOverKinds, respectively. If so, associate the first kind with the - second kind. -4. For each kind association discovered in part (3), call mergeArguments - on the lists of kinds. This will yield a kind substitution and kind - equality context. -5. If the kind substitution is non-empty, then go back to step (3) and repeat - the process on the new kind substitution and context. - - Otherwise, if the kind substitution is empty, then we have reached a fixed- - point (i.e., we have closed over the kinds), so proceed. -6. Union up all of the substitutions and contexts, and return those. - -This algorithm is not perfect, as it will only catch everything if all of -the kinds are explicitly mentioned somewhere (and not left quantified -implicitly). Thankfully, reifying data types via Template Haskell tends to -yield a healthy amount of kind signatures, so this works quite well in -practice. --} -closeOverKinds :: Map Name Kind - -> Map Name Kind - -> (Map Name Name, Cxt) - -> (Map Name Name, Cxt) -closeOverKinds domainFVKinds rangeFVKinds = go - where - go :: (Map Name Name, Cxt) -> (Map Name Name, Cxt) - go (subst, context) = - let substList = Map.toList subst - (kindsInner, kindsOuter) = - unzip $ - mapMaybe (\(d, r) -> do d' <- Map.lookup d domainFVKinds - r' <- Map.lookup r rangeFVKinds - return (d', r')) - substList - (kindSubst, kindContext) = mergeArgumentKinds kindsOuter kindsInner - (restSubst, restContext) - = if Map.null kindSubst -- Fixed-point calculation - then (Map.empty, []) - else go (kindSubst, kindContext) - finalSubst = Map.unions [subst, kindSubst, restSubst] - finalContext = nub $ concat [context, kindContext, restContext] - -- Use `nub` here in an effort to minimize the number of - -- redundant equality constraints in the returned context. - in (finalSubst, finalContext) - --- Look into a list of types and map each free variable name to its kind. -kindsOfFVsOfTypes :: [Type] -> Map Name Kind -kindsOfFVsOfTypes = foldMap go - where - go :: Type -> Map Name Kind - go (AppT t1 t2) = go t1 `Map.union` go t2 - go (SigT t k) = - let kSigs = -#if MIN_VERSION_template_haskell(2,8,0) - go k -#else - Map.empty -#endif - in case t of - VarT n -> Map.insert n k kSigs - _ -> go t `Map.union` kSigs - - go (ForallT {}) = forallError -#if MIN_VERSION_template_haskell(2,16,0) - go (ForallVisT {}) = forallError -#endif - - go _ = Map.empty - - forallError :: a - forallError = error "`forall` type used in data family pattern" - --- Look into a list of type variable binder and map each free variable name --- to its kind (also map the names that KindedTVs bind to their respective --- kinds). This function considers the kind of a PlainTV to be *. -kindsOfFVsOfTvbs :: [TyVarBndr_ flag] -> Map Name Kind -kindsOfFVsOfTvbs = foldMap go - where - go :: TyVarBndr_ flag -> Map Name Kind - go = elimTV (\n -> Map.singleton n starK) - (\n k -> let kSigs = -#if MIN_VERSION_template_haskell(2,8,0) - kindsOfFVsOfTypes [k] -#else - Map.empty -#endif - in Map.insert n k kSigs) - -mergeArguments :: - [Type] {- ^ outer parameters -} -> - [Type] {- ^ inner parameters (specializations ) -} -> - (Map Name Name, Cxt) -mergeArguments ns ts = foldr aux (Map.empty, []) (zip ns ts) - where - - aux (f `AppT` x, g `AppT` y) sc = - aux (x,y) (aux (f,g) sc) - - aux (VarT n,p) (subst, context) = - case p of - VarT m | m == n -> (subst, context) - -- If the two variables are the same, don't bother extending - -- the substitution. (This is purely an optimization.) - | Just n' <- Map.lookup m subst - , n == n' -> (subst, context) - -- If a variable is already in a substitution and it maps - -- to the variable that we are trying to unify with, then - -- leave the context alone. (Not doing so caused #46.) - | Map.notMember m subst -> (Map.insert m n subst, context) - _ -> (subst, equalPred (VarT n) p : context) - - aux (SigT x _, y) sc = aux (x,y) sc -- learn about kinds?? - -- This matches *after* VarT so that we can compute a substitution - -- that includes the kind signature. - aux (x, SigT y _) sc = aux (x,y) sc - - aux _ sc = sc - --- | A specialization of 'mergeArguments' to 'Kind'. --- Needed only for backwards compatibility with older versions of --- @template-haskell@. -mergeArgumentKinds :: - [Kind] -> - [Kind] -> - (Map Name Name, Cxt) -#if MIN_VERSION_template_haskell(2,8,0) -mergeArgumentKinds = mergeArguments -#else -mergeArgumentKinds _ _ = (Map.empty, []) -#endif - --- | Expand all of the type synonyms in a type. --- --- Note that this function will drop parentheses as a side effect. -resolveTypeSynonyms :: Type -> Q Type -resolveTypeSynonyms t = - let (f, xs) = decomposeTypeArgs t - normal_xs = filterTANormals xs - - -- Either the type is not headed by a type synonym, or it is headed by a - -- type synonym that is not applied to enough arguments. Leave the type - -- alone and only expand its arguments. - defaultCase :: Type -> Q Type - defaultCase ty = foldl appTypeArg ty <$> mapM resolveTypeArgSynonyms xs - - expandCon :: Name -- The Name to check whether it is a type synonym or not - -> Type -- The argument type to fall back on if the supplied - -- Name isn't a type synonym - -> Q Type - expandCon n ty = do - mbInfo <- reifyMaybe n - case mbInfo of - Just (TyConI (TySynD _ synvars def)) - | length normal_xs >= length synvars -- Don't expand undersaturated type synonyms (#88) - -> resolveTypeSynonyms $ expandSynonymRHS synvars normal_xs def - _ -> defaultCase ty - - in case f of - ForallT tvbs ctxt body -> - ForallT `fmap` mapM resolve_tvb_syns tvbs - `ap` mapM resolvePredSynonyms ctxt - `ap` resolveTypeSynonyms body - SigT ty ki -> do - ty' <- resolveTypeSynonyms ty - ki' <- resolveKindSynonyms ki - defaultCase $ SigT ty' ki' - ConT n -> expandCon n f -#if MIN_VERSION_template_haskell(2,11,0) - InfixT t1 n t2 -> do - t1' <- resolveTypeSynonyms t1 - t2' <- resolveTypeSynonyms t2 - expandCon n (InfixT t1' n t2') - UInfixT t1 n t2 -> do - t1' <- resolveTypeSynonyms t1 - t2' <- resolveTypeSynonyms t2 - expandCon n (UInfixT t1' n t2') -#endif -#if MIN_VERSION_template_haskell(2,15,0) - ImplicitParamT n t -> do - ImplicitParamT n <$> resolveTypeSynonyms t -#endif -#if MIN_VERSION_template_haskell(2,16,0) - ForallVisT tvbs body -> - ForallVisT `fmap` mapM resolve_tvb_syns tvbs - `ap` resolveTypeSynonyms body -#endif -#if MIN_VERSION_template_haskell(2,19,0) - PromotedInfixT t1 n t2 -> do - t1' <- resolveTypeSynonyms t1 - t2' <- resolveTypeSynonyms t2 - return $ PromotedInfixT t1' n t2' - PromotedUInfixT t1 n t2 -> do - t1' <- resolveTypeSynonyms t1 - t2' <- resolveTypeSynonyms t2 - return $ PromotedUInfixT t1' n t2' -#endif - _ -> defaultCase f - --- | Expand all of the type synonyms in a 'TypeArg'. -resolveTypeArgSynonyms :: TypeArg -> Q TypeArg -resolveTypeArgSynonyms (TANormal t) = TANormal <$> resolveTypeSynonyms t -resolveTypeArgSynonyms (TyArg k) = TyArg <$> resolveKindSynonyms k - --- | Expand all of the type synonyms in a 'Kind'. -resolveKindSynonyms :: Kind -> Q Kind -#if MIN_VERSION_template_haskell(2,8,0) -resolveKindSynonyms = resolveTypeSynonyms -#else -resolveKindSynonyms = return -- One simply couldn't put type synonyms into - -- kinds on old versions of GHC. -#endif - --- | Expand all of the type synonyms in a the kind of a 'TyVarBndr'. -resolve_tvb_syns :: TyVarBndr_ flag -> Q (TyVarBndr_ flag) -resolve_tvb_syns = mapMTVKind resolveKindSynonyms - -expandSynonymRHS :: - [TyVarBndr_ flag] {- ^ 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 - mbInfo <- reifyMaybe n - case mbInfo of - Just (TyConI (TySynD _ synvars def)) - | length ts >= length synvars -- Don't expand undersaturated type synonyms (#88) - -> 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, explicit parentheses, and visible kind --- applications. --- --- This operation should be used after all 'UInfixT' cases have been resolved --- by 'resolveFixities' if the argument is being user generated. --- --- > t ~= foldl1 AppT (decomposeType t) -decomposeType :: Type -> NonEmpty Type -decomposeType t = - case decomposeTypeArgs t of - (f, x) -> f :| filterTANormals x - --- | A variant of 'decomposeType' that preserves information about visible kind --- applications by returning a 'NonEmpty' list of 'TypeArg's. -decomposeTypeArgs :: Type -> (Type, [TypeArg]) -decomposeTypeArgs = go [] - where - go :: [TypeArg] -> Type -> (Type, [TypeArg]) - go args (AppT f x) = go (TANormal x:args) f -#if MIN_VERSION_template_haskell(2,11,0) - go args (ParensT t) = go args t -#endif -#if MIN_VERSION_template_haskell(2,15,0) - go args (AppKindT f x) = go (TyArg x:args) f -#endif - go args t = (t, args) - --- | An argument to a type, either a normal type ('TANormal') or a visible --- kind application ('TyArg'). -data TypeArg - = TANormal Type - | TyArg Kind - --- | Apply a 'Type' to a 'TypeArg'. -appTypeArg :: Type -> TypeArg -> Type -appTypeArg f (TANormal x) = f `AppT` x -appTypeArg f (TyArg _k) = -#if MIN_VERSION_template_haskell(2,15,0) - f `AppKindT` _k -#else - f -- VKA isn't supported, so conservatively drop the argument -#endif - --- | Filter out all of the normal type arguments from a list of 'TypeArg's. -filterTANormals :: [TypeArg] -> [Type] -filterTANormals = mapMaybe f - where - f :: TypeArg -> Maybe Type - f (TANormal t) = Just t - f (TyArg {}) = Nothing - --- 'NonEmpty' didn't move into base until recently. Reimplementing it locally --- saves dependencies for supporting older GHCs -data NonEmpty a = a :| [a] - -data NonEmptySnoc a = [a] :|- a - --- Decompose a function type into its context, argument types, --- and return type. For instance, this --- --- forall a b. (Show a, b ~ Int) => (a -> b) -> Char -> Int --- --- becomes --- --- ([a, b], [Show a, b ~ Int], [a -> b, Char] :|- Int) -uncurryType :: Type -> ([TyVarBndrSpec], Cxt, NonEmptySnoc Type) -uncurryType = go [] [] [] - where - go tvbs ctxt args (AppT (AppT ArrowT t1) t2) = go tvbs ctxt (t1:args) t2 - go tvbs ctxt args (ForallT tvbs' ctxt' t) = go (tvbs++tvbs') (ctxt++ctxt') args t - go tvbs ctxt args t = (tvbs, ctxt, reverse args :|- t) - --- | Decompose a function kind into its context, argument kinds, --- and return kind. For instance, this --- --- forall a b. Maybe a -> Maybe b -> Type --- --- becomes --- --- ([a, b], [], [Maybe a, Maybe b] :|- Type) -uncurryKind :: Kind -> ([TyVarBndrSpec], Cxt, NonEmptySnoc Kind) -#if MIN_VERSION_template_haskell(2,8,0) -uncurryKind = uncurryType -#else -uncurryKind = go [] - where - go args (ArrowK k1 k2) = go (k1:args) k2 - go args StarK = ([], [], reverse args :|- StarK) -#endif - --- Reconstruct a function type from its type variable binders, context, --- argument types and return type. -curryType :: [TyVarBndrSpec] -> Cxt -> [Type] -> Type -> Type -curryType tvbs ctxt args res = - ForallT tvbs ctxt $ foldr (\arg t -> ArrowT `AppT` arg `AppT` t) res args - --- | 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 <$> traverse (traverseTVKind resolveInfixT) 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) -# if MIN_VERSION_template_haskell(2,15,0) -resolveInfixT (f `AppKindT` x) = appKindT (resolveInfixT f) (resolveInfixT x) -resolveInfixT (ImplicitParamT n t) - = implicitParamT n $ resolveInfixT t -# endif -# if MIN_VERSION_template_haskell(2,16,0) -resolveInfixT (ForallVisT vs t) = ForallVisT <$> traverse (traverseTVKind resolveInfixT) vs - <*> resolveInfixT t -# endif -# if MIN_VERSION_template_haskell(2,19,0) -resolveInfixT (PromotedInfixT l o r) - = promotedT o `appT` resolveInfixT l `appT` resolveInfixT r -resolveInfixT t@PromotedUInfixT{} - = resolveInfixT =<< resolveInfixT1 (gatherUInfixT t) -# endif -resolveInfixT t = return t - -gatherUInfixT :: Type -> InfixList -gatherUInfixT (UInfixT l o r) = ilAppend (gatherUInfixT l) o False (gatherUInfixT r) -# if MIN_VERSION_template_haskell(2,19,0) -gatherUInfixT (PromotedUInfixT l o r) = ilAppend (gatherUInfixT l) o True (gatherUInfixT r) -# endif -gatherUInfixT t = ILNil t - --- This can fail due to incompatible fixities -resolveInfixT1 :: InfixList -> TypeQ -resolveInfixT1 = go [] - where - go :: [(Type,Name,Bool,Fixity)] -> InfixList -> TypeQ - go ts (ILNil u) = return (foldl (\acc (l,o,p,_) -> mkConT p o `AppT` l `AppT` acc) u ts) - go ts (ILCons l o p r) = - do ofx <- fromMaybe defaultFixity <$> reifyFixityCompat o - let push = go ((l,o,p,ofx):ts) r - case ts of - (l1,o1,p1,o1fx):ts' -> - case compareFixity o1fx ofx of - Just True -> go ((mkConT p1 o1 `AppT` l1 `AppT` l, o, p, ofx):ts') r - Just False -> push - Nothing -> fail (precedenceError o1 o1fx o ofx) - _ -> push - - mkConT :: Bool -> Name -> Type - mkConT promoted = if promoted then PromotedT else ConT - - compareFixity :: Fixity -> Fixity -> Maybe Bool - compareFixity (Fixity n1 InfixL) (Fixity n2 InfixL) = Just (n1 >= n2) - compareFixity (Fixity n1 InfixR) (Fixity n2 InfixR) = Just (n1 > n2) - compareFixity (Fixity n1 _ ) (Fixity n2 _ ) = - case compare n1 n2 of - GT -> Just True - LT -> Just False - EQ -> Nothing - - precedenceError :: Name -> Fixity -> Name -> Fixity -> String - precedenceError o1 ofx1 o2 ofx2 = - "Precedence parsing error: cannot mix ‘" ++ - nameBase o1 ++ "’ [" ++ showFixity ofx1 ++ "] and ‘" ++ - nameBase o2 ++ "’ [" ++ showFixity ofx2 ++ - "] in the same infix type expression" - -data InfixList - = ILCons Type -- The first argument to the type operator - Name -- The name of the infix type operator - Bool -- 'True' if this is a promoted infix data constructor, - -- 'False' otherwise - InfixList -- The rest of the infix applications to resolve - | ILNil Type - -ilAppend :: InfixList -> Name -> Bool -> InfixList -> InfixList -ilAppend (ILNil l) o p r = ILCons l o p r -ilAppend (ILCons l1 o1 p1 r1) o p r = ILCons l1 o1 p1 (ilAppend r1 o p r) - -#else --- older template-haskell packages don't have UInfixT -resolveInfixT = return -#endif - - --- | Render a 'Fixity' as it would appear in Haskell source. --- --- Example: @infixl 5@ -showFixity :: Fixity -> String -showFixity (Fixity n d) = showFixityDirection d ++ " " ++ show n - - --- | Render a 'FixityDirection' like it would appear in Haskell source. --- --- Examples: @infixl@ @infixr@ @infix@ -showFixityDirection :: FixityDirection -> String -showFixityDirection InfixL = "infixl" -showFixityDirection InfixR = "infixr" -showFixityDirection InfixN = "infix" - -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] - -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 --- useful when constructing a type signature for a declaration. --- This code is careful to ensure that the order of the variables quantified --- is determined by their order of appearance in the type signature. (In --- contrast with being dependent upon the Ord instance for 'Name') -quantifyType :: Type -> Type -quantifyType t - | null tvbs - = t - | ForallT tvbs' ctxt' t' <- t -- Collapse two consecutive foralls (#63) - = ForallT (tvbs ++ tvbs') ctxt' t' - | otherwise - = ForallT tvbs [] t - where - tvbs = changeTVFlags SpecifiedSpec $ freeVariablesWellScoped [t] - --- | Take a list of 'Type's, find their free variables, and sort them --- according to dependency order. --- --- As an example of how this function works, consider the following type: --- --- @ --- Proxy (a :: k) --- @ --- --- Calling 'freeVariables' on this type would yield @[a, k]@, since that is --- the order in which those variables appear in a left-to-right fashion. But --- this order does not preserve the fact that @k@ is the kind of @a@. Moreover, --- if you tried writing the type @forall a k. Proxy (a :: k)@, GHC would reject --- this, since GHC would demand that @k@ come before @a@. --- --- 'freeVariablesWellScoped' orders the free variables of a type in a way that --- preserves this dependency ordering. If one were to call --- 'freeVariablesWellScoped' on the type above, it would return --- @[k, (a :: k)]@. (This is why 'freeVariablesWellScoped' returns a list of --- 'TyVarBndr's instead of 'Name's, since it must make it explicit that @k@ --- is the kind of @a@.) --- --- 'freeVariablesWellScoped' guarantees the free variables returned will be --- ordered such that: --- --- 1. Whenever an explicit kind signature of the form @(A :: K)@ is --- encountered, the free variables of @K@ will always appear to the left of --- the free variables of @A@ in the returned result. --- --- 2. The constraint in (1) notwithstanding, free variables will appear in --- left-to-right order of their original appearance. --- --- On older GHCs, this takes measures to avoid returning explicitly bound --- kind variables, which was not possible before @TypeInType@. -freeVariablesWellScoped :: [Type] -> [TyVarBndrUnit] -freeVariablesWellScoped tys = - let fvs :: [Name] - fvs = freeVariables tys - - varKindSigs :: Map Name Kind - varKindSigs = foldMap go_ty tys - where - go_ty :: Type -> Map Name Kind - go_ty (ForallT tvbs ctxt t) = - foldr (\tvb -> Map.delete (tvName tvb)) - (foldMap go_pred ctxt `mappend` go_ty t) tvbs - go_ty (AppT t1 t2) = go_ty t1 `mappend` go_ty t2 - go_ty (SigT t k) = - let kSigs = -#if MIN_VERSION_template_haskell(2,8,0) - go_ty k -#else - mempty -#endif - in case t of - VarT n -> Map.insert n k kSigs - _ -> go_ty t `mappend` kSigs -#if MIN_VERSION_template_haskell(2,15,0) - go_ty (AppKindT t k) = go_ty t `mappend` go_ty k - go_ty (ImplicitParamT _ t) = go_ty t -#endif -#if MIN_VERSION_template_haskell(2,16,0) - go_ty (ForallVisT tvbs t) = - foldr (\tvb -> Map.delete (tvName tvb)) (go_ty t) tvbs -#endif - go_ty _ = mempty - - go_pred :: Pred -> Map Name Kind -#if MIN_VERSION_template_haskell(2,10,0) - go_pred = go_ty -#else - go_pred (ClassP _ ts) = foldMap go_ty ts - go_pred (EqualP t1 t2) = go_ty t1 `mappend` go_ty t2 -#endif - - -- | Do a topological sort on a list of tyvars, - -- so that binders occur before occurrences - -- E.g. given [ a::k, k::*, b::k ] - -- it'll return a well-scoped list [ k::*, a::k, b::k ] - -- - -- This is a deterministic sorting operation - -- (that is, doesn't depend on Uniques). - -- - -- It is also meant to be stable: that is, variables should not - -- be reordered unnecessarily. - scopedSort :: [Name] -> [Name] - scopedSort = go [] [] - - go :: [Name] -- already sorted, in reverse order - -> [Set Name] -- each set contains all the variables which must be placed - -- before the tv corresponding to the set; they are accumulations - -- of the fvs in the sorted tvs' kinds - - -- This list is in 1-to-1 correspondence with the sorted tyvars - -- INVARIANT: - -- all (\tl -> all (`isSubsetOf` head tl) (tail tl)) (tails fv_list) - -- That is, each set in the list is a superset of all later sets. - -> [Name] -- yet to be sorted - -> [Name] - go acc _fv_list [] = reverse acc - go acc fv_list (tv:tvs) - = go acc' fv_list' tvs - where - (acc', fv_list') = insert tv acc fv_list - - insert :: Name -- var to insert - -> [Name] -- sorted list, in reverse order - -> [Set Name] -- list of fvs, as above - -> ([Name], [Set Name]) -- augmented lists - insert tv [] [] = ([tv], [kindFVSet tv]) - insert tv (a:as) (fvs:fvss) - | tv `Set.member` fvs - , (as', fvss') <- insert tv as fvss - = (a:as', fvs `Set.union` fv_tv : fvss') - - | otherwise - = (tv:a:as, fvs `Set.union` fv_tv : fvs : fvss) - where - fv_tv = kindFVSet tv - - -- lists not in correspondence - insert _ _ _ = error "scopedSort" - - kindFVSet n = - maybe Set.empty (Set.fromList . freeVariables) (Map.lookup n varKindSigs) - ascribeWithKind n = - maybe (plainTV n) (kindedTV n) (Map.lookup n varKindSigs) - - -- An annoying wrinkle: GHCs before 8.0 don't support explicitly - -- quantifying kinds, so something like @forall k (a :: k)@ would be - -- rejected. To work around this, we filter out any binders whose names - -- also appear in a kind on old GHCs. - isKindBinderOnOldGHCs -#if __GLASGOW_HASKELL__ >= 800 - = const False -#else - = (`elem` kindVars) - where - kindVars = freeVariables $ Map.elems varKindSigs -#endif - - in map ascribeWithKind $ - filter (not . isKindBinderOnOldGHCs) $ - scopedSort fvs - --- | Substitute all of the free variables in a type with fresh ones -freshenFreeVariables :: Type -> Q Type -freshenFreeVariables t = - do let xs = [ (n, VarT <$> newName (nameBase n)) | n <- freeVariables t] - subst <- T.sequence (Map.fromList xs) - return (applySubstitution subst t) - - --- | Class for types that support type variable substitution. -class TypeSubstitution a where - -- | Apply a type variable substitution. - applySubstitution :: Map Name Type -> a -> a - -- | Compute the free type variables - freeVariables :: a -> [Name] - -instance TypeSubstitution a => TypeSubstitution [a] where - freeVariables = nub . concat . map freeVariables - applySubstitution = fmap . applySubstitution - -instance TypeSubstitution Type where - applySubstitution subst = go - where - go (ForallT tvs context t) = - let (subst', tvs') = substTyVarBndrs subst tvs in - ForallT tvs' - (applySubstitution subst' context) - (applySubstitution subst' t) - go (AppT f x) = AppT (go f) (go x) - go (SigT t k) = SigT (go t) (applySubstitution subst k) -- k could be Kind - go (VarT v) = Map.findWithDefault (VarT v) v subst -#if MIN_VERSION_template_haskell(2,11,0) - go (InfixT l c r) = InfixT (go l) c (go r) - go (UInfixT l c r) = UInfixT (go l) c (go r) - go (ParensT t) = ParensT (go t) -#endif -#if MIN_VERSION_template_haskell(2,15,0) - go (AppKindT t k) = AppKindT (go t) (go k) - go (ImplicitParamT n t) - = ImplicitParamT n (go t) -#endif -#if MIN_VERSION_template_haskell(2,16,0) - go (ForallVisT tvs t) = - let (subst', tvs') = substTyVarBndrs subst tvs in - ForallVisT tvs' - (applySubstitution subst' t) -#endif -#if MIN_VERSION_template_haskell(2,19,0) - go (PromotedInfixT l c r) - = PromotedInfixT (go l) c (go r) - go (PromotedUInfixT l c r) - = PromotedUInfixT (go l) c (go r) -#endif - go t = t - - subst_tvbs :: [TyVarBndr_ flag] -> (Map Name Type -> a) -> a - subst_tvbs tvs k = k $ foldl' (flip Map.delete) subst (map tvName tvs) - - freeVariables t = - case t of - ForallT tvs context t' -> - fvs_under_forall tvs (freeVariables context `union` freeVariables t') - AppT f x -> freeVariables f `union` freeVariables x - SigT t' k -> freeVariables t' `union` freeVariables k - VarT v -> [v] -#if MIN_VERSION_template_haskell(2,11,0) - InfixT l _ r -> freeVariables l `union` freeVariables r - UInfixT l _ r -> freeVariables l `union` freeVariables r - ParensT t' -> freeVariables t' -#endif -#if MIN_VERSION_template_haskell(2,15,0) - AppKindT t k -> freeVariables t `union` freeVariables k - ImplicitParamT _ t - -> freeVariables t -#endif -#if MIN_VERSION_template_haskell(2,16,0) - ForallVisT tvs t' - -> fvs_under_forall tvs (freeVariables t') -#endif -#if MIN_VERSION_template_haskell(2,19,0) - PromotedInfixT l _ r - -> freeVariables l `union` freeVariables r - PromotedUInfixT l _ r - -> freeVariables l `union` freeVariables r -#endif - _ -> [] - where - fvs_under_forall :: [TyVarBndr_ flag] -> [Name] -> [Name] - fvs_under_forall tvs fvs = - (freeVariables (map tvKind tvs) `union` fvs) - \\ map tvName tvs - -instance TypeSubstitution ConstructorInfo where - freeVariables ci = - (freeVariables (map tvKind (constructorVars ci)) - `union` freeVariables (constructorContext ci) - `union` freeVariables (constructorFields ci)) - \\ (tvName <$> constructorVars ci) - - applySubstitution subst ci = - let subst' = foldl' (flip Map.delete) subst (map tvName (constructorVars ci)) in - ci { constructorVars = map (mapTVKind (applySubstitution subst')) - (constructorVars ci) - , constructorContext = applySubstitution subst' (constructorContext ci) - , constructorFields = applySubstitution subst' (constructorFields ci) - } - --- 'Pred' became a type synonym for 'Type' -#if !MIN_VERSION_template_haskell(2,10,0) -instance TypeSubstitution Pred where - freeVariables (ClassP _ xs) = freeVariables xs - freeVariables (EqualP x y) = freeVariables x `union` freeVariables y - - applySubstitution p (ClassP n xs) = ClassP n (applySubstitution p xs) - applySubstitution p (EqualP x y) = EqualP (applySubstitution p x) - (applySubstitution p y) -#endif - --- 'Kind' became a type synonym for 'Type'. Previously there were no kind variables -#if !MIN_VERSION_template_haskell(2,8,0) -instance TypeSubstitution Kind where - freeVariables _ = [] - applySubstitution _ k = k -#endif - --- | Substitutes into the kinds of type variable binders. This makes an effort --- to avoid capturing the 'TyVarBndr' names during substitution by --- alpha-renaming names if absolutely necessary. For a version of this function --- which does /not/ avoid capture, see 'substTyVarBndrKinds'. -substTyVarBndrs :: Map Name Type -> [TyVarBndr_ flag] -> (Map Name Type, [TyVarBndr_ flag]) -substTyVarBndrs = mapAccumL substTyVarBndr - --- | The workhorse for 'substTyVarBndrs'. -substTyVarBndr :: Map Name Type -> TyVarBndr_ flag -> (Map Name Type, TyVarBndr_ flag) -substTyVarBndr subst tvb - | tvbName `Map.member` subst - = (Map.delete tvbName subst, mapTVKind (applySubstitution subst) tvb) - | tvbName `Set.notMember` substRangeFVs - = (subst, mapTVKind (applySubstitution subst) tvb) - | otherwise - = let tvbName' = evade tvbName in - ( Map.insert tvbName (VarT tvbName') subst - , mapTV (\_ -> tvbName') id (applySubstitution subst) tvb - ) - where - tvbName :: Name - tvbName = tvName tvb - - substRangeFVs :: Set Name - substRangeFVs = Set.fromList $ freeVariables $ Map.elems subst - - evade :: Name -> Name - evade n | n `Set.member` substRangeFVs - = evade $ bump n - | otherwise - = n - - -- An improvement would be to try a variety of different characters instead - -- of prepending the same character repeatedly. Let's wait to see if - -- someone complains about this before making this more complicated, - -- however. - bump :: Name -> Name - bump n = mkName $ 'f':nameBase n - --- | Substitutes into the kinds of type variable binders. This is slightly more --- efficient than 'substTyVarBndrs', but at the expense of not avoiding --- capture. Only use this function in situations where you know that none of --- the 'TyVarBndr' names are contained in the range of the substitution. -substTyVarBndrKinds :: Map Name Type -> [TyVarBndr_ flag] -> [TyVarBndr_ flag] -substTyVarBndrKinds subst = map (substTyVarBndrKind subst) - --- | The workhorse for 'substTyVarBndrKinds'. -substTyVarBndrKind :: Map Name Type -> TyVarBndr_ flag -> TyVarBndr_ flag -substTyVarBndrKind subst = mapTVKind (applySubstitution subst) - ------------------------------------------------------------------------- - -combineSubstitutions :: Map Name Type -> Map Name Type -> Map Name Type -combineSubstitutions x y = Map.union (fmap (applySubstitution y) x) y - --- | Compute the type variable substitution that unifies a list of types, --- or fail in 'Q'. --- --- All infix issue should be resolved before using 'unifyTypes' --- --- Alpha equivalent quantified types are not unified. -unifyTypes :: [Type] -> Q (Map Name Type) -unifyTypes [] = return Map.empty -unifyTypes (t:ts) = - do t':ts' <- mapM resolveTypeSynonyms (t:ts) - let aux sub u = - do sub' <- unify' (applySubstitution sub t') - (applySubstitution sub u) - return (combineSubstitutions sub sub') - - case foldM aux Map.empty ts' of - Right m -> return m - Left (x,y) -> - fail $ showString "Unable to unify types " - . showsPrec 11 x - . showString " and " - . showsPrec 11 y - $ "" - -unify' :: Type -> Type -> Either (Type,Type) (Map Name Type) - -unify' (VarT n) (VarT m) | n == m = pure Map.empty -unify' (VarT n) t | n `elem` freeVariables t = Left (VarT n, t) - | otherwise = Right (Map.singleton n t) -unify' t (VarT n) | n `elem` freeVariables t = Left (VarT n, t) - | otherwise = Right (Map.singleton n t) - -unify' (AppT f1 x1) (AppT f2 x2) = - do sub1 <- unify' f1 f2 - sub2 <- unify' (applySubstitution sub1 x1) (applySubstitution sub1 x2) - Right (combineSubstitutions sub1 sub2) - --- Doesn't unify kind signatures -unify' (SigT t _) u = unify' t u -unify' t (SigT u _) = unify' t u - --- only non-recursive cases should remain at this point -unify' t u - | t == u = Right Map.empty - | otherwise = Left (t,u) - - --- | Construct an equality constraint. The implementation of 'Pred' varies --- across versions of Template Haskell. -equalPred :: Type -> Type -> Pred -equalPred x y = -#if MIN_VERSION_template_haskell(2,10,0) - AppT (AppT EqualityT x) y -#else - EqualP x y -#endif - --- | Construct a typeclass constraint. The implementation of 'Pred' varies --- across versions of Template Haskell. -classPred :: Name {- ^ class -} -> [Type] {- ^ parameters -} -> Pred -classPred = -#if MIN_VERSION_template_haskell(2,10,0) - foldl AppT . ConT -#else - ClassP -#endif - --- | Match a 'Pred' representing an equality constraint. Returns --- arguments to the equality constraint if successful. -asEqualPred :: Pred -> Maybe (Type,Type) -#if MIN_VERSION_template_haskell(2,10,0) -asEqualPred (EqualityT `AppT` x `AppT` y) = Just (x,y) -asEqualPred (ConT eq `AppT` x `AppT` y) | eq == eqTypeName = Just (x,y) -#else -asEqualPred (EqualP x y) = Just (x,y) -#endif -asEqualPred _ = Nothing - --- | Match a 'Pred' representing a class constraint. --- Returns the classname and parameters if successful. -asClassPred :: Pred -> Maybe (Name, [Type]) -#if MIN_VERSION_template_haskell(2,10,0) -asClassPred t = - case decomposeType t of - ConT f :| xs | f /= eqTypeName -> Just (f,xs) - _ -> Nothing -#else -asClassPred (ClassP f xs) = Just (f,xs) -asClassPred _ = Nothing -#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 --- manually on any reified type variable binders without a signature. However, --- don't do this for quoted type variable binders (#84). - -giveDIVarsStarKinds :: IsReifiedDec -> DatatypeInfo -> DatatypeInfo -giveDIVarsStarKinds isReified info = - info { datatypeVars = map (giveTyVarBndrStarKind isReified) (datatypeVars info) - , datatypeInstTypes = map (giveTypeStarKind isReified) (datatypeInstTypes info) } - -giveCIVarsStarKinds :: IsReifiedDec -> ConstructorInfo -> ConstructorInfo -giveCIVarsStarKinds isReified info = - info { constructorVars = map (giveTyVarBndrStarKind isReified) (constructorVars info) } - -giveTyVarBndrStarKind :: IsReifiedDec -> TyVarBndrUnit -> TyVarBndrUnit -giveTyVarBndrStarKind isReified tvb - | isReified - = elimTV (\n -> kindedTV n starK) (\_ _ -> tvb) tvb - | otherwise - = tvb - -giveTypeStarKind :: IsReifiedDec -> Type -> Type -giveTypeStarKind isReified t - | isReified - = case t of - VarT n -> SigT t starK - _ -> t - | otherwise - = t - --- | 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. --- --- The particular problem is that the type variables used in the patterns --- while defining a data family instance do not completely match those --- used when defining the fields of the value constructors beyond the --- base names. This code attempts to recover the relationship between the --- type variables. --- --- It is possible, however, to generate these kinds of declarations by --- means other than reify. In these cases the name bases might not be --- unique and the declarations might be well formed. In such a case this --- code attempts to avoid altering the declaration. --- --- https://ghc.haskell.org/trac/ghc/ticket/13618 -repair13618 :: DatatypeInfo -> Q DatatypeInfo -repair13618 info = - do s <- T.sequence (Map.fromList substList) - return info { datatypeCons = applySubstitution s (datatypeCons info) } - - where - used = freeVariables (datatypeCons info) - bound = map tvName (datatypeVars info) - free = used \\ bound - - substList = - [ (u, substEntry u vs) - | u <- free - , let vs = [v | v <- bound, nameBase v == nameBase u] - ] - - substEntry _ [v] = varT v - substEntry u [] = fail ("Impossible free variable: " ++ show u) - substEntry u _ = fail ("Ambiguous free variable: " ++ show u) - ------------------------------------------------------------------------- - --- | Backward compatible version of 'dataD' -dataDCompat :: - CxtQ {- ^ context -} -> - Name {- ^ type constructor -} -> - [TyVarBndrUnit] {- ^ type parameters -} -> - [ConQ] {- ^ constructor definitions -} -> - [Name] {- ^ derived class names -} -> - DecQ -#if MIN_VERSION_template_haskell(2,12,0) -dataDCompat c n ts cs ds = - dataD c n ts Nothing cs - (if null ds then [] else [derivClause Nothing (map conT ds)]) -#elif MIN_VERSION_template_haskell(2,11,0) -dataDCompat c n ts cs ds = - dataD c n ts Nothing cs - (return (map ConT ds)) -#else -dataDCompat = dataD -#endif - --- | Backward compatible version of 'newtypeD' -newtypeDCompat :: - CxtQ {- ^ context -} -> - Name {- ^ type constructor -} -> - [TyVarBndrUnit] {- ^ type parameters -} -> - ConQ {- ^ constructor definition -} -> - [Name] {- ^ derived class names -} -> - DecQ -#if MIN_VERSION_template_haskell(2,12,0) -newtypeDCompat c n ts cs ds = - newtypeD c n ts Nothing cs - (if null ds then [] else [derivClause Nothing (map conT ds)]) -#elif MIN_VERSION_template_haskell(2,11,0) -newtypeDCompat c n ts cs ds = - newtypeD c n ts Nothing cs - (return (map ConT ds)) -#else -newtypeDCompat = newtypeD -#endif - --- | Backward compatible version of 'tySynInstD' -tySynInstDCompat :: - Name {- ^ type family name -} -> - Maybe [Q TyVarBndrUnit] {- ^ type variable binders -} -> - [TypeQ] {- ^ instance parameters -} -> - TypeQ {- ^ instance result -} -> - DecQ -#if MIN_VERSION_template_haskell(2,15,0) -tySynInstDCompat n mtvbs ps r = TySynInstD <$> (TySynEqn <$> mapM sequence mtvbs - <*> foldl' appT (conT n) ps - <*> r) -#elif MIN_VERSION_template_haskell(2,9,0) -tySynInstDCompat n _ ps r = TySynInstD n <$> (TySynEqn <$> sequence ps <*> r) -#else -tySynInstDCompat n _ = tySynInstD n -#endif - --- | Backward compatible version of 'pragLineD'. Returns --- 'Nothing' if line pragmas are not suported. -pragLineDCompat :: - Int {- ^ line number -} -> - String {- ^ file name -} -> - Maybe DecQ -#if MIN_VERSION_template_haskell(2,10,0) -pragLineDCompat ln fn = Just (pragLineD ln fn) -#else -pragLineDCompat _ _ = Nothing -#endif - -arrowKCompat :: Kind -> Kind -> Kind -#if MIN_VERSION_template_haskell(2,8,0) -arrowKCompat x y = arrowK `appK` x `appK` y -#else -arrowKCompat = arrowK -#endif - ------------------------------------------------------------------------- - --- | 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 = recover (return Nothing) ((`mplus` Just defaultFixity) <$> reifyFixity n) -#else -reifyFixityCompat n = recover (return Nothing) $ - do info <- reify n - return $! case info of - ClassOpI _ _ _ fixity -> Just fixity - DataConI _ _ _ fixity -> Just fixity - VarI _ _ _ fixity -> Just fixity - _ -> Nothing -#endif +{-# Language CPP, DeriveDataTypeable, DeriveGeneric, ScopedTypeVariables, TupleSections #-} + +#if MIN_VERSION_template_haskell(2,12,0) +{-# Language Safe #-} +#else +{-# Language Trustworthy #-} +#endif + +{-| +Module : Language.Haskell.TH.Datatype +Description : Backwards-compatible interface to reified information about datatypes. +Copyright : Eric Mertens 2017-2020 +License : ISC +Maintainer : emertens@gmail.com + +This module provides a flattened view of information about data types +and newtypes that can be supported uniformly across multiple versions +of the @template-haskell@ package. + +Sample output for @'reifyDatatype' ''Maybe@ + +@ +'DatatypeInfo' + { 'datatypeContext' = [] + , 'datatypeName' = GHC.Base.Maybe + , 'datatypeVars' = [ 'KindedTV' a_3530822107858468866 () 'StarT' ] + , 'datatypeInstTypes' = [ 'SigT' ('VarT' a_3530822107858468866) 'StarT' ] + , 'datatypeVariant' = 'Datatype' + , 'datatypeReturnKind' = 'StarT' + , 'datatypeCons' = + [ 'ConstructorInfo' + { 'constructorName' = GHC.Base.Nothing + , 'constructorVars' = [] + , 'constructorContext' = [] + , 'constructorFields' = [] + , 'constructorStrictness' = [] + , 'constructorVariant' = 'NormalConstructor' + } + , 'ConstructorInfo' + { 'constructorName' = GHC.Base.Just + , 'constructorVars' = [] + , 'constructorContext' = [] + , 'constructorFields' = [ 'VarT' a_3530822107858468866 ] + , 'constructorStrictness' = [ 'FieldStrictness' + 'UnspecifiedUnpackedness' + 'Lazy' + ] + , 'constructorVariant' = 'NormalConstructor' + } + ] + } +@ + +Datatypes declared with GADT syntax are normalized to constructors with existentially +quantified type variables and equality constraints. + +-} +module Language.Haskell.TH.Datatype + ( + -- * Types + DatatypeInfo(..) + , ConstructorInfo(..) + , DatatypeVariant(..) + , ConstructorVariant(..) + , FieldStrictness(..) + , Unpackedness(..) + , Strictness(..) + + -- * Normalization functions + , reifyDatatype + , reifyConstructor + , reifyRecord + , normalizeInfo + , normalizeDec + , normalizeCon + + -- * 'DatatypeInfo' lookup functions + , lookupByConstructorName + , lookupByRecordName + + -- * Type variable manipulation + , TypeSubstitution(..) + , quantifyType + , freeVariablesWellScoped + , freshenFreeVariables + + -- * 'Pred' functions + , equalPred + , classPred + , asEqualPred + , asClassPred + + -- * Backward compatible data definitions + , dataDCompat + , newtypeDCompat + , tySynInstDCompat + , pragLineDCompat + , arrowKCompat + + -- * Strictness annotations + , isStrictAnnot + , notStrictAnnot + , unpackedAnnot + + -- * Type simplification + , resolveTypeSynonyms + , resolveKindSynonyms + , resolvePredSynonyms + , resolveInfixT + + -- * Fixities + , reifyFixityCompat + , showFixity + , showFixityDirection + + -- * Convenience functions + , unifyTypes + , tvName + , tvKind + , datatypeType + ) where + +import Control.Monad +import Data.Data (Data) +import Data.Foldable (foldMap, foldl') +import Data.List (mapAccumL, nub, find, union, (\\)) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe +import qualified Data.Set as Set +import Data.Set (Set) +import qualified Data.Traversable as T +import GHC.Generics (Generic) +import Language.Haskell.TH hiding (Extension(..)) +import Language.Haskell.TH.Datatype.Internal +import Language.Haskell.TH.Datatype.TyVarBndr +import Language.Haskell.TH.Lib (arrowK, starK) -- needed for th-2.4 + +-- | Normalized information about newtypes and data types. +-- +-- 'DatatypeInfo' contains two fields, 'datatypeVars' and 'datatypeInstTypes', +-- which encode information about the argument types. The simplest explanation +-- is that 'datatypeVars' contains all the type /variables/ bound by the data +-- type constructor, while 'datatypeInstTypes' contains the type /arguments/ +-- to the data type constructor. To be more precise: +-- +-- * For ADTs declared with @data@ and @newtype@, it will likely be the case +-- that 'datatypeVars' and 'datatypeInstTypes' coincide. For instance, given +-- @newtype Id a = MkId a@, in the 'DatatypeInfo' for @Id@ we would +-- have @'datatypeVars' = ['KindedTV' a () 'StarT']@ and +-- @'datatypeInstVars' = ['SigT' ('VarT' a) 'StarT']@. +-- +-- ADTs that leverage @PolyKinds@ may have more 'datatypeVars' than +-- 'datatypeInstTypes'. For instance, given @data Proxy (a :: k) = MkProxy@, +-- in the 'DatatypeInfo' for @Proxy@ we would have +-- @'datatypeVars' = ['KindedTV' k () 'StarT', 'KindedTV' a () ('VarT' k)]@ +-- (since there are two variables, @k@ and @a@), whereas +-- @'datatypeInstTypes' = ['SigT' ('VarT' a) ('VarT' k)]@, since there is +-- only one explicit type argument to @Proxy@. +-- +-- The same outcome would occur if @Proxy@ were declared using +-- @TypeAbstractions@, i.e., if it were declared as +-- @data Proxy \@k (a :: k) = MkProxy@. The 'datatypeInstTypes' would /not/ +-- include a separate type for @\@k@. +-- +-- * For @data instance@s and @newtype instance@s of data families, +-- 'datatypeVars' and 'datatypeInstTypes' can be quite different. Here is +-- an example to illustrate the difference: +-- +-- @ +-- data family F a b +-- data instance F (Maybe c) (f x) = MkF c (f x) +-- @ +-- +-- Then in the 'DatatypeInfo' for @F@'s data instance, we would have: +-- +-- @ +-- 'datatypeVars' = [ 'KindedTV' c () 'StarT' +-- , 'KindedTV' f () 'StarT' +-- , 'KindedTV' x () 'StarT' ] +-- 'datatypeInstTypes' = [ 'AppT' ('ConT' ''Maybe) ('VarT' c) +-- , 'AppT' ('VarT' f) ('VarT' x) ] +-- @ +data DatatypeInfo = DatatypeInfo + { datatypeContext :: Cxt -- ^ Data type context (deprecated) + , datatypeName :: Name -- ^ Type constructor + , datatypeVars :: [TyVarBndrUnit] -- ^ Type parameters + , datatypeInstTypes :: [Type] -- ^ Argument types + , datatypeVariant :: DatatypeVariant -- ^ Extra information + , datatypeReturnKind:: Kind -- ^ Return 'Kind' of the type. + -- + -- If normalization is unable to determine the return kind, + -- then this is conservatively set to @StarT@. + , datatypeCons :: [ConstructorInfo] -- ^ Normalize constructor information + } + deriving (Show, Eq, Data, Generic) + +-- | Possible variants of data type declarations. +data DatatypeVariant + = Datatype -- ^ Type declared with @data@ or a primitive datatype. + | Newtype -- ^ Type declared with @newtype@. + -- + -- A 'DatatypeInfo' that uses 'Newtype' will uphold the + -- invariant that there will be exactly one + -- 'ConstructorInfo' in the 'datatypeCons'. + | DataInstance -- ^ Type declared with @data instance@. + | NewtypeInstance -- ^ Type declared with @newtype instance@. + -- + -- A 'DatatypeInfo' that uses 'NewtypeInstance' will + -- uphold the invariant that there will be exactly one + -- 'ConstructorInfo' in the 'datatypeCons'. + | TypeData -- ^ Type declared with @type data@. + -- + -- A 'DatatypeInfo' that uses 'TypeData' will uphold the + -- following invariants: + -- + -- * The 'datatypeContext' will be empty. + -- + -- * None of the 'constructorVariant's in any of the + -- 'datatypeCons' will be 'RecordConstructor'. + -- + -- * Each of the 'constructorStrictness' values in each + -- of the 'datatypeCons' will be equal to + -- 'notStrictAnnot'. + deriving (Show, Read, Eq, Ord, Data, Generic) + +-- | Normalized information about constructors associated with newtypes and +-- data types. +data ConstructorInfo = ConstructorInfo + { constructorName :: Name -- ^ Constructor name + , constructorVars :: [TyVarBndrUnit] -- ^ 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, Data, Generic) + +-- | 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, Data, Generic) + +-- | 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, Data, Generic) + +-- | 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, Data, Generic) + +-- | Information about a constructor field's strictness annotation. +data Strictness + = UnspecifiedStrictness -- ^ No annotation whatsoever + | Lazy -- ^ Annotated with @~@ + | Strict -- ^ Annotated with @!@ + deriving (Show, Eq, Ord, Data, Generic) + +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 +datatypeType di + = foldl AppT (ConT (datatypeName di)) + $ map stripSigT + $ datatypeInstTypes di + + +-- | Compute a normalized view of the metadata about a data type or newtype +-- 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/, +-- 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) +-- kinds. For instance, the following GADT's constructors: +-- +-- @ +-- data T (a :: k -> *) where +-- MkT1 :: T Proxy +-- MkT2 :: T Maybe +-- @ +-- +-- will be normalized to the following equality constraints: +-- +-- @ +-- AppT (AppT EqualityT (VarT a)) (ConT Proxy) -- MkT1 +-- AppT (AppT EqualityT (VarT a)) (ConT Maybe) -- MkT2 +-- @ +-- +-- But only the first equality constraint is well kinded, since in the second +-- 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. +-- +-- Primitive types (other than unboxed sums and tuples) will have +-- no @datatypeCons@ in their normalization. +-- +-- 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 {- ^ data type or constructor name -} -> + Q DatatypeInfo +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" isn'tReified + +normalizeInfo' :: String -> IsReifiedDec -> Info -> Q DatatypeInfo +normalizeInfo' entry reifiedDec i = + case i of + (PrimTyConI name arity unlifted) -> do +#if MIN_VERSION_template_haskell(2,16,0) + -- We provide a minimal @DataD@ because, since TH 2.16, + -- we can rely on the call to @reifyType@ in + -- @normalizeDecFor@ to fill in the missing details. + normalizeDecFor reifiedDec $ DataD [] name [] Nothing [] [] +#else + -- On older versions, we are very limited in what we can deduce. + -- All we know is the appropriate amount of type constructors. + -- Note that this will default all kinds to @Type@, which is all + -- that is available anyway. + args <- replicateM arity (newName "x") + dec <- dataDCompat (return []) name (map plainTV args) [] [] + normalizeDecFor reifiedDec dec +#endif + ClassI{} -> bad "Class not supported" + FamilyI DataFamilyD{} _ -> bad "Use a value constructor to reify a data family instance" + FamilyI _ _ -> bad "Type families not supported" + TyConI dec -> normalizeDecFor reifiedDec dec + DataConI name _ parent -> reifyParent name parent + -- 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. + VarI recName recTy _ -> reifyRecordType recName recTy + -- NB: Similarly, we do not pass the IsReifiedDec + -- information here. + _ -> bad "Expected a type constructor" + where + bad msg = fail (entry ++ ": " ++ msg) + + +reifyParent :: Name -> Name -> Q DatatypeInfo +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 -> normalizeDecFor isReified dec + FamilyI dec instances -> + do instances1 <- mapM (repairDataFam dec) instances + instances2 <- mapM (normalizeDecFor isReified) instances1 + case find p instances2 of + Just inst -> return inst + Nothing -> panic "lost the instance" + _ -> panic "unexpected parent" + where + 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 + +-- Sadly, Template Haskell's treatment of data family instances leaves much +-- to be desired. 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. +repairDataFam :: + Dec {- ^ family declaration -} -> + Dec {- ^ instance declaration -} -> + Q Dec {- ^ instance declaration -} +repairDataFam famD instD +#if MIN_VERSION_template_haskell(2,15,0) + | DataFamilyD _ dvars dk <- famD + , NewtypeInstD cx mbInstVars nts k c deriv <- instD + , con :| ts <- decomposeType nts + = do ts' <- repairVarKindsWith dvars dk ts + return $ NewtypeInstD cx mbInstVars (foldl' AppT con ts') k c deriv + + | DataFamilyD _ dvars dk <- famD + , DataInstD cx mbInstVars nts k c deriv <- instD + , con :| ts <- decomposeType nts + = do ts' <- repairVarKindsWith dvars dk ts + return $ DataInstD cx mbInstVars (foldl' AppT con ts') k c deriv +#else + | DataFamilyD _ dvars dk <- famD + , NewtypeInstD cx n ts k c deriv <- instD + = do ts' <- repairVarKindsWith dvars dk ts + return $ NewtypeInstD cx n ts' k c deriv + + | DataFamilyD _ dvars dk <- famD + , DataInstD cx n ts k c deriv <- instD + = do ts' <- repairVarKindsWith dvars dk ts + return $ DataInstD cx n ts' k c deriv +#endif +repairDataFam _ instD = return instD + +-- | @'repairVarKindsWith' tvbs mbKind ts@ returns @ts@, but where each element +-- has an explicit kind signature taken from a 'TyVarBndr' in the corresponding +-- position in @tvbs@, or from the corresponding kind argument in 'mbKind' if +-- there aren't enough 'TyVarBndr's available. An example where @tvbs@ can be +-- shorter than @ts@ can be found in this example from #95: +-- +-- @ +-- data family F :: Type -> Type +-- data instance F a = C +-- @ +-- +-- The @F@ has no type variable binders in its @data family@ declaration, and +-- it has a return kind of @Type -> Type@. As a result, we pair up @Type@ with +-- @VarT a@ to get @SigT a (ConT ''Type)@. +repairVarKindsWith :: [TyVarBndrVis] -> Maybe Kind -> [Type] -> Q [Type] +repairVarKindsWith tvbs mbKind ts = do + extra_tvbs <- mkExtraKindBinders $ fromMaybe starK mbKind + -- This list should be the same length as @ts@. If it isn't, something has + -- gone terribly wrong. + let tvbs' = changeTVFlags () tvbs ++ extra_tvbs + return $ zipWith stealKindForType tvbs' ts + +-- If a VarT is missing an explicit kind signature, steal it from a TyVarBndr. +stealKindForType :: TyVarBndr_ flag -> Type -> Type +stealKindForType tvb t@VarT{} = SigT t (tvKind tvb) +stealKindForType _ t = t + +-- | Normalize 'Dec' for a newtype or datatype into a 'DatatypeInfo'. +-- Fail in 'Q' otherwise. +-- +-- 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' +-- 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,20,0) + TypeDataD name tyvars mbKind cons -> + normalizeDataD [] name tyvars mbKind cons TypeData +#endif +#if MIN_VERSION_template_haskell(2,12,0) + NewtypeD context name tyvars mbKind con _derives -> + normalizeDataD context name tyvars mbKind [con] Newtype + DataD context name tyvars mbKind cons _derives -> + normalizeDataD context name tyvars mbKind cons Datatype +# if MIN_VERSION_template_haskell(2,15,0) + NewtypeInstD context mbTyvars nameInstTys mbKind con _derives -> + normalizeDataInstDPostTH2'15 "newtype" context mbTyvars nameInstTys + mbKind [con] NewtypeInstance + DataInstD context mbTyvars nameInstTys mbKind cons _derives -> + normalizeDataInstDPostTH2'15 "data" context mbTyvars nameInstTys + mbKind cons DataInstance +# else + NewtypeInstD context name instTys mbKind con _derives -> + normalizeDataInstDPreTH2'15 context name instTys mbKind [con] NewtypeInstance + DataInstD context name instTys mbKind cons _derives -> + normalizeDataInstDPreTH2'15 context name instTys mbKind cons DataInstance +# endif +#else + NewtypeD context name tyvars mbKind con _derives -> + normalizeDataD context name tyvars mbKind [con] Newtype + DataD context name tyvars mbKind cons _derives -> + normalizeDataD context name tyvars mbKind cons Datatype + NewtypeInstD context name instTys mbKind con _derives -> + normalizeDataInstDPreTH2'15 context name instTys mbKind [con] NewtypeInstance + DataInstD context name instTys mbKind cons _derives -> + normalizeDataInstDPreTH2'15 context name instTys mbKind cons DataInstance +#endif + _ -> fail "normalizeDecFor: DataD or NewtypeD required" + where + -- We only need to repair reified declarations for data family instances. + repair13618' :: DatatypeInfo -> Q DatatypeInfo + repair13618' di@DatatypeInfo{datatypeVariant = variant} + | isReified && isFamInstVariant variant + = repair13618 di + | otherwise + = return di + + -- If a data type lacks an explicit return kind, use `reifyType` to compute + -- it, as described in step (1) of Note [Tricky result kinds]. + normalizeMbKind :: Name -> [Type] -> Maybe Kind -> Q (Maybe Kind) + normalizeMbKind _name _instTys mbKind@(Just _) = return mbKind + normalizeMbKind name instTys Nothing = do +#if MIN_VERSION_template_haskell(2,16,0) + mbReifiedKind <- return Nothing `recover` fmap Just (reifyType name) + T.mapM normalizeKind mbReifiedKind + where + normalizeKind :: Kind -> Q Kind + normalizeKind k = do + k' <- resolveKindSynonyms k + -- Step (1) in Note [Tricky result kinds] + -- (Wrinkle: normalizeMbKind argument unification). + let (args, res) = unravelKindUpTo instTys k' + -- Step (2) in Note [Tricky result kinds] + -- (Wrinkle: normalizeMbKind argument unification). + (instTys', args') = + unzip $ + mapMaybe + (\(instTy, arg) -> + case arg of + VisFADep tvb -> Just (instTy, bndrParam tvb) + VisFAAnon k -> (, k) <$> sigTMaybeKind instTy) + args + (subst, _) = mergeArguments args' instTys' + -- Step (3) in Note [Tricky result kinds] + -- (Wrinkle: normalizeMbKind argument unification). + pure $ applySubstitution (VarT <$> subst) res +#else + return Nothing +#endif + + -- Given a data type declaration's binders, as well as the arguments and + -- result of its explicit return kind, compute the free type variables. + -- For example, this: + -- + -- @ + -- data T (a :: j) :: forall k. Maybe k -> Type + -- @ + -- + -- Would yield: + -- + -- @ + -- [j, (a :: j), k, (b :: k)] + -- @ + -- + -- Where @b@ is a fresh name that is generated in 'mkExtraFunArgForalls'. + datatypeFreeVars :: [TyVarBndr_ flag] -> FunArgs -> Kind -> [TyVarBndrUnit] + datatypeFreeVars declBndrs kindArgs kindRes = + freeVariablesWellScoped $ + bndrParams declBndrs ++ funArgTys kindArgs ++ [kindRes] + + normalizeDataD :: Cxt -> Name -> [TyVarBndrVis] -> Maybe Kind + -> [Con] -> DatatypeVariant -> Q DatatypeInfo + normalizeDataD context name tyvars mbKind cons variant = do + -- NB: use `filter isRequiredTvb tyvars` here. It is possible for some of + -- the `tyvars` to be `BndrInvis` if the data type is quoted, e.g., + -- + -- data D @k (a :: k) + -- + -- th-abstraction adopts the convention that all binders in the + -- 'datatypeInstTypes' are required, so we want to filter out the `@k`. + let tys = bndrParams $ filter isRequiredTvb tyvars + mbKind' <- normalizeMbKind name tys mbKind + normalize' context name tyvars tys mbKind' cons variant + + normalizeDataInstDPostTH2'15 + :: String -> Cxt -> Maybe [TyVarBndrUnit] -> Type -> Maybe Kind + -> [Con] -> DatatypeVariant -> Q DatatypeInfo + normalizeDataInstDPostTH2'15 what context mbTyvars nameInstTys + mbKind cons variant = + case decomposeType nameInstTys of + ConT name :| instTys -> do + mbKind' <- normalizeMbKind name instTys mbKind + normalize' context name + (fromMaybe (freeVariablesWellScoped instTys) mbTyvars) + instTys mbKind' cons variant + _ -> fail $ "Unexpected " ++ what ++ " instance head: " ++ pprint nameInstTys + + normalizeDataInstDPreTH2'15 + :: Cxt -> Name -> [Type] -> Maybe Kind + -> [Con] -> DatatypeVariant -> Q DatatypeInfo + normalizeDataInstDPreTH2'15 context name instTys mbKind cons variant = do + mbKind' <- normalizeMbKind name instTys mbKind + normalize' context name (freeVariablesWellScoped instTys) + instTys mbKind' cons variant + + -- The main worker of this function. + normalize' :: Cxt -> Name -> [TyVarBndr_ flag] -> [Type] -> Maybe Kind + -> [Con] -> DatatypeVariant -> Q DatatypeInfo + normalize' context name tvbs instTys mbKind cons variant = do + -- If `mbKind` is *still* Nothing after all of the work done in + -- normalizeMbKind, then conservatively assume that the return kind is + -- `Type`. See step (1) of Note [Tricky result kinds]. + let kind = fromMaybe starK mbKind + kind' <- resolveKindSynonyms kind + let (kindArgs, kindRes) = unravelType kind' + (extra_vis_tvbs, kindArgs') <- mkExtraFunArgForalls kindArgs + let tvbs' = datatypeFreeVars tvbs kindArgs' kindRes + instTys' = instTys ++ bndrParams extra_vis_tvbs + dec <- normalizeDec' isReified context name tvbs' instTys' kindRes cons variant + repair13618' $ giveDIVarsStarKinds isReified dec + +{- +Note [Tricky result kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this example, which uses UnliftedNewtypes: + + type T :: TYPE r + newtype T where + MkT :: forall r. Any @(TYPE r) -> T @r + +This has one universally quantified type variable `r`, but making +`reifyDatatype ''T` realize this is surprisingly tricky. There root of the +trickiness is the fact that `Language.Haskell.TH.reify ''T` will yield this: + + newtype T where + MkT :: forall r. (Any :: TYPE r) -> (T :: TYPE r) + +In particular, note that: + +1. `reify` does not give `T` an explicit return kind of `TYPE r`. This is bad, + because without this, we cannot conclude that `r` is universally quantified. +2. The reified type of the `MkT` constructor uses explicit kind annotations + instead of visible kind applications. That is, the return type is + `T :: TYPE r` instead of `T @r`. This makes it even trickier to figure out + that `r` is universally quantified, as `r` does not appear directly + underneath an application of `T`. + +We resolve each of these issues as follows: + +1. In `normalizeDecFor.normalizeMbKind`, we attempt to use `reifyType` to look + up the return kind of the data type. In the `T` example above, this suffices + to conclude that `T :: TYPE r`. `reifyType` won't always work (e.g., when + using `normalizeDec` on a data type without an explicit return kind), so for + those situations, we conservatively assume that the data type has return kind + `Type`. + + The implementation of `normalizeMbKind` is somewhat involved. See + "Wrinkle: normalizeMbKind argument unification" below for more details. +2. After determining the result kind `K1`, we pass `K1` through to + `normalizeGadtC`. In that function, we check if the return type of the data + constructor is of the form `Ty :: K2`, and if so, we attempt to unify `K1` + and `K2` by passing through to `mergeArguments`. In the example above, this + lets us conclude that the `r` in the data type return kind is the same `r` + as in the data constructor. + +=================================================== +== Wrinkle: normalizeMbKind argument unification == +=================================================== + +Here is a slightly more involved example: + + type T2 :: TYPE r1 -> TYPE r1 + newtype T2 (a :: TYPE r2) = MkT2 a + +Here, we must use `reifyType` in `normalizeMbKind` to determine that the return +kind is `TYPE r1`. But we must be careful here: `r1` is actually the same type +variable as `r2`! We don't want to accidentally end up quantifying over the two +variables separately in `datatypeInstVars`, since they're really one and the +same. + +We accomplish this by doing the following: + +1. After calling `reifyKind` in `normalizeMbKind`, split the result kind into + as many arguments as there are visible binders in the data type declaration. + In the `T2` example above, there is exactly one visible binder in + `newtype T2 a`, so we split the kind `TYPE r1 -> TYPE r1` by one argument to + get ([TYPE r1], TYPE r1). See `unravelKindUpTo` for how this splitting logic + is implemented. +2. We then unify the argument kinds resuling from the splitting in the previous + step with the corresponding kinds from the data type declaration. In the + example above, the split argument kind is `TYPE r1`, and the binder in the + declaration has kind `TYPE r2`, so we unify `TYPE r1` with `TYPE r2` using + `mergeArguments` to get a substitution [r1 :-> r2]. +3. We then apply the substitution from the previous step to the rest of the + kind. In the example above, that means we apply the [r1 :-> r2] substitution + to `TYPE r1` to obtain `TYPE r2`. + +The payoff is that everything consistently refers to `r2`, rather than the mix +of `r1` and `r2` as before. +-} + +-- | Create new kind variable binder names corresponding to the return kind of +-- a data type. This is useful when you have a data type like: +-- +-- @ +-- data Foo :: forall k. k -> Type -> Type where ... +-- @ +-- +-- But you want to be able to refer to the type @Foo a b@. +-- 'mkExtraKindBinders' will take the kind @forall k. k -> Type -> Type@, +-- discover that is has two visible argument kinds, and return as a result +-- two new kind variable binders @[a :: k, b :: Type]@, where @a@ and @b@ +-- are fresh type variable names. +-- +-- This expands kind synonyms if necessary. +mkExtraKindBinders :: Kind -> Q [TyVarBndrUnit] +mkExtraKindBinders kind = do + kind' <- resolveKindSynonyms kind + let (args, _) = unravelType kind' + (extra_kvbs, _) <- mkExtraFunArgForalls args + return extra_kvbs + +-- | Take the supplied function kind arguments ('FunArgs') and do two things: +-- +-- 1. For each 'FAAnon' with kind @k@, generate a fresh name @a@ and return +-- the 'TyVarBndr' @a :: k@. Also return each visible @forall@ in an +-- 'FAForalls' as a 'TyVarBndr'. (This is what the list of 'TyVarBndrUnit's +-- in the return type consists of.) +-- +-- 2. Return a new 'FunArgs' value where each 'FAAnon' has been replaced with +-- @'FAForalls' ('ForallVis' [a :: k])@, where @a :: k@ the corresponding +-- 'TyVarBndr' computed in step (1). +-- +-- As an example, consider this function kind: +-- +-- @ +-- forall k. k -> Type -> Type +-- @ +-- +-- After splitting this kind into its 'FunArgs': +-- +-- @ +-- ['FAForalls' ('ForallInvis' [k]), 'FAAnon' k, 'FAAnon' Type] +-- @ +-- +-- Calling 'mkExtraFunArgForalls' on this 'FunArgs' value would return: +-- +-- @ +-- ( [a :: k, b :: Type] +-- , [ 'FAForalls' ('ForallInvis' [k]) +-- , 'FAForalls' ('ForallVis' [a :: k]) +-- , 'FAForalls' ('ForallVis' [b :: Type]) +-- ] +-- ) +-- @ +-- +-- Where @a@ and @b@ are fresh. +-- +-- This function is used in two places: +-- +-- 1. As the workhorse for 'mkExtraKindBinders'. +-- +-- 2. In 'normalizeDecFor', as part of computing the 'datatypeInstVars' and as +-- part of eta expanding the explicit return kind. +mkExtraFunArgForalls :: FunArgs -> Q ([TyVarBndrUnit], FunArgs) +mkExtraFunArgForalls FANil = + return ([], FANil) +mkExtraFunArgForalls (FAForalls tele args) = do + (extra_vis_tvbs', args') <- mkExtraFunArgForalls args + case tele of + ForallVis tvbs -> + return ( tvbs ++ extra_vis_tvbs' + , FAForalls (ForallVis tvbs) args' + ) + ForallInvis tvbs -> + return ( extra_vis_tvbs' + , FAForalls (ForallInvis tvbs) args' + ) +mkExtraFunArgForalls (FACxt ctxt args) = do + (extra_vis_tvbs', args') <- mkExtraFunArgForalls args + return (extra_vis_tvbs', FACxt ctxt args') +mkExtraFunArgForalls (FAAnon anon args) = do + name <- newName "x" + let tvb = kindedTV name anon + (extra_vis_tvbs', args') <- mkExtraFunArgForalls args + return ( tvb : extra_vis_tvbs' + , FAForalls (ForallVis [tvb]) args' + ) + +-- | Is a declaration for a @data instance@ or @newtype instance@? +isFamInstVariant :: DatatypeVariant -> Bool +isFamInstVariant dv = + case dv of + Datatype -> False + Newtype -> False + DataInstance -> True + NewtypeInstance -> True + TypeData -> False + +bndrParams :: [TyVarBndr_ flag] -> [Type] +bndrParams = map bndrParam + +bndrParam :: TyVarBndr_ flag -> Type +bndrParam = elimTV VarT (\n k -> SigT (VarT n) k) + +-- | Returns 'True' if the flag of the supplied 'TyVarBndrVis' is 'BndrReq'. +isRequiredTvb :: TyVarBndrVis -> Bool +isRequiredTvb tvb = tvFlag tvb == BndrReq + +-- | Remove the outermost 'SigT'. +stripSigT :: Type -> Type +stripSigT (SigT t _) = t +stripSigT t = t + +-- | If the supplied 'Type' is a @'SigT' _ k@, return @'Just' k@. Otherwise, +-- return 'Nothing'. +sigTMaybeKind :: Type -> Maybe Kind +sigTMaybeKind (SigT _ k) = Just k +sigTMaybeKind _ = Nothing + +normalizeDec' :: + IsReifiedDec {- ^ Is this a reified 'Dec'? -} -> + Cxt {- ^ Datatype context -} -> + Name {- ^ Type constructor -} -> + [TyVarBndrUnit] {- ^ Type parameters -} -> + [Type] {- ^ Argument types -} -> + Kind {- ^ Result kind -} -> + [Con] {- ^ Constructors -} -> + DatatypeVariant {- ^ Extra information -} -> + Q DatatypeInfo +normalizeDec' reifiedDec context name params instTys resKind cons variant = + do cons' <- concat <$> mapM (normalizeConFor reifiedDec name params instTys resKind variant) cons + return DatatypeInfo + { datatypeContext = context + , datatypeName = name + , datatypeVars = params + , datatypeInstTypes = instTys + , datatypeCons = cons' + , datatypeReturnKind = resKind + , datatypeVariant = variant + } + +-- | Normalize a 'Con' into a 'ConstructorInfo'. This requires knowledge of +-- 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 -} -> + [TyVarBndrUnit] {- ^ Type parameters -} -> + [Type] {- ^ Argument types -} -> + Kind {- ^ Result kind -} -> + DatatypeVariant {- ^ Extra information -} -> + Con {- ^ Constructor -} -> + Q [ConstructorInfo] +normalizeCon = normalizeConFor isn'tReified + +normalizeConFor :: + IsReifiedDec {- ^ Is this a reified 'Dec'? -} -> + Name {- ^ Type constructor -} -> + [TyVarBndrUnit] {- ^ Type parameters -} -> + [Type] {- ^ Argument types -} -> + Kind {- ^ Result kind -} -> + DatatypeVariant {- ^ Extra information -} -> + Con {- ^ Constructor -} -> + Q [ConstructorInfo] +normalizeConFor reifiedDec typename params instTys resKind variant = + fmap (map (giveCIVarsStarKinds reifiedDec)) . dispatch + where + -- 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 + -- Don't call reifyFixityCompat here! We need to be able to distinguish + -- between a default fixity and an explicit @infixl 9@. + mbFi <- return Nothing `recover` reifyFixity n + let userSuppliedFixity = isJust mbFi + 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 :: [TyVarBndrUnit] + -> 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 (changeTVFlags () tyvars'++tyvars) (context'++context) True c' + 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 instTys resKind tyvars context + in defaultCase + +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 + +normalizeGadtC :: + Name {- ^ Type constructor -} -> + [TyVarBndrUnit] {- ^ Type parameters -} -> + [Type] {- ^ Argument types -} -> + Kind {- ^ Result kind -} -> + [TyVarBndrUnit] {- ^ 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 instTys resKind tyvars context names innerType + fields stricts getVariant = + do -- It's possible that the constructor has implicitly quantified type + -- variables, such as in the following example (from #58): + -- + -- [d| data Foo where + -- MkFoo :: a -> Foo |] + -- + -- normalizeGadtC assumes that all type variables have binders, however, + -- so we use freeVariablesWellScoped to obtain the implicit type + -- variables' binders before proceeding. + let implicitTyvars = freeVariablesWellScoped + [curryType (changeTVFlags SpecifiedSpec tyvars) + context fields innerType] + allTyvars = implicitTyvars ++ tyvars + + -- Due to GHC Trac #13885, it's possible that the type variables bound by + -- a GADT constructor will shadow those that are bound by the data type. + -- This function assumes this isn't the case in certain parts (e.g., when + -- mergeArguments is invoked), so we do an alpha-renaming of the + -- constructor-bound variables before proceeding. See #36 for an example + -- of what can go wrong if this isn't done. + let conBoundNames = + concatMap (\tvb -> tvName tvb:freeVariables (tvKind tvb)) allTyvars + conSubst <- T.sequence $ Map.fromList [ (n, newName (nameBase n)) + | n <- conBoundNames ] + let conSubst' = fmap VarT conSubst + renamedTyvars = + map (elimTV (\n -> plainTV (conSubst Map.! n)) + (\n k -> kindedTV (conSubst Map.! n) + (applySubstitution conSubst' k))) allTyvars + renamedContext = applySubstitution conSubst' context + renamedInnerType = applySubstitution conSubst' innerType + renamedFields = applySubstitution conSubst' fields + + innerType' <- resolveTypeSynonyms renamedInnerType + + -- If the return type in the data constructor is of the form `T :: K`, then + -- return (T, Just K, Just resKind), where `resKind` is the result kind of + -- the parent data type. Otherwise, return (T :: K, Nothing, Nothing). The + -- two `Maybe` values are passed below to `mergeArguments` such that if + -- they are both `Just`, then we will attempt to unify `K` and `resKind`. + -- See step (2) of Note [Tricky result kinds]. + let (innerType'', mbInnerResKind, mbResKind) = + case innerType' of + SigT t innerResKind -> (t, Just innerResKind, Just resKind) + _ -> (innerType', Nothing, Nothing) + + case decomposeType innerType'' of + ConT innerTyCon :| ts | typename == innerTyCon -> + + let -- See step (2) of Note [Tricky result kinds]. + instTys' = maybeToList mbResKind ++ instTys + ts' = maybeToList mbInnerResKind ++ ts + + (substName, context1) = + closeOverKinds (kindsOfFVsOfTvbs renamedTyvars) + (kindsOfFVsOfTvbs params) + (mergeArguments instTys' ts') + subst = VarT <$> substName + exTyvars = [ tv | tv <- renamedTyvars, Map.notMember (tvName tv) subst ] + + -- The use of substTyVarBndrKinds below will never capture, as the + -- range of the substitution will always use distinct names from + -- exTyvars due to the alpha-renaming pass above. + exTyvars' = substTyVarBndrKinds subst exTyvars + context2 = applySubstitution subst (context1 ++ renamedContext) + fields' = applySubstitution subst renamedFields + in sequence [ ConstructorInfo name exTyvars' context2 + fields' stricts <$> variantQ + | name <- names + , let variantQ = getVariant name + ] + + _ -> fail "normalizeGadtC: Expected type constructor application" + +{- +Extend a type variable renaming subtitution and a list of equality +predicates by looking into kind information as much as possible. + +Why is this necessary? Consider the following example: + + data (a1 :: k1) :~: (b1 :: k1) where + Refl :: forall k2 (a2 :: k2). a2 :~: a2 + +After an initial call to mergeArguments, we will have the following +substitution and context: + +* Substitution: [a2 :-> a1] +* Context: (a2 ~ b1) + +We shouldn't stop there, however! We determine the existentially quantified +type variables of a constructor by filtering out those constructor-bound +variables which do not appear in the substitution that mergeArguments +returns. In this example, Refl's bound variables are k2 and a2. a2 appears +in the returned substitution, but k2 does not, which means that we would +mistakenly conclude that k2 is existential! + +Although we don't have the full power of kind inference to guide us here, we +can at least do the next best thing. Generally, the datatype-bound type +variables and the constructor type variable binders contain all of the kind +information we need, so we proceed as follows: + +1. Construct a map from each constructor-bound variable to its kind. (Do the + same for each datatype-bound variable). These maps are the first and second + arguments to closeOverKinds, respectively. +2. Call mergeArguments once on the GADT return type and datatype-bound types, + and pass that in as the third argument to closeOverKinds. +3. For each name-name pair in the supplied substitution, check if the first and + second names map to kinds in the first and second kind maps in + closeOverKinds, respectively. If so, associate the first kind with the + second kind. +4. For each kind association discovered in part (3), call mergeArguments + on the lists of kinds. This will yield a kind substitution and kind + equality context. +5. If the kind substitution is non-empty, then go back to step (3) and repeat + the process on the new kind substitution and context. + + Otherwise, if the kind substitution is empty, then we have reached a fixed- + point (i.e., we have closed over the kinds), so proceed. +6. Union up all of the substitutions and contexts, and return those. + +This algorithm is not perfect, as it will only catch everything if all of +the kinds are explicitly mentioned somewhere (and not left quantified +implicitly). Thankfully, reifying data types via Template Haskell tends to +yield a healthy amount of kind signatures, so this works quite well in +practice. +-} +closeOverKinds :: Map Name Kind + -> Map Name Kind + -> (Map Name Name, Cxt) + -> (Map Name Name, Cxt) +closeOverKinds domainFVKinds rangeFVKinds = go + where + go :: (Map Name Name, Cxt) -> (Map Name Name, Cxt) + go (subst, context) = + let substList = Map.toList subst + (kindsInner, kindsOuter) = + unzip $ + mapMaybe (\(d, r) -> do d' <- Map.lookup d domainFVKinds + r' <- Map.lookup r rangeFVKinds + return (d', r')) + substList + (kindSubst, kindContext) = mergeArguments kindsOuter kindsInner + (restSubst, restContext) + = if Map.null kindSubst -- Fixed-point calculation + then (Map.empty, []) + else go (kindSubst, kindContext) + finalSubst = Map.unions [subst, kindSubst, restSubst] + finalContext = nub $ concat [context, kindContext, restContext] + -- Use `nub` here in an effort to minimize the number of + -- redundant equality constraints in the returned context. + in (finalSubst, finalContext) + +-- Look into a list of types and map each free variable name to its kind. +kindsOfFVsOfTypes :: [Type] -> Map Name Kind +kindsOfFVsOfTypes = foldMap go + where + go :: Type -> Map Name Kind + go (AppT t1 t2) = go t1 `Map.union` go t2 + go (SigT t k) = + let kSigs = go k + in case t of + VarT n -> Map.insert n k kSigs + _ -> go t `Map.union` kSigs + + go (ForallT {}) = forallError +#if MIN_VERSION_template_haskell(2,16,0) + go (ForallVisT {}) = forallError +#endif + + go _ = Map.empty + + forallError :: a + forallError = error "`forall` type used in data family pattern" + +-- Look into a list of type variable binder and map each free variable name +-- to its kind (also map the names that KindedTVs bind to their respective +-- kinds). This function considers the kind of a PlainTV to be *. +kindsOfFVsOfTvbs :: [TyVarBndr_ flag] -> Map Name Kind +kindsOfFVsOfTvbs = foldMap go + where + go :: TyVarBndr_ flag -> Map Name Kind + go = elimTV (\n -> Map.singleton n starK) + (\n k -> let kSigs = kindsOfFVsOfTypes [k] + in Map.insert n k kSigs) + +mergeArguments :: + [Type] {- ^ outer parameters -} -> + [Type] {- ^ inner parameters (specializations ) -} -> + (Map Name Name, Cxt) +mergeArguments ns ts = foldr aux (Map.empty, []) (zip ns ts) + where + + aux (f `AppT` x, g `AppT` y) sc = + aux (x,y) (aux (f,g) sc) + + aux (VarT n,p) (subst, context) = + case p of + VarT m | m == n -> (subst, context) + -- If the two variables are the same, don't bother extending + -- the substitution. (This is purely an optimization.) + | Just n' <- Map.lookup m subst + , n == n' -> (subst, context) + -- If a variable is already in a substitution and it maps + -- to the variable that we are trying to unify with, then + -- leave the context alone. (Not doing so caused #46.) + | Map.notMember m subst -> (Map.insert m n subst, context) + _ -> (subst, equalPred (VarT n) p : context) + + aux (SigT x _, y) sc = aux (x,y) sc -- learn about kinds?? + -- This matches *after* VarT so that we can compute a substitution + -- that includes the kind signature. + aux (x, SigT y _) sc = aux (x,y) sc + + aux _ sc = sc + +-- | Expand all of the type synonyms in a type. +-- +-- Note that this function will drop parentheses as a side effect. +resolveTypeSynonyms :: Type -> Q Type +resolveTypeSynonyms t = + let (f, xs) = decomposeTypeArgs t + normal_xs = filterTANormals xs + + -- Either the type is not headed by a type synonym, or it is headed by a + -- type synonym that is not applied to enough arguments. Leave the type + -- alone and only expand its arguments. + defaultCase :: Type -> Q Type + defaultCase ty = foldl appTypeArg ty <$> mapM resolveTypeArgSynonyms xs + + expandCon :: Name -- The Name to check whether it is a type synonym or not + -> Type -- The argument type to fall back on if the supplied + -- Name isn't a type synonym + -> Q Type + expandCon n ty = do + mbInfo <- reifyMaybe n + case mbInfo of + Just (TyConI (TySynD _ synvars def)) + | length normal_xs >= length synvars -- Don't expand undersaturated type synonyms (#88) + -> resolveTypeSynonyms $ expandSynonymRHS synvars normal_xs def + _ -> defaultCase ty + + in case f of + ForallT tvbs ctxt body -> + ForallT `fmap` mapM resolve_tvb_syns tvbs + `ap` mapM resolvePredSynonyms ctxt + `ap` resolveTypeSynonyms body + SigT ty ki -> do + ty' <- resolveTypeSynonyms ty + ki' <- resolveKindSynonyms ki + defaultCase $ SigT ty' ki' + ConT n -> expandCon n f + InfixT t1 n t2 -> do + t1' <- resolveTypeSynonyms t1 + t2' <- resolveTypeSynonyms t2 + expandCon n (InfixT t1' n t2') + UInfixT t1 n t2 -> do + t1' <- resolveTypeSynonyms t1 + t2' <- resolveTypeSynonyms t2 + expandCon n (UInfixT t1' n t2') +#if MIN_VERSION_template_haskell(2,15,0) + ImplicitParamT n t -> do + ImplicitParamT n <$> resolveTypeSynonyms t +#endif +#if MIN_VERSION_template_haskell(2,16,0) + ForallVisT tvbs body -> + ForallVisT `fmap` mapM resolve_tvb_syns tvbs + `ap` resolveTypeSynonyms body +#endif +#if MIN_VERSION_template_haskell(2,19,0) + PromotedInfixT t1 n t2 -> do + t1' <- resolveTypeSynonyms t1 + t2' <- resolveTypeSynonyms t2 + return $ PromotedInfixT t1' n t2' + PromotedUInfixT t1 n t2 -> do + t1' <- resolveTypeSynonyms t1 + t2' <- resolveTypeSynonyms t2 + return $ PromotedUInfixT t1' n t2' +#endif + _ -> defaultCase f + +-- | Expand all of the type synonyms in a 'TypeArg'. +resolveTypeArgSynonyms :: TypeArg -> Q TypeArg +resolveTypeArgSynonyms (TANormal t) = TANormal <$> resolveTypeSynonyms t +resolveTypeArgSynonyms (TyArg k) = TyArg <$> resolveKindSynonyms k + +-- | Expand all of the type synonyms in a 'Kind'. +resolveKindSynonyms :: Kind -> Q Kind +resolveKindSynonyms = resolveTypeSynonyms + +-- | Expand all of the type synonyms in a the kind of a 'TyVarBndr'. +resolve_tvb_syns :: TyVarBndr_ flag -> Q (TyVarBndr_ flag) +resolve_tvb_syns = mapMTVKind resolveKindSynonyms + +expandSynonymRHS :: + [TyVarBndr_ flag] {- ^ 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 +resolvePredSynonyms = resolveTypeSynonyms + +-- | Decompose a type into a list of it's outermost applications. This process +-- forgets about infix application, explicit parentheses, and visible kind +-- applications. +-- +-- This operation should be used after all 'UInfixT' cases have been resolved +-- by 'resolveFixities' if the argument is being user generated. +-- +-- > t ~= foldl1 AppT (decomposeType t) +decomposeType :: Type -> NonEmpty Type +decomposeType t = + case decomposeTypeArgs t of + (f, x) -> f :| filterTANormals x + +-- | A variant of 'decomposeType' that preserves information about visible kind +-- applications by returning a 'NonEmpty' list of 'TypeArg's. +decomposeTypeArgs :: Type -> (Type, [TypeArg]) +decomposeTypeArgs = go [] + where + go :: [TypeArg] -> Type -> (Type, [TypeArg]) + go args (AppT f x) = go (TANormal x:args) f + go args (ParensT t) = go args t +#if MIN_VERSION_template_haskell(2,15,0) + go args (AppKindT f x) = go (TyArg x:args) f +#endif + go args t = (t, args) + +-- | An argument to a type, either a normal type ('TANormal') or a visible +-- kind application ('TyArg'). +data TypeArg + = TANormal Type + | TyArg Kind + +-- | Apply a 'Type' to a 'TypeArg'. +appTypeArg :: Type -> TypeArg -> Type +appTypeArg f (TANormal x) = f `AppT` x +appTypeArg f (TyArg _k) = +#if MIN_VERSION_template_haskell(2,15,0) + f `AppKindT` _k +#else + f -- VKA isn't supported, so conservatively drop the argument +#endif + +-- | Filter out all of the normal type arguments from a list of 'TypeArg's. +filterTANormals :: [TypeArg] -> [Type] +filterTANormals = mapMaybe f + where + f :: TypeArg -> Maybe Type + f (TANormal t) = Just t + f (TyArg {}) = Nothing + +-- 'NonEmpty' didn't move into base until recently. Reimplementing it locally +-- saves dependencies for supporting older GHCs +data NonEmpty a = a :| [a] + +data NonEmptySnoc a = [a] :|- a + +-- Decompose a function type into its context, argument types, +-- and return type. For instance, this +-- +-- forall a b. (Show a, b ~ Int) => (a -> b) -> Char -> Int +-- +-- becomes +-- +-- ([a, b], [Show a, b ~ Int], [a -> b, Char] :|- Int) +uncurryType :: Type -> ([TyVarBndrSpec], Cxt, NonEmptySnoc Type) +uncurryType = go [] [] [] + where + go tvbs ctxt args (AppT (AppT ArrowT t1) t2) = go tvbs ctxt (t1:args) t2 + go tvbs ctxt args (ForallT tvbs' ctxt' t) = go (tvbs++tvbs') (ctxt++ctxt') args t + go tvbs ctxt args t = (tvbs, ctxt, reverse args :|- t) + +-- Reconstruct a function type from its type variable binders, context, +-- argument types and return type. +curryType :: [TyVarBndrSpec] -> Cxt -> [Type] -> Type -> Type +curryType tvbs ctxt args res = + ForallT tvbs ctxt $ foldr (\arg t -> ArrowT `AppT` arg `AppT` t) res args + +-- All of the code from @ForallTelescope@ through @unravelType@ is taken from +-- the @th-desugar@ library, which is licensed under a 3-Clause BSD license. + +-- | The type variable binders in a @forall@. This is not used by the TH AST +-- itself, but this is used as an intermediate data type in 'FAForalls'. +data ForallTelescope + = ForallVis [TyVarBndrUnit] + -- ^ A visible @forall@ (e.g., @forall a -> {...}@). + -- These do not have any notion of specificity, so we use + -- '()' as a placeholder value in the 'TyVarBndr's. + | ForallInvis [TyVarBndrSpec] + -- ^ An invisible @forall@ (e.g., @forall a {b} c -> {...}@), + -- where each binder has a 'Specificity'. + +-- | The list of arguments in a function 'Type'. +data FunArgs + = FANil + -- ^ No more arguments. + | FAForalls ForallTelescope FunArgs + -- ^ A series of @forall@ed type variables followed by a dot (if + -- 'ForallInvis') or an arrow (if 'ForallVis'). For example, + -- the type variables @a1 ... an@ in @forall a1 ... an. r@. + | FACxt Cxt FunArgs + -- ^ A series of constraint arguments followed by @=>@. For example, + -- the @(c1, ..., cn)@ in @(c1, ..., cn) => r@. + | FAAnon Kind FunArgs + -- ^ An anonymous argument followed by an arrow. For example, the @a@ + -- in @a -> r@. + +-- | A /visible/ function argument type (i.e., one that must be supplied +-- explicitly in the source code). This is in contrast to /invisible/ +-- arguments (e.g., the @c@ in @c => r@), which are instantiated without +-- the need for explicit user input. +data VisFunArg + = VisFADep TyVarBndrUnit + -- ^ A visible @forall@ (e.g., @forall a -> a@). + | VisFAAnon Kind + -- ^ An anonymous argument followed by an arrow (e.g., @a -> r@). + +-- | Decompose a function 'Type' into its arguments (the 'FunArgs') and its +-- result type (the 'Type). +unravelType :: Type -> (FunArgs, Type) +unravelType (ForallT tvbs cxt ty) = + let (args, res) = unravelType ty in + (FAForalls (ForallInvis tvbs) (FACxt cxt args), res) +unravelType (AppT (AppT ArrowT t1) t2) = + let (args, res) = unravelType t2 in + (FAAnon t1 args, res) +#if __GLASGOW_HASKELL__ >= 809 +unravelType (ForallVisT tvbs ty) = + let (args, res) = unravelType ty in + (FAForalls (ForallVis tvbs) args, res) +#endif +unravelType t = (FANil, t) + +-- | Reconstruct an arrow 'Type' from its argument and result types. +ravelType :: FunArgs -> Type -> Type +ravelType FANil res = res +-- We need a special case for FAForalls ForallInvis followed by FACxt so that we may +-- collapse them into a single ForallT when raveling. +ravelType (FAForalls (ForallInvis tvbs) (FACxt p args)) res = + ForallT tvbs p (ravelType args res) +ravelType (FAForalls (ForallInvis tvbs) args) res = ForallT tvbs [] (ravelType args res) +ravelType (FAForalls (ForallVis _tvbs) _args) _res = +#if __GLASGOW_HASKELL__ >= 809 + ForallVisT _tvbs (ravelType _args _res) +#else + error "Visible dependent quantification supported only on GHC 8.10+" +#endif +ravelType (FACxt cxt args) res = ForallT [] cxt (ravelType args res) +ravelType (FAAnon t args) res = AppT (AppT ArrowT t) (ravelType args res) + +-- | Convert a 'FunArg's value into the list of 'Type's that it contains. +-- For example, given this function type: +-- +-- @ +-- forall k (a :: k). Proxy a -> forall b. Maybe b +-- @ +-- +-- Then calling @funArgTys@ on the arguments would yield: +-- +-- @ +-- [k, (a :: k), Proxy a, b, Maybe b] +-- @ +-- +-- This is primarily used for the purposes of computing all of the type +-- variables that appear in a 'FunArgs' value. +funArgTys :: FunArgs -> [Type] +funArgTys FANil = [] +funArgTys (FAForalls tele args) = + forallTelescopeTys tele ++ funArgTys args +funArgTys (FACxt ctxt args) = + ctxt ++ funArgTys args +funArgTys (FAAnon anon args) = + anon : funArgTys args + +-- | Convert a 'ForallTelescope' value into the list of 'Type's that it +-- contains. See the Haddocks for 'funArgTys' for an example of what this does. +forallTelescopeTys :: ForallTelescope -> [Type] +forallTelescopeTys (ForallVis tvbs) = bndrParams tvbs +forallTelescopeTys (ForallInvis tvbs) = bndrParams tvbs + +-- | @'filterVisFunArgsUpTo' xs args@ will split @args@ into 'VisFunArg's as +-- many times as there are elements in @xs@, pairing up each entry in @xs@ with +-- the corresponding 'VisFunArg' in the process. This will stop after the last +-- entry in @xs@ has been paired up. +-- +-- For example, this: +-- +-- @ +-- 'filterVisFunArgsUpTo' +-- [Bool, True] +-- [ FAForalls (ForallVis [j]) +-- , FAAnon j +-- , FAForalls (ForallInvis [k]) +-- , FAAnon k +-- ] +-- @ +-- +-- Will yield: +-- +-- @ +-- ( [(Bool, VisFADep j), (True, VisFAAnon j)] +-- , [FAForalls (ForallInvis [k]), FAAnon k] +-- ) +-- @ +-- +-- This function assumes the precondition that there are at least as many +-- visible function arguments in @args@ as there are elements in @xs@. If this +-- is not the case, this function will raise an error. +filterVisFunArgsUpTo :: forall a. [a] -> FunArgs -> ([(a, VisFunArg)], FunArgs) +filterVisFunArgsUpTo = go_fun_args + where + go_fun_args :: [a] -> FunArgs -> ([(a, VisFunArg)], FunArgs) + go_fun_args [] args = + ([], args) + go_fun_args (_:_) FANil = + error "filterVisFunArgsUpTo.go_fun_args: Too few FunArgs" + go_fun_args xs (FACxt _ args) = + go_fun_args xs args + go_fun_args (x:xs) (FAAnon t args) = + let (xs', args') = go_fun_args xs args in + ((x, VisFAAnon t):xs', args') + go_fun_args xs (FAForalls tele args) = + case tele of + ForallVis tvbs -> + go_vis_tvbs tvbs xs args + ForallInvis _ -> + go_fun_args xs args + + go_vis_tvbs :: [TyVarBndrUnit] -> [a] -> FunArgs -> ([(a, VisFunArg)], FunArgs) + go_vis_tvbs [] xs args = + go_fun_args xs args + go_vis_tvbs (tvb:tvbs) (x:xs) args = + let (xs', args') = go_vis_tvbs tvbs xs args in + ((x, VisFADep tvb):xs', args') + go_vis_tvbs tvbs [] args = + ([], FAForalls (ForallVis tvbs) args) + +-- | @'unravelKindUpTo' xs k@ will split the function kind @k@ into its argument +-- kinds @args@ and result kind @res@, and then it will call +-- @'filterVisFunArgsUpTo' xs args@. The leftover arguments that were not split +-- apart by 'filterVisFunArgsUpTo' are then raveled back into @res@. +-- +-- For example, this: +-- +-- @ +-- 'filterVisFunArgsUpTo' +-- [Bool, True] +-- (forall j -> j -> forall k. k -> Type) +-- @ +-- +-- Will yield: +-- +-- @ +-- ( [(Bool, VisFADep j), (True, VisFAAnon j)] +-- , forall k. k -> Type +-- ) +-- @ +-- +-- This function assumes the precondition that there are at least as many +-- visible function arguments in @args@ as there are elements in @xs@. If this +-- is not the case, this function will raise an error. +unravelKindUpTo :: [a] -> Kind -> ([(a, VisFunArg)], Kind) +unravelKindUpTo xs k = (xs', ravelType args' res) + where + (args, res) = unravelType k + (xs', args') = filterVisFunArgsUpTo xs args + +-- | 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 + +resolveInfixT (ForallT vs cx t) = ForallT <$> traverse (traverseTVKind resolveInfixT) 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) +#if MIN_VERSION_template_haskell(2,15,0) +resolveInfixT (f `AppKindT` x) = appKindT (resolveInfixT f) (resolveInfixT x) +resolveInfixT (ImplicitParamT n t) + = implicitParamT n $ resolveInfixT t +#endif +#if MIN_VERSION_template_haskell(2,16,0) +resolveInfixT (ForallVisT vs t) = ForallVisT <$> traverse (traverseTVKind resolveInfixT) vs + <*> resolveInfixT t +#endif +#if MIN_VERSION_template_haskell(2,19,0) +resolveInfixT (PromotedInfixT l o r) + = promotedT o `appT` resolveInfixT l `appT` resolveInfixT r +resolveInfixT t@PromotedUInfixT{} + = resolveInfixT =<< resolveInfixT1 (gatherUInfixT t) +#endif +resolveInfixT t = return t + +gatherUInfixT :: Type -> InfixList +gatherUInfixT (UInfixT l o r) = ilAppend (gatherUInfixT l) o False (gatherUInfixT r) +#if MIN_VERSION_template_haskell(2,19,0) +gatherUInfixT (PromotedUInfixT l o r) = ilAppend (gatherUInfixT l) o True (gatherUInfixT r) +#endif +gatherUInfixT t = ILNil t + +-- This can fail due to incompatible fixities +resolveInfixT1 :: InfixList -> TypeQ +resolveInfixT1 = go [] + where + go :: [(Type,Name,Bool,Fixity)] -> InfixList -> TypeQ + go ts (ILNil u) = return (foldl (\acc (l,o,p,_) -> mkConT p o `AppT` l `AppT` acc) u ts) + go ts (ILCons l o p r) = + do ofx <- fromMaybe defaultFixity <$> reifyFixityCompat o + let push = go ((l,o,p,ofx):ts) r + case ts of + (l1,o1,p1,o1fx):ts' -> + case compareFixity o1fx ofx of + Just True -> go ((mkConT p1 o1 `AppT` l1 `AppT` l, o, p, ofx):ts') r + Just False -> push + Nothing -> fail (precedenceError o1 o1fx o ofx) + _ -> push + + mkConT :: Bool -> Name -> Type + mkConT promoted = if promoted then PromotedT else ConT + + compareFixity :: Fixity -> Fixity -> Maybe Bool + compareFixity (Fixity n1 InfixL) (Fixity n2 InfixL) = Just (n1 >= n2) + compareFixity (Fixity n1 InfixR) (Fixity n2 InfixR) = Just (n1 > n2) + compareFixity (Fixity n1 _ ) (Fixity n2 _ ) = + case compare n1 n2 of + GT -> Just True + LT -> Just False + EQ -> Nothing + + precedenceError :: Name -> Fixity -> Name -> Fixity -> String + precedenceError o1 ofx1 o2 ofx2 = + "Precedence parsing error: cannot mix ‘" ++ + nameBase o1 ++ "’ [" ++ showFixity ofx1 ++ "] and ‘" ++ + nameBase o2 ++ "’ [" ++ showFixity ofx2 ++ + "] in the same infix type expression" + +data InfixList + = ILCons Type -- The first argument to the type operator + Name -- The name of the infix type operator + Bool -- 'True' if this is a promoted infix data constructor, + -- 'False' otherwise + InfixList -- The rest of the infix applications to resolve + | ILNil Type + +ilAppend :: InfixList -> Name -> Bool -> InfixList -> InfixList +ilAppend (ILNil l) o p r = ILCons l o p r +ilAppend (ILCons l1 o1 p1 r1) o p r = ILCons l1 o1 p1 (ilAppend r1 o p r) + + +-- | Render a 'Fixity' as it would appear in Haskell source. +-- +-- Example: @infixl 5@ +showFixity :: Fixity -> String +showFixity (Fixity n d) = showFixityDirection d ++ " " ++ show n + + +-- | Render a 'FixityDirection' like it would appear in Haskell source. +-- +-- Examples: @infixl@ @infixr@ @infix@ +showFixityDirection :: FixityDirection -> String +showFixityDirection InfixL = "infixl" +showFixityDirection InfixR = "infixr" +showFixityDirection InfixN = "infix" + +takeFieldNames :: [(Name,a,b)] -> [Name] +takeFieldNames xs = [a | (a,_,_) <- xs] + +takeFieldStrictness :: [(a,Bang,b)] -> [FieldStrictness] +takeFieldStrictness xs = [normalizeStrictness a | (_,a,_) <- xs] + +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 +-- useful when constructing a type signature for a declaration. +-- This code is careful to ensure that the order of the variables quantified +-- is determined by their order of appearance in the type signature. (In +-- contrast with being dependent upon the Ord instance for 'Name') +quantifyType :: Type -> Type +quantifyType t + | null tvbs + = t + | ForallT tvbs' ctxt' t' <- t -- Collapse two consecutive foralls (#63) + = ForallT (tvbs ++ tvbs') ctxt' t' + | otherwise + = ForallT tvbs [] t + where + tvbs = changeTVFlags SpecifiedSpec $ freeVariablesWellScoped [t] + +-- | Take a list of 'Type's, find their free variables, and sort them +-- according to dependency order. +-- +-- As an example of how this function works, consider the following type: +-- +-- @ +-- Proxy (a :: k) +-- @ +-- +-- Calling 'freeVariables' on this type would yield @[a, k]@, since that is +-- the order in which those variables appear in a left-to-right fashion. But +-- this order does not preserve the fact that @k@ is the kind of @a@. Moreover, +-- if you tried writing the type @forall a k. Proxy (a :: k)@, GHC would reject +-- this, since GHC would demand that @k@ come before @a@. +-- +-- 'freeVariablesWellScoped' orders the free variables of a type in a way that +-- preserves this dependency ordering. If one were to call +-- 'freeVariablesWellScoped' on the type above, it would return +-- @[k, (a :: k)]@. (This is why 'freeVariablesWellScoped' returns a list of +-- 'TyVarBndr's instead of 'Name's, since it must make it explicit that @k@ +-- is the kind of @a@.) +-- +-- 'freeVariablesWellScoped' guarantees the free variables returned will be +-- ordered such that: +-- +-- 1. Whenever an explicit kind signature of the form @(A :: K)@ is +-- encountered, the free variables of @K@ will always appear to the left of +-- the free variables of @A@ in the returned result. +-- +-- 2. The constraint in (1) notwithstanding, free variables will appear in +-- left-to-right order of their original appearance. +-- +-- On older GHCs, this takes measures to avoid returning explicitly bound +-- kind variables, which was not possible before @TypeInType@. +freeVariablesWellScoped :: [Type] -> [TyVarBndrUnit] +freeVariablesWellScoped tys = + let fvs :: [Name] + fvs = freeVariables tys + + varKindSigs :: Map Name Kind + varKindSigs = foldMap go_ty tys + where + go_ty :: Type -> Map Name Kind + go_ty (ForallT tvbs ctxt t) = + foldr (\tvb -> Map.delete (tvName tvb)) + (foldMap go_ty ctxt `mappend` go_ty t) tvbs + go_ty (AppT t1 t2) = go_ty t1 `mappend` go_ty t2 + go_ty (SigT t k) = + let kSigs = go_ty k + in case t of + VarT n -> Map.insert n k kSigs + _ -> go_ty t `mappend` kSigs +#if MIN_VERSION_template_haskell(2,15,0) + go_ty (AppKindT t k) = go_ty t `mappend` go_ty k + go_ty (ImplicitParamT _ t) = go_ty t +#endif +#if MIN_VERSION_template_haskell(2,16,0) + go_ty (ForallVisT tvbs t) = + foldr (\tvb -> Map.delete (tvName tvb)) (go_ty t) tvbs +#endif + go_ty _ = mempty + + -- | Do a topological sort on a list of tyvars, + -- so that binders occur before occurrences + -- E.g. given [ a::k, k::*, b::k ] + -- it'll return a well-scoped list [ k::*, a::k, b::k ] + -- + -- This is a deterministic sorting operation + -- (that is, doesn't depend on Uniques). + -- + -- It is also meant to be stable: that is, variables should not + -- be reordered unnecessarily. + scopedSort :: [Name] -> [Name] + scopedSort = go [] [] + + go :: [Name] -- already sorted, in reverse order + -> [Set Name] -- each set contains all the variables which must be placed + -- before the tv corresponding to the set; they are accumulations + -- of the fvs in the sorted tvs' kinds + + -- This list is in 1-to-1 correspondence with the sorted tyvars + -- INVARIANT: + -- all (\tl -> all (`isSubsetOf` head tl) (tail tl)) (tails fv_list) + -- That is, each set in the list is a superset of all later sets. + -> [Name] -- yet to be sorted + -> [Name] + go acc _fv_list [] = reverse acc + go acc fv_list (tv:tvs) + = go acc' fv_list' tvs + where + (acc', fv_list') = insert tv acc fv_list + + insert :: Name -- var to insert + -> [Name] -- sorted list, in reverse order + -> [Set Name] -- list of fvs, as above + -> ([Name], [Set Name]) -- augmented lists + insert tv [] [] = ([tv], [kindFVSet tv]) + insert tv (a:as) (fvs:fvss) + | tv `Set.member` fvs + , (as', fvss') <- insert tv as fvss + = (a:as', fvs `Set.union` fv_tv : fvss') + + | otherwise + = (tv:a:as, fvs `Set.union` fv_tv : fvs : fvss) + where + fv_tv = kindFVSet tv + + -- lists not in correspondence + insert _ _ _ = error "scopedSort" + + kindFVSet n = + maybe Set.empty (Set.fromList . freeVariables) (Map.lookup n varKindSigs) + ascribeWithKind n = + maybe (plainTV n) (kindedTV n) (Map.lookup n varKindSigs) + + in map ascribeWithKind $ scopedSort fvs + +-- | Substitute all of the free variables in a type with fresh ones +freshenFreeVariables :: Type -> Q Type +freshenFreeVariables t = + do let xs = [ (n, VarT <$> newName (nameBase n)) | n <- freeVariables t] + subst <- T.sequence (Map.fromList xs) + return (applySubstitution subst t) + + +-- | Class for types that support type variable substitution. +class TypeSubstitution a where + -- | Apply a type variable substitution. + applySubstitution :: Map Name Type -> a -> a + -- | Compute the free type variables + freeVariables :: a -> [Name] + +instance TypeSubstitution a => TypeSubstitution [a] where + freeVariables = nub . concat . map freeVariables + applySubstitution = fmap . applySubstitution + +instance TypeSubstitution Type where + applySubstitution subst = go + where + go (ForallT tvs context t) = + let (subst', tvs') = substTyVarBndrs subst tvs in + ForallT tvs' + (applySubstitution subst' context) + (applySubstitution subst' t) + go (AppT f x) = AppT (go f) (go x) + go (SigT t k) = SigT (go t) (applySubstitution subst k) -- k could be Kind + go (VarT v) = Map.findWithDefault (VarT v) v subst + go (InfixT l c r) = InfixT (go l) c (go r) + go (UInfixT l c r) = UInfixT (go l) c (go r) + go (ParensT t) = ParensT (go t) +#if MIN_VERSION_template_haskell(2,15,0) + go (AppKindT t k) = AppKindT (go t) (go k) + go (ImplicitParamT n t) + = ImplicitParamT n (go t) +#endif +#if MIN_VERSION_template_haskell(2,16,0) + go (ForallVisT tvs t) = + let (subst', tvs') = substTyVarBndrs subst tvs in + ForallVisT tvs' + (applySubstitution subst' t) +#endif +#if MIN_VERSION_template_haskell(2,19,0) + go (PromotedInfixT l c r) + = PromotedInfixT (go l) c (go r) + go (PromotedUInfixT l c r) + = PromotedUInfixT (go l) c (go r) +#endif + go t = t + + subst_tvbs :: [TyVarBndr_ flag] -> (Map Name Type -> a) -> a + subst_tvbs tvs k = k $ foldl' (flip Map.delete) subst (map tvName tvs) + + freeVariables t = + case t of + ForallT tvs context t' -> + fvs_under_forall tvs (freeVariables context `union` freeVariables t') + AppT f x -> freeVariables f `union` freeVariables x + SigT t' k -> freeVariables t' `union` freeVariables k + VarT v -> [v] + InfixT l _ r -> freeVariables l `union` freeVariables r + UInfixT l _ r -> freeVariables l `union` freeVariables r + ParensT t' -> freeVariables t' +#if MIN_VERSION_template_haskell(2,15,0) + AppKindT t k -> freeVariables t `union` freeVariables k + ImplicitParamT _ t + -> freeVariables t +#endif +#if MIN_VERSION_template_haskell(2,16,0) + ForallVisT tvs t' + -> fvs_under_forall tvs (freeVariables t') +#endif +#if MIN_VERSION_template_haskell(2,19,0) + PromotedInfixT l _ r + -> freeVariables l `union` freeVariables r + PromotedUInfixT l _ r + -> freeVariables l `union` freeVariables r +#endif + _ -> [] + where + fvs_under_forall :: [TyVarBndr_ flag] -> [Name] -> [Name] + fvs_under_forall tvs fvs = + (freeVariables (map tvKind tvs) `union` fvs) + \\ map tvName tvs + +instance TypeSubstitution ConstructorInfo where + freeVariables ci = + (freeVariables (map tvKind (constructorVars ci)) + `union` freeVariables (constructorContext ci) + `union` freeVariables (constructorFields ci)) + \\ (tvName <$> constructorVars ci) + + applySubstitution subst ci = + let subst' = foldl' (flip Map.delete) subst (map tvName (constructorVars ci)) in + ci { constructorVars = map (mapTVKind (applySubstitution subst')) + (constructorVars ci) + , constructorContext = applySubstitution subst' (constructorContext ci) + , constructorFields = applySubstitution subst' (constructorFields ci) + } + +-- | Substitutes into the kinds of type variable binders. This makes an effort +-- to avoid capturing the 'TyVarBndr' names during substitution by +-- alpha-renaming names if absolutely necessary. For a version of this function +-- which does /not/ avoid capture, see 'substTyVarBndrKinds'. +substTyVarBndrs :: Map Name Type -> [TyVarBndr_ flag] -> (Map Name Type, [TyVarBndr_ flag]) +substTyVarBndrs = mapAccumL substTyVarBndr + +-- | The workhorse for 'substTyVarBndrs'. +substTyVarBndr :: Map Name Type -> TyVarBndr_ flag -> (Map Name Type, TyVarBndr_ flag) +substTyVarBndr subst tvb + | tvbName `Map.member` subst + = (Map.delete tvbName subst, mapTVKind (applySubstitution subst) tvb) + | tvbName `Set.notMember` substRangeFVs + = (subst, mapTVKind (applySubstitution subst) tvb) + | otherwise + = let tvbName' = evade tvbName in + ( Map.insert tvbName (VarT tvbName') subst + , mapTV (\_ -> tvbName') id (applySubstitution subst) tvb + ) + where + tvbName :: Name + tvbName = tvName tvb + + substRangeFVs :: Set Name + substRangeFVs = Set.fromList $ freeVariables $ Map.elems subst + + evade :: Name -> Name + evade n | n `Set.member` substRangeFVs + = evade $ bump n + | otherwise + = n + + -- An improvement would be to try a variety of different characters instead + -- of prepending the same character repeatedly. Let's wait to see if + -- someone complains about this before making this more complicated, + -- however. + bump :: Name -> Name + bump n = mkName $ 'f':nameBase n + +-- | Substitutes into the kinds of type variable binders. This is slightly more +-- efficient than 'substTyVarBndrs', but at the expense of not avoiding +-- capture. Only use this function in situations where you know that none of +-- the 'TyVarBndr' names are contained in the range of the substitution. +substTyVarBndrKinds :: Map Name Type -> [TyVarBndr_ flag] -> [TyVarBndr_ flag] +substTyVarBndrKinds subst = map (substTyVarBndrKind subst) + +-- | The workhorse for 'substTyVarBndrKinds'. +substTyVarBndrKind :: Map Name Type -> TyVarBndr_ flag -> TyVarBndr_ flag +substTyVarBndrKind subst = mapTVKind (applySubstitution subst) + +------------------------------------------------------------------------ + +combineSubstitutions :: Map Name Type -> Map Name Type -> Map Name Type +combineSubstitutions x y = Map.union (fmap (applySubstitution y) x) y + +-- | Compute the type variable substitution that unifies a list of types, +-- or fail in 'Q'. +-- +-- All infix issue should be resolved before using 'unifyTypes' +-- +-- Alpha equivalent quantified types are not unified. +unifyTypes :: [Type] -> Q (Map Name Type) +unifyTypes [] = return Map.empty +unifyTypes (t:ts) = + do t':ts' <- mapM resolveTypeSynonyms (t:ts) + let aux sub u = + do sub' <- unify' (applySubstitution sub t') + (applySubstitution sub u) + return (combineSubstitutions sub sub') + + case foldM aux Map.empty ts' of + Right m -> return m + Left (x,y) -> + fail $ showString "Unable to unify types " + . showsPrec 11 x + . showString " and " + . showsPrec 11 y + $ "" + +unify' :: Type -> Type -> Either (Type,Type) (Map Name Type) + +unify' (VarT n) (VarT m) | n == m = pure Map.empty +unify' (VarT n) t | n `elem` freeVariables t = Left (VarT n, t) + | otherwise = Right (Map.singleton n t) +unify' t (VarT n) | n `elem` freeVariables t = Left (VarT n, t) + | otherwise = Right (Map.singleton n t) + +unify' (AppT f1 x1) (AppT f2 x2) = + do sub1 <- unify' f1 f2 + sub2 <- unify' (applySubstitution sub1 x1) (applySubstitution sub1 x2) + Right (combineSubstitutions sub1 sub2) + +-- Doesn't unify kind signatures +unify' (SigT t _) u = unify' t u +unify' t (SigT u _) = unify' t u + +-- only non-recursive cases should remain at this point +unify' t u + | t == u = Right Map.empty + | otherwise = Left (t,u) + + +-- | Construct an equality constraint. The implementation of 'Pred' varies +-- across versions of Template Haskell. +equalPred :: Type -> Type -> Pred +equalPred x y = AppT (AppT EqualityT x) y + +-- | Construct a typeclass constraint. The implementation of 'Pred' varies +-- across versions of Template Haskell. +classPred :: Name {- ^ class -} -> [Type] {- ^ parameters -} -> Pred +classPred = foldl AppT . ConT + +-- | Match a 'Pred' representing an equality constraint. Returns +-- arguments to the equality constraint if successful. +asEqualPred :: Pred -> Maybe (Type,Type) +asEqualPred (EqualityT `AppT` x `AppT` y) = Just (x,y) +asEqualPred (ConT eq `AppT` x `AppT` y) | eq == eqTypeName = Just (x,y) +asEqualPred _ = Nothing + +-- | Match a 'Pred' representing a class constraint. +-- Returns the classname and parameters if successful. +asClassPred :: Pred -> Maybe (Name, [Type]) +asClassPred t = + case decomposeType t of + ConT f :| xs | f /= eqTypeName -> Just (f,xs) + _ -> Nothing + +------------------------------------------------------------------------ + +-- | 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 +-- manually on any reified type variable binders without a signature. However, +-- don't do this for quoted type variable binders (#84). + +giveDIVarsStarKinds :: IsReifiedDec -> DatatypeInfo -> DatatypeInfo +giveDIVarsStarKinds isReified info = + info { datatypeVars = map (giveTyVarBndrStarKind isReified) (datatypeVars info) + , datatypeInstTypes = map (giveTypeStarKind isReified) (datatypeInstTypes info) } + +giveCIVarsStarKinds :: IsReifiedDec -> ConstructorInfo -> ConstructorInfo +giveCIVarsStarKinds isReified info = + info { constructorVars = map (giveTyVarBndrStarKind isReified) (constructorVars info) } + +giveTyVarBndrStarKind :: IsReifiedDec -> TyVarBndrUnit -> TyVarBndrUnit +giveTyVarBndrStarKind isReified tvb + | isReified + = elimTV (\n -> kindedTV n starK) (\_ _ -> tvb) tvb + | otherwise + = tvb + +giveTypeStarKind :: IsReifiedDec -> Type -> Type +giveTypeStarKind isReified t + | isReified + = case t of + VarT n -> SigT t starK + _ -> t + | otherwise + = t + +-- | 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. +-- +-- The particular problem is that the type variables used in the patterns +-- while defining a data family instance do not completely match those +-- used when defining the fields of the value constructors beyond the +-- base names. This code attempts to recover the relationship between the +-- type variables. +-- +-- It is possible, however, to generate these kinds of declarations by +-- means other than reify. In these cases the name bases might not be +-- unique and the declarations might be well formed. In such a case this +-- code attempts to avoid altering the declaration. +-- +-- https://ghc.haskell.org/trac/ghc/ticket/13618 +repair13618 :: DatatypeInfo -> Q DatatypeInfo +repair13618 info = + do s <- T.sequence (Map.fromList substList) + return info { datatypeCons = applySubstitution s (datatypeCons info) } + + where + used = freeVariables (datatypeCons info) + bound = map tvName (datatypeVars info) + free = used \\ bound + + substList = + [ (u, substEntry u vs) + | u <- free + , let vs = [v | v <- bound, nameBase v == nameBase u] + ] + + substEntry _ [v] = varT v + substEntry u [] = fail ("Impossible free variable: " ++ show u) + substEntry u _ = fail ("Ambiguous free variable: " ++ show u) + +------------------------------------------------------------------------ + +-- | Backward compatible version of 'dataD' +dataDCompat :: + CxtQ {- ^ context -} -> + Name {- ^ type constructor -} -> + [TyVarBndrVis] {- ^ type parameters -} -> + [ConQ] {- ^ constructor definitions -} -> + [Name] {- ^ derived class names -} -> + DecQ +#if MIN_VERSION_template_haskell(2,12,0) +dataDCompat c n ts cs ds = + dataD c n ts Nothing cs + (if null ds then [] else [derivClause Nothing (map conT ds)]) +#else +dataDCompat c n ts cs ds = + dataD c n ts Nothing cs + (return (map ConT ds)) +#endif + +-- | Backward compatible version of 'newtypeD' +newtypeDCompat :: + CxtQ {- ^ context -} -> + Name {- ^ type constructor -} -> + [TyVarBndrVis] {- ^ type parameters -} -> + ConQ {- ^ constructor definition -} -> + [Name] {- ^ derived class names -} -> + DecQ +#if MIN_VERSION_template_haskell(2,12,0) +newtypeDCompat c n ts cs ds = + newtypeD c n ts Nothing cs + (if null ds then [] else [derivClause Nothing (map conT ds)]) +#else +newtypeDCompat c n ts cs ds = + newtypeD c n ts Nothing cs + (return (map ConT ds)) +#endif + +-- | Backward compatible version of 'tySynInstD' +tySynInstDCompat :: + Name {- ^ type family name -} -> + Maybe [Q TyVarBndrUnit] {- ^ type variable binders -} -> + [TypeQ] {- ^ instance parameters -} -> + TypeQ {- ^ instance result -} -> + DecQ +#if MIN_VERSION_template_haskell(2,15,0) +tySynInstDCompat n mtvbs ps r = TySynInstD <$> (TySynEqn <$> mapM sequence mtvbs + <*> foldl' appT (conT n) ps + <*> r) +#else +tySynInstDCompat n _ ps r = TySynInstD n <$> (TySynEqn <$> sequence ps <*> r) +#endif + +-- | Backward compatible version of 'pragLineD'. Returns +-- 'Nothing' if line pragmas are not suported. +pragLineDCompat :: + Int {- ^ line number -} -> + String {- ^ file name -} -> + Maybe DecQ +pragLineDCompat ln fn = Just (pragLineD ln fn) + +arrowKCompat :: Kind -> Kind -> Kind +arrowKCompat x y = arrowK `appK` x `appK` y + +------------------------------------------------------------------------ + +-- | 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) +reifyFixityCompat n = recover (return Nothing) ((`mplus` Just defaultFixity) <$> reifyFixity n) -- | Call 'reify' and return @'Just' info@ if successful or 'Nothing' if -- reification failed. 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,8 +1,9 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskellQuotes #-} #if MIN_VERSION_template_haskell(2,12,0) {-# Language Safe #-} -#elif __GLASGOW_HASKELL__ >= 702 +#else {-# Language Trustworthy #-} #endif @@ -20,13 +21,13 @@ import Language.Haskell.TH.Syntax +#if MIN_VERSION_base(4,13,0) +import Data.Type.Equality +#endif + eqTypeName :: Name -#if MIN_VERSION_base(4,9,0) && !(MIN_VERSION_base(4,13,0)) -eqTypeName = mkNameG_tc "base" "Data.Type.Equality" "~" +#if MIN_VERSION_base(4,13,0) +eqTypeName = ''(~) #else -eqTypeName = mkNameG_tc "ghc-prim" "GHC.Types" "~" +eqTypeName = mkNameG_tc "base" "Data.Type.Equality" "~" #endif - --- This is only needed for GHC 7.6-specific bug -starKindName :: Name -starKindName = mkNameG_tc "ghc-prim" "GHC.Prim" "*" diff --git a/src/Language/Haskell/TH/Datatype/TyVarBndr.hs b/src/Language/Haskell/TH/Datatype/TyVarBndr.hs --- a/src/Language/Haskell/TH/Datatype/TyVarBndr.hs +++ b/src/Language/Haskell/TH/Datatype/TyVarBndr.hs @@ -1,21 +1,11 @@ -{-# Language CPP, DeriveDataTypeable #-} - -#if MIN_VERSION_base(4,4,0) -#define HAS_GENERICS -{-# Language DeriveGeneric #-} -#endif +{-# Language CPP, DeriveDataTypeable, DeriveGeneric, DeriveLift, PatternSynonyms, ViewPatterns #-} #if MIN_VERSION_template_haskell(2,12,0) {-# Language Safe #-} -#elif __GLASGOW_HASKELL__ >= 702 +#else {-# Language Trustworthy #-} #endif -#if __GLASGOW_HASKELL__ >= 800 -#define HAS_TH_LIFT -{-# Language DeriveLift #-} -#endif - {-| Module : Language.Haskell.TH.Datatype.TyVarBndr Description : Backwards-compatible type variable binders @@ -33,7 +23,16 @@ TyVarBndr_ , TyVarBndrUnit , TyVarBndrSpec + , TyVarBndrVis , Specificity(..) +#if __GLASGOW_HASKELL__ >= 907 + , BndrVis(..) +#else + , BndrVis + , pattern BndrReq + , pattern BndrInvis +#endif + , DefaultBndrFlag(..) -- * Constructing @TyVarBndr@s -- ** @flag@-polymorphic @@ -47,13 +46,23 @@ , plainTVSpecified , kindedTVInferred , kindedTVSpecified + -- ** @TyVarBndrVis@ + , plainTVReq + , plainTVInvis + , kindedTVReq + , kindedTVInvis -- * Constructing @Specificity@ , inferredSpec , specifiedSpec + -- * Constructing @BndrVis@ + , bndrReq + , bndrInvis + -- * Modifying @TyVarBndr@s , elimTV + , elimTVFlag , mapTV , mapTVName , mapTVFlag @@ -71,47 +80,39 @@ -- * Properties of @TyVarBndr@s , tvName , tvKind + , tvFlag ) where import Control.Applicative import Control.Monad -import Data.Data (Typeable, Data) +import Data.Data (Data) +import GHC.Generics (Generic) import Language.Haskell.TH.Lib import Language.Haskell.TH.Syntax -#ifdef HAS_GENERICS -import GHC.Generics (Generic) -#endif - -- | A type synonym for 'TyVarBndr'. This is the recommended way to refer to -- 'TyVarBndr's if you wish to achieve backwards compatibility with older -- versions of @template-haskell@, where 'TyVarBndr' lacked a @flag@ type --- parameter representing its specificity (if it has one). +-- parameter (if it has one). #if MIN_VERSION_template_haskell(2,17,0) type TyVarBndr_ flag = TyVarBndr flag #else type TyVarBndr_ flag = TyVarBndr --- | A 'TyVarBndr' where the specificity is irrelevant. This is used for --- 'TyVarBndr's that do not interact with visible type application. +-- | A 'TyVarBndr' without a flag. This is used for 'TyVarBndr's that do not +-- interact with visible type application and are not binders for type-level +-- declarations. type TyVarBndrUnit = TyVarBndr --- | A 'TyVarBndr' with an explicit 'Specificity'. This is used for --- 'TyVarBndr's that interact with visible type application. +-- | A 'TyVarBndr' with a 'Specificity' flag. This is used for 'TyVarBndr's that +-- interact with visible type application. type TyVarBndrSpec = TyVarBndr -- | Determines how a 'TyVarBndr' interacts with visible type application. data Specificity = SpecifiedSpec -- ^ @a@. Eligible for visible type application. | InferredSpec -- ^ @{a}@. Not eligible for visible type application. - deriving (Show, Eq, Ord, Typeable, Data -#ifdef HAS_GENERICS - ,Generic -#endif -#ifdef HAS_TH_LIFT - ,Lift -#endif - ) + deriving (Show, Eq, Ord, Data, Generic, Lift) inferredSpec :: Specificity inferredSpec = InferredSpec @@ -120,6 +121,75 @@ specifiedSpec = SpecifiedSpec #endif +#if !MIN_VERSION_template_haskell(2,21,0) +-- | A 'TyVarBndr' with a 'BndrVis' flag. This is used for 'TyVarBndr's in +-- type-level declarations (e.g., the binders in @data D \@k (a :: k)@). +type TyVarBndrVis = TyVarBndr_ BndrVis + +-- | Because pre-9.8 GHCs do not support invisible binders in type-level +-- declarations, we simply make 'BndrVis' an alias for @()@ as a compatibility +-- shim for old GHCs. This matches how type-level 'TyVarBndr's were flagged +-- prior to GHC 9.8. +type BndrVis = () +#if __GLASGOW_HASKELL__ >= 802 +{-# COMPLETE BndrReq, BndrInvis #-} +#endif + +-- | Because pre-9.8 GHCs do not support invisible binders in type-level +-- declarations, we simply make 'BndrReq' a pattern synonym for @()@ as a +-- compatibility shim for old GHCs. This matches how type-level 'TyVarBndr's +-- were flagged prior to GHC 9.8. +pattern BndrReq :: BndrVis +pattern BndrReq = () + +-- | Because pre-9.8 GHCs do not support invisible binders in type-level +-- declarations, this compatibility shim is defined in a somewhat unusual way: +-- +-- * As a pattern, 'BndrInvis' will never match on pre-9.8 GHCs. That way, if +-- you write pattern matches like this: +-- +-- @ +-- case flag of +-- 'BndrInvis' -> ... +-- 'BndrVis' -> ... +-- @ +-- +-- Then the first branch will never be taken on pre-9.8 GHCs. +-- +-- * 'BndrInvis' is a unidirectional pattern synonym on pre-9.8 GHCs, so it +-- cannot be used as an expression on these GHC versions. This is done in an +-- effort to avoid pitfalls that could occur if 'BndrInvis' were defined like +-- so: +-- +-- @ +-- pattern 'BndrInvis' = () +-- @ +-- +-- If this were the definition, then a user could write code involving +-- 'BndrInvis' that would construct an invisible type-level binder on GHC 9.8 +-- or later, but a /visible/ type-level binder on older GHCs! This would be +-- disastrous, so we prevent the user from doing such a thing. +pattern BndrInvis :: BndrVis +pattern BndrInvis <- ((\() -> True) -> False) + +bndrReq :: BndrVis +bndrReq = () + +bndrInvis :: BndrVis +bndrInvis = () + +-- | A class characterizing reasonable default values for various 'TyVarBndr' +-- @flag@ types. +class DefaultBndrFlag flag where + defaultBndrFlag :: flag + +instance DefaultBndrFlag () where + defaultBndrFlag = () + +instance DefaultBndrFlag Specificity where + defaultBndrFlag = SpecifiedSpec +#endif + -- | Construct a 'PlainTV' with the given @flag@. plainTVFlag :: Name -> flag -> TyVarBndr_ flag #if MIN_VERSION_template_haskell(2,17,0) @@ -136,6 +206,14 @@ plainTVSpecified :: Name -> TyVarBndrSpec plainTVSpecified n = plainTVFlag n SpecifiedSpec +-- | Construct a 'PlainTV' with a 'BndrReq'. +plainTVReq :: Name -> TyVarBndrVis +plainTVReq n = plainTVFlag n bndrReq + +-- | Construct a 'PlainTV' with a 'BndrInvis'. +plainTVInvis :: Name -> TyVarBndrVis +plainTVInvis n = plainTVFlag n bndrInvis + -- | Construct a 'KindedTV' with the given @flag@. kindedTVFlag :: Name -> flag -> Kind -> TyVarBndr_ flag #if MIN_VERSION_template_haskell(2,17,0) @@ -152,6 +230,14 @@ kindedTVSpecified :: Name -> Kind -> TyVarBndrSpec kindedTVSpecified n k = kindedTVFlag n SpecifiedSpec k +-- | Construct a 'KindedTV' with a 'BndrReq'. +kindedTVReq :: Name -> Kind -> TyVarBndrVis +kindedTVReq n k = kindedTVFlag n bndrReq k + +-- | Construct a 'KindedTV' with a 'BndrInvis'. +kindedTVInvis :: Name -> Kind -> TyVarBndrVis +kindedTVInvis n k = kindedTVFlag n bndrInvis k + -- | Case analysis for a 'TyVarBndr'. If the value is a @'PlainTV' n _@, apply -- the first function to @n@; if it is @'KindedTV' n _ k@, apply the second -- function to @n@ and @k@. @@ -164,6 +250,20 @@ elimTV _ptv ktv (KindedTV n k) = ktv n k #endif +-- | Case analysis for a 'TyVarBndr' that includes @flag@s in the continuation +-- arguments. Note that 'TyVarBndr's did not include @flag@s prior to +-- @template-haskell-2.17.0.0@, so on older versions of @template-haskell@, +-- these @flag@s instead become @()@. +#if MIN_VERSION_template_haskell(2,17,0) +elimTVFlag :: (Name -> flag -> r) -> (Name -> flag -> Kind -> r) -> TyVarBndr_ flag -> r +elimTVFlag ptv _ktv (PlainTV n flag) = ptv n flag +elimTVFlag _ptv ktv (KindedTV n flag k) = ktv n flag k +#else +elimTVFlag :: (Name -> () -> r) -> (Name -> () -> Kind -> r) -> TyVarBndr_ flag -> r +elimTVFlag ptv _ktv (PlainTV n) = ptv n () +elimTVFlag _ptv ktv (KindedTV n k) = ktv n () k +#endif + -- | Map over the components of a 'TyVarBndr'. mapTV :: (Name -> Name) -> (flag -> flag') -> (Kind -> Kind) -> TyVarBndr_ flag -> TyVarBndr_ flag' @@ -354,3 +454,14 @@ -- | Extract the kind from a 'TyVarBndr'. Assumes 'PlainTV' has kind @*@. tvKind :: TyVarBndr_ flag -> Kind tvKind = elimTV (\_ -> starK) (\_ k -> k) + +-- | Extract the @flag@ from a 'TyVarBndr'. Note that 'TyVarBndr's did not +-- include @flag@s prior to @template-haskell-2.17.0.0@, so on older versions of +-- @template-haskell@, this functions instead returns @()@. +#if MIN_VERSION_template_haskell(2,17,0) +tvFlag :: TyVarBndr_ flag -> flag +tvFlag = elimTVFlag (\_ flag -> flag) (\_ flag _ -> flag) +#else +tvFlag :: TyVarBndr_ flag -> () +tvFlag _ = () +#endif diff --git a/test/Harness.hs b/test/Harness.hs --- a/test/Harness.hs +++ b/test/Harness.hs @@ -16,9 +16,6 @@ ( validateDI , validateCI , equateCxt - - -- * Utilities - , varKCompat ) where import Control.Monad @@ -47,11 +44,15 @@ check "datatypeVars len" (length . datatypeVars) dat1 dat2 check "datatypeInstTypes len" (length . datatypeInstTypes) dat1 dat2 check "datatypeVariant" datatypeVariant dat1 dat2 - check "datatypeCons len" (length . datatypeCons) dat1 dat2 - let sub = Map.fromList (zip (freeVariables (bndrParams (datatypeVars dat2))) (map VarT (freeVariables (bndrParams (datatypeVars dat1))))) + check "datatypeReturnKind" + id + (datatypeReturnKind dat1) + (applySubstitution sub $ datatypeReturnKind dat2) + check "datatypeCons len" (length . datatypeCons) dat1 dat2 + check "datatypeVars" id (datatypeVars dat1) (substIntoTyVarBndrs sub (datatypeVars dat2)) @@ -128,29 +129,9 @@ 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 "constructorStrictness" id fs1 fs2 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,7 +1,7 @@ -{-# Language CPP, FlexibleContexts, TypeFamilies, KindSignatures, TemplateHaskell, GADTs #-} +{-# Language CPP, FlexibleContexts, TypeFamilies, KindSignatures, TemplateHaskell, GADTs, RankNTypes, MagicHash, ConstraintKinds, PolyKinds #-} -#if __GLASGOW_HASKELL__ >= 704 -{-# LANGUAGE ConstraintKinds #-} +#if __GLASGOW_HASKELL__ < 806 +{-# Language TypeInType #-} #endif #if __GLASGOW_HASKELL__ >= 807 @@ -9,10 +9,17 @@ {-# LANGUAGE TypeApplications #-} #endif -#if MIN_VERSION_template_haskell(2,8,0) -{-# Language PolyKinds #-} +#if MIN_VERSION_template_haskell(2,21,0) +{-# Language TypeAbstractions #-} #endif +#if MIN_VERSION_template_haskell(2,18,0) +{-# LANGUAGE UnliftedDatatypes #-} +#endif + +-- We should aim to enable -Wincomplete-uni-patterns long-term. See #121. +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + {-| Module : Main Description : Test cases for the th-abstraction package @@ -27,18 +34,22 @@ -} module Main (main) where -#if __GLASGOW_HASKELL__ >= 704 -import Control.Monad (zipWithM_) -#endif - -import Control.Monad (unless, when) +import Control.Monad (unless, when, zipWithM_) import qualified Data.Map as Map - -#if MIN_VERSION_base(4,7,0) +import Data.Kind import Data.Type.Equality ((:~:)(..)) + +#if __GLASGOW_HASKELL__ >= 810 +import GHC.Exts (Any, RuntimeRep(..), TYPE) #endif +#if __GLASGOW_HASKELL__ >= 902 +import GHC.Exts (UnliftedType, Levity(..)) +#endif -import Language.Haskell.TH +import GHC.Exts (Array#) + +import qualified Language.Haskell.TH as TH (Type) +import Language.Haskell.TH hiding (Type) import Language.Haskell.TH.Datatype as Datatype import Language.Haskell.TH.Datatype.TyVarBndr import Language.Haskell.TH.Lib (starK) @@ -59,11 +70,8 @@ voidstosTest strictDemoTest recordVanillaTest -#if MIN_VERSION_template_haskell(2,6,0) t43Test t58Test -#endif -#if MIN_VERSION_template_haskell(2,7,0) dataFamilyTest ghc78bugTest quotedTest @@ -75,33 +83,22 @@ t46Test t73Test t95Test -#endif fixityLookupTest -#if __GLASGOW_HASKELL__ >= 704 resolvePredSynonymsTest -#endif reifyDatatypeWithConNameTest reifyConstructorTest -#if MIN_VERSION_base(4,7,0) importedEqualityTest -#endif -#if MIN_VERSION_template_haskell(2,8,0) kindSubstTest t59Test t61Test t66Test t80Test -#endif -#if MIN_VERSION_template_haskell(2,11,0) t79TestA -#endif #if MIN_VERSION_template_haskell(2,19,0) t79TestB #endif -#if __GLASGOW_HASKELL__ >= 800 t37Test polyKindedExTyvarTest -#endif #if __GLASGOW_HASKELL__ >= 807 resolveTypeSynonymsVKATest #endif @@ -113,7 +110,25 @@ #if MIN_VERSION_template_haskell(2,20,0) t100Test #endif +#if MIN_VERSION_template_haskell(2,21,0) + t103Test +#endif +#if __GLASGOW_HASKELL__ >= 810 + t107Test + t108Test +#endif +#if __GLASGOW_HASKELL__ >= 804 + t110Test +#endif +#if MIN_VERSION_template_haskell(2,16,0) + unboxedTupleTest +#endif +#if MIN_VERSION_template_haskell(2,18,0) + unliftedGADTDecTest +#endif + primTyConTest + adt1Test :: IO () adt1Test = $(do info <- reifyDatatype ''Adt1 @@ -130,6 +145,7 @@ , datatypeVars = [aTvb,bTvb] , datatypeInstTypes = [aSig, bSig] , datatypeVariant = Datatype + , datatypeReturnKind = starK , datatypeCons = [ ConstructorInfo { constructorName = 'Adtc1 @@ -163,6 +179,7 @@ , datatypeVars = [kindedTV a starK] , datatypeInstTypes = [SigT aVar starK] , datatypeVariant = Datatype + , datatypeReturnKind = starK , datatypeCons = [ ConstructorInfo { constructorName = 'Gadtc1 @@ -210,6 +227,7 @@ , datatypeVars = [kindedTV a starK] , datatypeInstTypes = [SigT (VarT a) starK] , datatypeVariant = Datatype + , datatypeReturnKind = starK , datatypeCons = [ con, con { constructorName = 'Gadtrecc2 } ] } @@ -231,6 +249,7 @@ , datatypeVars = [aTvb, bTvb, cTvb] , datatypeInstTypes = [aSig, bSig, cSig] , datatypeVariant = Datatype + , datatypeReturnKind = starK , datatypeCons = [ ConstructorInfo { constructorName = 'Equalc @@ -263,6 +282,7 @@ , datatypeVars = [] , datatypeInstTypes = [] , datatypeVariant = Datatype + , datatypeReturnKind = starK , datatypeCons = [ ConstructorInfo { constructorName = 'Showable @@ -285,6 +305,7 @@ , datatypeVars = [] , datatypeInstTypes = [] , datatypeVariant = Datatype + , datatypeReturnKind = starK , datatypeCons = [ ConstructorInfo { constructorName = 'R1 @@ -320,6 +341,7 @@ , datatypeVars = [aTvb, bTvb] , datatypeInstTypes = [aSig, bSig] , datatypeVariant = Datatype + , datatypeReturnKind = starK , datatypeCons = [ con { constructorName = 'Gadt2c1 , constructorContext = [equalPred bVar (AppT ListT aVar)] } @@ -344,6 +366,7 @@ , datatypeVars = [kindedTV g (arrowKCompat starK starK)] , datatypeInstTypes = [SigT (VarT g) (arrowKCompat starK starK)] , datatypeVariant = Datatype + , datatypeReturnKind = starK , datatypeCons = [] } ) @@ -358,6 +381,7 @@ , datatypeVars = [] , datatypeInstTypes = [] , datatypeVariant = Datatype + , datatypeReturnKind = starK , datatypeCons = [ ConstructorInfo { constructorName = 'StrictDemo @@ -377,7 +401,6 @@ $(do info <- reifyRecord 'gadtrec1a validateCI info gadtRecVanillaCI) -#if MIN_VERSION_template_haskell(2,6,0) t43Test :: IO () t43Test = $(do [decPlain] <- [d| data T43Plain where MkT43Plain :: T43Plain |] @@ -389,6 +412,7 @@ , datatypeVars = [] , datatypeInstTypes = [] , datatypeVariant = Datatype + , datatypeReturnKind = starK , datatypeCons = [ ConstructorInfo { constructorName = mkName "MkT43Plain" @@ -408,6 +432,7 @@ , datatypeVars = [] , datatypeInstTypes = [] , datatypeVariant = DataInstance + , datatypeReturnKind = starK , datatypeCons = [ ConstructorInfo { constructorName = mkName "MkT43Fam" @@ -432,6 +457,7 @@ , datatypeVars = [] , datatypeInstTypes = [] , datatypeVariant = Datatype + , datatypeReturnKind = starK , datatypeCons = [ ConstructorInfo { constructorName = mkName "MkFoo" @@ -442,9 +468,7 @@ , constructorVariant = NormalConstructor } ] } ) -#endif -#if MIN_VERSION_template_haskell(2,7,0) dataFamilyTest :: IO () dataFamilyTest = $(do info <- reifyDatatype 'DFMaybe @@ -456,6 +480,7 @@ , datatypeVars = [kindedTV a starK] , datatypeInstTypes = [AppT (ConT ''Maybe) (VarT a)] , datatypeVariant = DataInstance + , datatypeReturnKind = starK , datatypeCons = [ ConstructorInfo { constructorName = 'DFMaybe @@ -479,6 +504,7 @@ , datatypeVars = [kindedTV c starK] , datatypeInstTypes = [SigT cVar starK] , datatypeVariant = DataInstance + , datatypeReturnKind = starK , datatypeCons = [ ConstructorInfo { constructorName = 'DF1 @@ -503,6 +529,7 @@ , datatypeVars = [plainTV a] , datatypeInstTypes = [aVar] , datatypeVariant = DataInstance + , datatypeReturnKind = starK , datatypeCons = [ ConstructorInfo { constructorName = mkName "MkQuoted" @@ -518,18 +545,15 @@ polyTest = $(do info <- reifyDatatype 'MkPoly let [a,k] = map mkName ["a","k"] - kVar = varKCompat k + kVar = VarT k validateDI info DatatypeInfo { datatypeName = ''Poly , datatypeContext = [] - , datatypeVars = [ -#if __GLASGOW_HASKELL__ >= 800 - kindedTV k starK, -#endif - kindedTV a kVar ] + , datatypeVars = [kindedTV k starK, kindedTV a kVar] , datatypeInstTypes = [SigT (VarT a) kVar] , datatypeVariant = DataInstance + , datatypeReturnKind = starK , datatypeCons = [ ConstructorInfo { constructorName = 'MkPoly @@ -555,6 +579,7 @@ , datatypeVars = [cTvb,dTvb] , datatypeInstTypes = [cSig,dSig] , datatypeVariant = DataInstance + , datatypeReturnKind = starK , datatypeCons = [ ConstructorInfo { constructorName = 'MkGadtFam1 @@ -613,6 +638,7 @@ , datatypeVars = [] , datatypeInstTypes = [ConT ''Int] , datatypeVariant = DataInstance + , datatypeReturnKind = starK , datatypeCons = [ ConstructorInfo { constructorName = mkName "FamLocalDec1Int" @@ -638,6 +664,7 @@ , datatypeVars = [aTvb,bTvb] , datatypeInstTypes = [ConT ''Int, TupleT 2 `AppT` aVar `AppT` bVar, aVar] , datatypeVariant = DataInstance + , datatypeReturnKind = starK , datatypeCons = [ ConstructorInfo { constructorName = mkName "FamLocalDec2Int" @@ -676,6 +703,7 @@ , datatypeVars = [bTvb] , datatypeInstTypes = [ConT ''Int, SigT bVar starK] , datatypeVariant = DataInstance + , datatypeReturnKind = starK , datatypeCons = [ ConstructorInfo { constructorName = 'MkT73 @@ -700,6 +728,7 @@ , datatypeVars = [aTvb] , datatypeInstTypes = [AppT ListT aVar] , datatypeVariant = DataInstance + , datatypeReturnKind = starK , datatypeCons = [ ConstructorInfo { constructorName = 'MkT95 @@ -710,14 +739,12 @@ , constructorVariant = NormalConstructor }] } ) -#endif fixityLookupTest :: IO () fixityLookupTest = $(do Just (Fixity 6 InfixR) <- reifyFixityCompat '(:**:) [| return () |]) -#if __GLASGOW_HASKELL__ >= 704 resolvePredSynonymsTest :: IO () resolvePredSynonymsTest = $(do info <- reifyDatatype ''PredSynT @@ -729,7 +756,6 @@ test3 = mkTest cxt3 [equalPred (ConT ''Int) (ConT ''Int)] mapM_ (either fail return) [test1,test2,test3] [| return () |]) -#endif reifyDatatypeWithConNameTest :: IO () reifyDatatypeWithConNameTest = @@ -742,6 +768,7 @@ , datatypeVars = [kindedTV a starK] , datatypeInstTypes = [SigT (VarT a) starK] , datatypeVariant = Datatype + , datatypeReturnKind = starK , datatypeCons = [ ConstructorInfo { constructorName = 'Nothing @@ -761,25 +788,24 @@ $(do info <- reifyConstructor 'Just validateCI info justCI) -#if MIN_VERSION_base(4,7,0) importedEqualityTest :: IO () importedEqualityTest = $(do info <- reifyDatatype ''(:~:) let names@[a,b] = map mkName ["a","b"] [aVar,bVar] = map VarT names k = mkName "k" - kKind = varKCompat k + kKind = VarT k validateDI info DatatypeInfo { datatypeContext = [] , datatypeName = ''(:~:) - , datatypeVars = [ -#if __GLASGOW_HASKELL__ >= 800 - kindedTV k starK, -#endif - kindedTV a kKind, kindedTV b kKind] + , datatypeVars = [ kindedTV k starK + , kindedTV a kKind + , kindedTV b kKind + ] , datatypeInstTypes = [SigT aVar kKind, SigT bVar kKind] , datatypeVariant = Datatype + , datatypeReturnKind = starK , datatypeCons = [ ConstructorInfo { constructorName = 'Refl @@ -790,9 +816,7 @@ , constructorVariant = NormalConstructor } ] } ) -#endif -#if MIN_VERSION_template_haskell(2,8,0) kindSubstTest :: IO () kindSubstTest = $(do k1 <- newName "k1" @@ -801,7 +825,7 @@ let ty = ForallT [kindedTVSpecified a (VarT k1)] [] (VarT a) substTy = applySubstitution (Map.singleton k1 (VarT k2)) ty - checkFreeVars :: Type -> [Name] -> Q () + checkFreeVars :: TH.Type -> [Name] -> Q () checkFreeVars t freeVars = unless (freeVariables t == freeVars) $ fail $ "free variables of " ++ show t ++ " should be " ++ show freeVars @@ -817,11 +841,7 @@ let proxyAK = ConT (mkName "Proxy") `AppT` SigT (VarT a) (VarT k) -- Proxy (a :: k) expected = ForallT -#if __GLASGOW_HASKELL__ >= 800 [plainTVSpecified k, kindedTVSpecified a (VarT k)] -#else - [kindedTVSpecified a (VarT k)] -#endif [] proxyAK actual = quantifyType proxyAK unless (expected == actual) $ @@ -833,7 +853,7 @@ t61Test :: IO () t61Test = - $(do let test :: Type -> Type -> Q () + $(do let test :: TH.Type -> TH.Type -> Q () test orig expected = do actual <- resolveTypeSynonyms orig unless (expected == actual) $ @@ -844,22 +864,18 @@ idAppT = (ConT ''Id `AppT`) a = mkName "a" - test (SigT (idAppT $ ConT ''Int) (idAppT StarT)) - (SigT (ConT ''Int) StarT) -#if MIN_VERSION_template_haskell(2,10,0) - test (ForallT [kindedTVSpecified a (idAppT StarT)] + test (SigT (idAppT $ ConT ''Int) (idAppT starK)) + (SigT (ConT ''Int) starK) + test (ForallT [kindedTVSpecified a (idAppT starK)] [idAppT (ConT ''Show `AppT` VarT a)] (idAppT $ VarT a)) - (ForallT [kindedTVSpecified a StarT] + (ForallT [kindedTVSpecified a starK] [ConT ''Show `AppT` VarT a] (VarT a)) -#endif -#if MIN_VERSION_template_haskell(2,11,0) test (InfixT (idAppT $ ConT ''Int) ''Either (idAppT $ ConT ''Int)) (InfixT (ConT ''Int) ''Either (ConT ''Int)) test (ParensT (idAppT $ ConT ''Int)) (ConT ''Int) -#endif #if MIN_VERSION_template_haskell(2,19,0) test (PromotedInfixT (idAppT $ ConT ''Int) '(:^:) (idAppT $ ConT ''Int)) (PromotedInfixT (ConT ''Int) '(:^:) (ConT ''Int)) @@ -882,6 +898,7 @@ , datatypeInstTypes = [ VarT a, VarT b , SigT (VarT f) fKind, SigT (VarT x) starK ] , datatypeVariant = Datatype + , datatypeReturnKind = starK , datatypeCons = [ ConstructorInfo { constructorName = mkName "MkFoo" @@ -912,9 +929,7 @@ , "Actual: " ++ pprint actual ] return () -#endif -#if MIN_VERSION_template_haskell(2,11,0) t79TestA :: IO () t79TestA = $(do let [a,b,c] = map mkName ["a","b","c"] @@ -930,7 +945,6 @@ , "Actual: " ++ pprint actual ] [| return () |]) -#endif #if MIN_VERSION_template_haskell(2,19,0) t79TestB :: IO () @@ -950,7 +964,6 @@ [| return () |]) #endif -#if __GLASGOW_HASKELL__ >= 800 t37Test :: IO () t37Test = $(do infoA <- reifyDatatype ''T37a @@ -967,6 +980,7 @@ , datatypeVars = [kTvb, aTvb] , datatypeInstTypes = [kSig, aSig] , datatypeVariant = Datatype + , datatypeReturnKind = starK , datatypeCons = [ ConstructorInfo { constructorName = 'MkT37a @@ -985,6 +999,7 @@ , datatypeVars = [kTvb, aTvb] , datatypeInstTypes = [aSig] , datatypeVariant = Datatype + , datatypeReturnKind = starK , datatypeCons = [ ConstructorInfo { constructorName = 'MkT37b @@ -1003,6 +1018,7 @@ , datatypeVars = [kTvb, aTvb] , datatypeInstTypes = [aSig] , datatypeVariant = Datatype + , datatypeReturnKind = starK , datatypeCons = [ ConstructorInfo { constructorName = 'MkT37c @@ -1026,6 +1042,7 @@ , datatypeVars = [kindedTV a starK] , datatypeInstTypes = [SigT aVar starK] , datatypeVariant = Datatype + , datatypeReturnKind = starK , datatypeCons = [ ConstructorInfo { constructorName = 'MkT48 @@ -1047,6 +1064,8 @@ -> unless (a1 == a2) $ fail $ "Two occurrences of the same variable have different names: " ++ show [a1, a2] + _ -> fail $ "Unexpected DatatypeInfo for T48: " + ++ show info [| return () |] ) @@ -1067,7 +1086,6 @@ ++ show (length cs) [| return () |] ) -#endif #if __GLASGOW_HASKELL__ >= 807 resolveTypeSynonymsVKATest :: IO () @@ -1161,6 +1179,7 @@ , datatypeVars = [] , datatypeInstTypes = [] , datatypeVariant = Datatype.TypeData + , datatypeReturnKind = starK , datatypeCons = [ ConstructorInfo { constructorName = ''MkT100 @@ -1179,3 +1198,215 @@ validateDI mkT100Info expectedInfo ) #endif + +#if MIN_VERSION_template_haskell(2,21,0) +t103Test :: IO () +t103Test = + $(do [dec] <- [d| data T102 @k (a :: k) |] + info <- normalizeDec dec + let k = mkName "k" + a = mkName "a" + validateDI info + DatatypeInfo + { datatypeName = mkName "T102" + , datatypeContext = [] + , datatypeVars = [plainTV k, kindedTV a (VarT k)] + , datatypeInstTypes = [SigT (VarT a) (VarT k)] + , datatypeVariant = Datatype + , datatypeReturnKind = starK + , datatypeCons = [] + } + ) +#endif + +#if __GLASGOW_HASKELL__ >= 810 +t107Test :: IO () +t107Test = + $(do info <- reifyDatatype ''T107 + let r = mkName "r" + validateDI info + DatatypeInfo + { datatypeName = mkName "T107" + , datatypeContext = [] + , datatypeVars = [kindedTV r (ConT ''RuntimeRep)] + , datatypeInstTypes = [] + , datatypeVariant = Newtype + , datatypeReturnKind = ConT ''TYPE `AppT` VarT r + , datatypeCons = + [ ConstructorInfo + { constructorName = mkName "MkT107" + , constructorVars = [] + , constructorContext = [] + , constructorFields = [ConT ''Any `SigT` (ConT ''TYPE `AppT` VarT r)] + , constructorStrictness = [notStrictAnnot] + , constructorVariant = NormalConstructor + } + ] + } + ) + +t108Test :: IO () +t108Test = + $(do [dec] <- [d| data T108 :: forall k -> k -> Type where + MkT108 :: forall k (a :: k). T108 k a + |] + info <- normalizeDec dec + let k = mkName "k" + a = mkName "a" + validateDI info + DatatypeInfo + { datatypeName = mkName "T108" + , datatypeContext = [] + , datatypeVars = [plainTV k, kindedTV a (VarT k)] + , datatypeInstTypes = [VarT k, SigT (VarT a) (VarT k)] + , datatypeVariant = Datatype + , datatypeReturnKind = starK + , datatypeCons = + [ ConstructorInfo + { constructorName = mkName "MkT108" + , constructorVars = [] + , constructorContext = [] + , constructorFields = [] + , constructorStrictness = [] + , constructorVariant = NormalConstructor + } + ] + } + ) +#endif + +#if __GLASGOW_HASKELL__ >= 804 +t110Test :: IO () +t110Test = + $(do [dec] <- [d| data T110 :: forall k. k -> Type where + MkT110 :: forall k (a :: k). T110 a + |] + info <- normalizeDec dec + let k = mkName "k" + a = mkName "a" + validateDI info + DatatypeInfo + { datatypeName = mkName "T110" + , datatypeContext = [] + , datatypeVars = [plainTV k, kindedTV a (VarT k)] + , datatypeInstTypes = [SigT (VarT a) (VarT k)] + , datatypeVariant = Datatype + , datatypeReturnKind = starK + , datatypeCons = + [ ConstructorInfo + { constructorName = mkName "MkT110" + , constructorVars = [] + , constructorContext = [] + , constructorFields = [] + , constructorStrictness = [] + , constructorVariant = NormalConstructor + } + ] + } + ) +#endif + +#if MIN_VERSION_template_haskell(2,16,0) +unboxedTupleTest :: IO () +unboxedTupleTest = + $(do k0 <- newName "k0" + k1 <- newName "k1" + a <- newName "a" + b <- newName "b" + tupleInfo <- reifyDatatype (unboxedTupleTypeName 2) + validateDI tupleInfo + DatatypeInfo + { datatypeContext = [] + , datatypeName = unboxedTupleTypeName 2 + , datatypeVars = [kindedTV k0 starK + ,kindedTV a (AppT (ConT ''TYPE) (VarT k0 )) + ,kindedTV k1 starK + ,kindedTV b (AppT (ConT ''TYPE) (VarT k1))] + , datatypeInstTypes = [SigT (VarT a) (AppT (ConT ''TYPE) (VarT k0)) + ,SigT (VarT b) (AppT (ConT ''TYPE) (VarT k1))] + , datatypeVariant = Datatype + , datatypeReturnKind = + AppT + (ConT ''TYPE) + (AppT + (PromotedT 'TupleRep) + (AppT + (AppT PromotedConsT (VarT k0)) + (AppT + (AppT PromotedConsT (VarT k1)) + (SigT PromotedNilT (AppT ListT (ConT ''RuntimeRep)))))) + , datatypeCons = + [ ConstructorInfo + { constructorName = unboxedTupleDataName 2 + , constructorVars = [] + , constructorContext = [] + , constructorFields = [VarT a, VarT b] + , constructorStrictness = [notStrictAnnot, notStrictAnnot] + , constructorVariant = NormalConstructor}] + } + ) +#endif + +#if MIN_VERSION_template_haskell(2,18,0) +unliftedGADTDecTest :: IO () +unliftedGADTDecTest = + $(do a <- newName "a" + s <- newName "s" + [dec] <- [d| data UnliftedGADT a :: UnliftedType where + UnliftedGADT :: Show s => s -> a -> UnliftedGADT a + |] + info <- normalizeDec dec + validateDI info + DatatypeInfo + { datatypeContext = [] + , datatypeName = mkName "UnliftedGADT" + , datatypeVars = [plainTV a] + , datatypeInstTypes = [VarT a] + , datatypeVariant = Datatype + , datatypeReturnKind = ConT ''TYPE `AppT` (PromotedT 'BoxedRep `AppT` PromotedT 'Unlifted) + , datatypeCons = + [ConstructorInfo + {constructorName = mkName "UnliftedGADT" + , constructorVars = [plainTV s] + , constructorContext = [AppT (ConT ''Show) (VarT s)] + , constructorFields = [VarT s,VarT a] + , constructorStrictness = [notStrictAnnot, notStrictAnnot] + , constructorVariant = NormalConstructor} + ] + } + ) +#endif + + +primTyConTest :: IO () +primTyConTest = + $(do l <- newName "l" + a <- newName "a" + info <- reifyDatatype ''Array# + validateDI info + DatatypeInfo + { datatypeContext = [] + , datatypeName = mkName "Array#" +#if MIN_VERSION_template_haskell(2,19,0) + , datatypeVars = [kindedTV l (ConT ''Levity) + , kindedTV a (ConT ''TYPE `AppT` (PromotedT 'BoxedRep `AppT` VarT l)) + ] + , datatypeInstTypes = [SigT (VarT a) (ConT ''TYPE `AppT` (PromotedT 'BoxedRep `AppT` VarT l))] + , datatypeReturnKind = ConT ''TYPE `AppT` (PromotedT 'BoxedRep `AppT` PromotedT 'Unlifted) +#elif MIN_VERSION_template_haskell(2,18,0) + , datatypeVars = [ kindedTV a StarT] + , datatypeInstTypes = [SigT (VarT a) StarT] + , datatypeReturnKind = ConT ''TYPE `AppT` (PromotedT 'BoxedRep `AppT` PromotedT 'Unlifted) +#elif MIN_VERSION_template_haskell(2,16,0) + , datatypeVars = [kindedTV a starK] + , datatypeInstTypes = [SigT (VarT a) starK] + , datatypeReturnKind = ConT ''TYPE `AppT` PromotedT 'UnliftedRep +#else + , datatypeVars = [kindedTV a starK] + , datatypeInstTypes = [SigT (VarT a) starK] + , datatypeReturnKind = starK +#endif + , datatypeVariant = Datatype + , datatypeCons = [] + } + ) diff --git a/test/Types.hs b/test/Types.hs --- a/test/Types.hs +++ b/test/Types.hs @@ -1,24 +1,22 @@ -{-# Language CPP, FlexibleContexts, TypeFamilies, KindSignatures, TemplateHaskell, GADTs, ScopedTypeVariables, TypeOperators #-} - -#if __GLASGOW_HASKELL__ >= 704 -{-# LANGUAGE ConstraintKinds #-} -#endif +{-# Language CPP, FlexibleContexts, TypeFamilies, KindSignatures, TemplateHaskell, GADTs, ScopedTypeVariables, TypeOperators, ConstraintKinds, DataKinds, PolyKinds #-} -#if MIN_VERSION_template_haskell(2,8,0) -{-# Language PolyKinds #-} +#if __GLASGOW_HASKELL__ < 806 +{-# Language TypeInType #-} #endif -#if __GLASGOW_HASKELL__ >= 800 -{-# Language DataKinds #-} -# if __GLASGOW_HASKELL__ < 806 -{-# Language TypeInType #-} -# endif +#if __GLASGOW_HASKELL__ >= 810 +{-# Language StandaloneKindSignatures #-} +{-# Language TypeApplications #-} +{-# Language UnliftedNewtypes #-} #endif #if MIN_VERSION_template_haskell(2,20,0) {-# Language TypeData #-} #endif +-- We should aim to enable -Wincomplete-uni-patterns long-term. See #121. +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + {-| Module : Types Description : Test cases for the th-abstraction package @@ -32,17 +30,17 @@ -} module Types where -#if __GLASGOW_HASKELL__ >= 704 +import Data.Kind + import GHC.Exts (Constraint) -#endif import Language.Haskell.TH hiding (Type) import Language.Haskell.TH.Datatype import Language.Haskell.TH.Datatype.TyVarBndr import Language.Haskell.TH.Lib (starK) -#if __GLASGOW_HASKELL__ >= 800 -import Data.Kind +#if __GLASGOW_HASKELL__ >= 810 +import GHC.Exts (Any, TYPE) #endif type Gadt1Int = Gadt1 Int @@ -85,24 +83,15 @@ type Id (a :: *) = a -#if MIN_VERSION_template_haskell(2,7,0) 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 :: *) @@ -126,9 +115,7 @@ data family T95 :: * -> * data instance T95 [a] = MkT95 a -#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) @@ -138,15 +125,19 @@ PredSyn1 Int Int => MkPredSynT1 Int | PredSyn2 Int Int => MkPredSynT2 Int | PredSyn3 Int => MkPredSynT3 Int -#endif -#if __GLASGOW_HASKELL__ >= 800 data T37a (k :: Type) :: k -> Type where MkT37a :: T37a Bool a +#if __GLASGOW_HASKELL__ >= 810 +type T37b :: k -> Type +#endif data T37b (a :: k) where MkT37b :: forall (a :: Bool). T37b a +#if __GLASGOW_HASKELL__ >= 810 +type T37c :: k -> Type +#endif data T37c (a :: k) where MkT37c :: T37c Bool @@ -157,12 +148,17 @@ data T75 (k :: Type) where MkT75 :: forall k (a :: k). Prox a -> T75 k -#endif #if MIN_VERSION_template_haskell(2,20,0) type data T100 = MkT100 #endif +#if __GLASGOW_HASKELL__ >= 810 +type T107 :: TYPE r +newtype T107 where + MkT107 :: forall r. Any @(TYPE r) -> T107 @r +#endif + -- We must define these here due to Template Haskell staging restrictions justCI :: ConstructorInfo justCI = @@ -190,7 +186,6 @@ 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 @@ -204,4 +199,3 @@ , 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.5.0.0 +version: 0.7.2.0 synopsis: Nicer interface for reified information about data types description: This package normalizes variations in the interface for inspecting datatype information via Template Haskell @@ -17,7 +17,7 @@ build-type: Simple extra-source-files: ChangeLog.md README.md cabal-version: >=1.10 -tested-with: GHC==9.6.1, GHC==9.4.4, GHC==9.2.6, GHC==9.0.2, GHC==8.10.7, GHC==8.8.4, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, 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 +tested-with: GHC==9.14.1, GHC==9.12.2, GHC==9.10.3, GHC==9.8.4, GHC==9.6.7, GHC==9.4.8, GHC==9.2.8, GHC==9.0.2, GHC==8.10.7, GHC==8.8.4, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2 source-repository head type: git @@ -27,10 +27,9 @@ exposed-modules: Language.Haskell.TH.Datatype Language.Haskell.TH.Datatype.TyVarBndr other-modules: Language.Haskell.TH.Datatype.Internal - build-depends: base >=4.3 && <5, - ghc-prim, - template-haskell >=2.5 && <2.21, - containers >=0.4 && <0.7 + build-depends: base >=4.9 && <5, + template-haskell >=2.11 && <2.25, + containers >=0.4 && <0.9 hs-source-dirs: src default-language: Haskell2010