th-abstraction-0.5.0.0/0000755000000000000000000000000007346545000012765 5ustar0000000000000000th-abstraction-0.5.0.0/ChangeLog.md0000644000000000000000000002027707346545000015146 0ustar0000000000000000# Revision history for th-abstraction ## 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 represent `type data` declarations. * Add a `Lift` instance for `th-abstraction`'s compatibility shim for `Specificity` when building with pre-9.0 versions of GHC. ## 0.4.5.0 -- 2022.09.12 * Fix a bug in which data family declarations with interesting return kinds (e.g., `data family F :: Type -> Type`) would be reified incorrectly when using `reifyDatatype`. ## 0.4.4.0 -- 2022.07.23 * Support free variable substitution and infix resolution for `PromotedInfixT` and `PromotedUInfixT` on `template-haskell-2.19.0.0` or later. ## 0.4.3.0 -- 2021.08.30 * Make `applySubstitution` avoid capturing type variable binders when substituting into `forall`s. * Fix a bug in which `resolveTypeSynonyms` would incorrectly expand type synonyms that are not applied to enough arguments. * Allow the test suite to build with GHC 9.2. ## 0.4.2.0 -- 2020-12-30 * Explicitly mark modules as Safe (or Trustworthy for GHC versions prior to 8.4). ## 0.4.1.0 -- 2020-12-09 * Fix a bug in which `normalizeDec` would give incorrect kind annotations to type variables in quoted `Dec`s. `normalizeDec` now leaves the kinds of type variable binders alone. ## 0.4.0.0 -- 2020-09-29 * Adapt to the `TyVarBndr` data type gaining a new `flag` type parameter (in `template-haskell-2.17.0.0`) to represent its specificity: * Introduce a new `Language.Haskell.TH.Datatype.TyVarBndr` module that defines `TyVarBndr_`, a backwards-compatible type synonym for `TyVarBndr`, as well as backporting `TyVarBndrSpec`, `TyVarBndrUnit`, and `Specificity`. This module also defines other useful functions for constructing and manipulating `TyVarBndr`s. * The types in `Language.Haskell.TH.Datatype` now use `TyVarBndr_`, `TyVarBndrUnit`, and `TyVarBndrSpec` where appropriate. Technically, this is not a breaking change, since all three are simple type synonyms around `TyVarBndr`, but it is likely that you will need to update your `th-abstraction`-using code anyway if it involves a `TyVarBndr`-consuming function. ## 0.3.2.0 -- 2020-02-06 * Support substituting into and extracting free variables from `ForallVisT`s on `template-haskell-2.16.0.0` (GHC 8.10) or later. * Fix a bug in which `freeVariables` could report duplicate kind variables when they occur in the kinds of the type variable binders in a `ForallT`. * Fix a bug in which `resolveInfixT` would not resolve `UInfixT`s occurring in the kinds of type variable binders in a `ForallT`. * Fix a bug in which the `TypeSubstitution ConstructorInfo` instance would not detect free kind variables in the `constructorVars`. ## 0.3.1.0 -- 2019-04-28 * Fix a bug which would cause data family information to be reified incorrectly with GHC 8.8+ in some situations. ## 0.3.0.0 -- 2019-04-26 * Breaking change: the `datatypeVars` field of `DatatypeInfo` is now of type `[TyVarBndr]` instead of `[Type]`, as it now refers to all of the bound type variables in the data type. The old `datatypeVars` field has been renamed to `datatypeInstTypes` to better reflect its purpose. In addition, the type of `normalizeCon` now has an additional `[TyVarBndr]` argument, since `DatatypeInfo` now requires it. * Support `template-haskell-2.15`. * Fix a bug in which `normalizeDec` would not detect existential type variables in a GADT constructor if they were implicitly quantified. * Fix a bug in which `normalizeDec` would report an incorrect number of `datatypeVars` for GADT declarations with explicit return kinds (such as `data Foo :: * -> * where`). ## 0.2.11.0 -- 2019-02-26 * Fix a bug in which `freeVariablesWellScoped` would sometimes not preserve the left-to-right ordering of `Name`s generated with `newName`. ## 0.2.10.0 -- 2018-12-20 * Optimization: `quantifyType` now collapses consecutive `forall`s. For instance, calling `quantifyType` on `forall b. a -> b -> T a` now produces `forall a b. a -> b -> T a` instead of `forall a. forall b. a -> b -> T a`. ## 0.2.9.0 -- 2018-12-20 * Fix a bug in which `resolveTypeSynonyms` would not look into `ForallT`s, `SigT`s, `InfixT`s, or `ParensT`s. * Fix a bug in which `quantifyType` would not respect the dependency order of type variables (e.g., `Proxy (a :: k)` would have erroneously been quantified as `forall a k. Proxy (a :: k)`). * Fix a bug in which `asEqualPred` would return incorrect results with GHC 8.7. * Add a `freeVariablesWellScoped` function which computes the free variables of a list of types and sorts them according to dependency order. * Add a `resolveKindSynonyms` function which expands all type synonyms in a `Kind`. This is mostly useful for supporting old GHCs where `Type` and `Kind` were not the same. ## 0.2.8.0 -- 2018-06-29 * GADT reification is now much more robust with respect to `PolyKinds`: * A bug in which universally quantified kind variables were mistakenly flagged as existential has been fixed. * A bug in which the kinds of existentially quantified type variables were not substituted properly has been fixed. * More kind equalities are detected than before. For example, in the following data type: ```haskell data T (a :: k) where MkT :: forall (a :: Bool). T a ``` We now catch the `k ~ Bool` equality. * Tweak `resolveTypeSynonyms` so that failing to reify a type constructor name so longer results in an error. Among other benefits, this makes it possible to pass data types with GADT syntax to `normalizeDec`. ## 0.2.7.0 -- 2018-06-17 * Fix bug in which data family instances with duplicate occurrences of type variables in the left-hand side would have redundant equality constraints in their contexts. ## 0.2.6.0 -- 2017-09-04 * Fix bug in which `applySubstitution` and `freeVariables` would ignore type variables in the kinds of type variable binders. ## 0.2.5.0 * Added `pragLineDCompat`, `newtypeDCompat` and `tySynInstDCompat` ## 0.2.4.0 -- 2017-07-31 * Fix bug that caused GADT equality constraints to be incorrect in some cases. * Expose `Unpackedness` and `Strictness` (which were unexported by accident). ## 0.2.3.0 -- 2017-06-26 * Add `resolvePredSynonyms` * Add `reifyConstructor`, which allows reification of `ConstructorInfo` from a constructor name, and `lookupByConstructorName`, which allows directly looking up a `ConstructorInfo` from a `DatatypeInfo` value for a given constructor `Name`. * Augment `reifyDatatype` to be able to look up `DatatypeInfo` from the `Name` of a record selector for one of its constructors. Also add `reifyRecord` for reification of of `ConstructorInfo` from a record name, and `lookupByRecordName`, which allows directly looking up a `ConstructorInfo` from a `DatatypeInfo` value for a given record `Name`. * Fix bug that caused `th-abstraction` to fail on GHC 7.0 and 7.2 when passing a vanilla constructor name to `reifyDatatype` * Make `normalizeDec` and `normalizeCon` more robust with respect to data family instances on GHC 7.6 and 7.8 ## 0.2.2.0 -- 2017-06-10 * Fix `freeVariables` on lists not not produce duplicates. ## 0.2.1.0 -- 2017-06-09 * Add sensible reify defaults and error messages when we can't backport fixes to old GHC Template Haskell output due to hand-written Decs being processed. ## 0.2.0.0 -- 2017-06-03 * Added `reifyFixityCompat` * Added `constructorStrictness` field to `ConstructorInfo` * Infer more kind signatures when missing on old GHCs * Added parameter to `normalizeCon` * Support GHC back to 7.0.4 ## 0.1.3.0 -- 2017-05-27 * Added `resolveInfixT` which uses reified fixity information to resolve `UInfixT` * Added `asEqualPred` and `asClassPred` * Fixed data-instance GADTs ## 0.1.2.1 -- 2017-05-21 * Add eta reduction fixes to GHC 7.6 ## 0.1.2.0 -- 2017-05-21 * Added `arrowKCompat` * Added workaround for GHC 7.8 data instance eta reduction bug * Added kind signatures to datatypeVars ## 0.1.1.0 -- 2017-05-20 * Better matching of constraints generated for GADTs across GHC versions * Added `dataDCompat` * Support for giving value constructors to reifyDatatype. This enables data families to be reified easily. ## 0.1.0.0 -- 2017-04-26 * First version. th-abstraction-0.5.0.0/LICENSE0000644000000000000000000000133707346545000013776 0ustar0000000000000000Copyright (c) 2017-2020 Eric Mertens Permission to use, copy, modify, and/or distribute this software for any purpose with or without fee is hereby granted, provided that the above copyright notice and this permission notice appear in all copies. THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. th-abstraction-0.5.0.0/README.md0000644000000000000000000000137407346545000014251 0ustar0000000000000000th-abstraction ============== [![Hackage](https://img.shields.io/hackage/v/th-abstraction.svg)](https://hackage.haskell.org/package/th-abstraction) [![Build Status](https://github.com/glguy/th-abstraction/workflows/Haskell-CI/badge.svg)](https://github.com/glguy/th-abstraction/actions?query=workflow%3AHaskell-CI) This package provides a consistent interface to a subset of Template Haskell. Currently the package provides a consistent view of the reified declaration information about datatypes, newtypes, and data family instances. These interfaces abstract away the differences in the normal and GADT syntax used to define these types. Contact Information ------------------- Please contact me via GitHub or on the #haskell IRC channel on irc.libera.chat th-abstraction-0.5.0.0/Setup.hs0000644000000000000000000000005607346545000014422 0ustar0000000000000000import Distribution.Simple main = defaultMain th-abstraction-0.5.0.0/src/Language/Haskell/TH/0000755000000000000000000000000007346545000017175 5ustar0000000000000000th-abstraction-0.5.0.0/src/Language/Haskell/TH/Datatype.hs0000644000000000000000000026167007346545000021320 0ustar0000000000000000{-# 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 -- | Call 'reify' and return @'Just' info@ if successful or 'Nothing' if -- reification failed. reifyMaybe :: Name -> Q (Maybe Info) reifyMaybe n = return Nothing `recover` fmap Just (reify n) th-abstraction-0.5.0.0/src/Language/Haskell/TH/Datatype/0000755000000000000000000000000007346545000020750 5ustar0000000000000000th-abstraction-0.5.0.0/src/Language/Haskell/TH/Datatype/Internal.hs0000644000000000000000000000147207346545000023064 0ustar0000000000000000{-# LANGUAGE CPP #-} #if MIN_VERSION_template_haskell(2,12,0) {-# Language Safe #-} #elif __GLASGOW_HASKELL__ >= 702 {-# Language Trustworthy #-} #endif {-| Module : Language.Haskell.TH.Datatype.Internal Description : Backwards-compatible interface to reified information about datatypes. Copyright : Eric Mertens 2017 License : ISC Maintainer : emertens@gmail.com Internal Template Haskell 'Name's. -} module Language.Haskell.TH.Datatype.Internal where import Language.Haskell.TH.Syntax eqTypeName :: Name #if MIN_VERSION_base(4,9,0) && !(MIN_VERSION_base(4,13,0)) eqTypeName = mkNameG_tc "base" "Data.Type.Equality" "~" #else eqTypeName = mkNameG_tc "ghc-prim" "GHC.Types" "~" #endif -- This is only needed for GHC 7.6-specific bug starKindName :: Name starKindName = mkNameG_tc "ghc-prim" "GHC.Prim" "*" th-abstraction-0.5.0.0/src/Language/Haskell/TH/Datatype/TyVarBndr.hs0000644000000000000000000002547207346545000023171 0ustar0000000000000000{-# 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 #if __GLASGOW_HASKELL__ >= 800 #define HAS_TH_LIFT {-# Language DeriveLift #-} #endif {-| Module : Language.Haskell.TH.Datatype.TyVarBndr Description : Backwards-compatible type variable binders Copyright : Eric Mertens 2020 License : ISC Maintainer : emertens@gmail.com This module provides a backwards-compatible API for constructing and manipulating 'TyVarBndr's across multiple versions of the @template-haskell@ package. -} module Language.Haskell.TH.Datatype.TyVarBndr ( -- * @TyVarBndr@-related types TyVarBndr_ , TyVarBndrUnit , TyVarBndrSpec , Specificity(..) -- * Constructing @TyVarBndr@s -- ** @flag@-polymorphic , plainTVFlag , kindedTVFlag -- ** @TyVarBndrUnit@ , plainTV , kindedTV -- ** @TyVarBndrSpec@ , plainTVInferred , plainTVSpecified , kindedTVInferred , kindedTVSpecified -- * Constructing @Specificity@ , inferredSpec , specifiedSpec -- * Modifying @TyVarBndr@s , elimTV , mapTV , mapTVName , mapTVFlag , mapTVKind , traverseTV , traverseTVName , traverseTVFlag , traverseTVKind , mapMTV , mapMTVName , mapMTVFlag , mapMTVKind , changeTVFlags -- * Properties of @TyVarBndr@s , tvName , tvKind ) where import Control.Applicative import Control.Monad import Data.Data (Typeable, Data) 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). #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. type TyVarBndrUnit = TyVarBndr -- | A 'TyVarBndr' with an explicit 'Specificity'. 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 ) inferredSpec :: Specificity inferredSpec = InferredSpec specifiedSpec :: Specificity specifiedSpec = SpecifiedSpec #endif -- | Construct a 'PlainTV' with the given @flag@. plainTVFlag :: Name -> flag -> TyVarBndr_ flag #if MIN_VERSION_template_haskell(2,17,0) plainTVFlag = PlainTV #else plainTVFlag n _ = PlainTV n #endif -- | Construct a 'PlainTV' with an 'InferredSpec'. plainTVInferred :: Name -> TyVarBndrSpec plainTVInferred n = plainTVFlag n InferredSpec -- | Construct a 'PlainTV' with a 'SpecifiedSpec'. plainTVSpecified :: Name -> TyVarBndrSpec plainTVSpecified n = plainTVFlag n SpecifiedSpec -- | Construct a 'KindedTV' with the given @flag@. kindedTVFlag :: Name -> flag -> Kind -> TyVarBndr_ flag #if MIN_VERSION_template_haskell(2,17,0) kindedTVFlag = KindedTV #else kindedTVFlag n _ kind = KindedTV n kind #endif -- | Construct a 'KindedTV' with an 'InferredSpec'. kindedTVInferred :: Name -> Kind -> TyVarBndrSpec kindedTVInferred n k = kindedTVFlag n InferredSpec k -- | Construct a 'KindedTV' with a 'SpecifiedSpec'. kindedTVSpecified :: Name -> Kind -> TyVarBndrSpec kindedTVSpecified n k = kindedTVFlag n SpecifiedSpec 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@. elimTV :: (Name -> r) -> (Name -> Kind -> r) -> TyVarBndr_ flag -> r #if MIN_VERSION_template_haskell(2,17,0) elimTV ptv _ktv (PlainTV n _) = ptv n elimTV _ptv ktv (KindedTV n _ k) = ktv n k #else elimTV ptv _ktv (PlainTV n) = ptv n elimTV _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' #if MIN_VERSION_template_haskell(2,17,0) mapTV fn fflag _fkind (PlainTV n flag) = PlainTV (fn n) (fflag flag) mapTV fn fflag fkind (KindedTV n flag kind) = KindedTV (fn n) (fflag flag) (fkind kind) #else mapTV fn _fflag _fkind (PlainTV n) = PlainTV (fn n) mapTV fn _fflag fkind (KindedTV n kind) = KindedTV (fn n) (fkind kind) #endif -- | Map over the 'Name' of a 'TyVarBndr'. mapTVName :: (Name -> Name) -> TyVarBndr_ flag -> TyVarBndr_ flag mapTVName fname = mapTV fname id id -- | Map over the @flag@ of a 'TyVarBndr'. mapTVFlag :: (flag -> flag') -> TyVarBndr_ flag -> TyVarBndr_ flag' #if MIN_VERSION_template_haskell(2,17,0) mapTVFlag = fmap #else mapTVFlag _ = id #endif -- | Map over the 'Kind' of a 'TyVarBndr'. mapTVKind :: (Kind -> Kind) -> TyVarBndr_ flag -> TyVarBndr_ flag mapTVKind fkind = mapTV id id fkind -- | Traverse the components of a 'TyVarBndr'. traverseTV :: Applicative f => (Name -> f Name) -> (flag -> f flag') -> (Kind -> f Kind) -> TyVarBndr_ flag -> f (TyVarBndr_ flag') #if MIN_VERSION_template_haskell(2,17,0) traverseTV fn fflag _fkind (PlainTV n flag) = liftA2 PlainTV (fn n) (fflag flag) traverseTV fn fflag fkind (KindedTV n flag kind) = liftA3 KindedTV (fn n) (fflag flag) (fkind kind) #else traverseTV fn _fflag _fkind (PlainTV n) = PlainTV <$> fn n traverseTV fn _fflag fkind (KindedTV n kind) = liftA2 KindedTV (fn n) (fkind kind) #endif -- | Traverse the 'Name' of a 'TyVarBndr'. traverseTVName :: Functor f => (Name -> f Name) -> TyVarBndr_ flag -> f (TyVarBndr_ flag) #if MIN_VERSION_template_haskell(2,17,0) traverseTVName fn (PlainTV n flag) = (\n' -> PlainTV n' flag) <$> fn n traverseTVName fn (KindedTV n flag kind) = (\n' -> KindedTV n' flag kind) <$> fn n #else traverseTVName fn (PlainTV n) = PlainTV <$> fn n traverseTVName fn (KindedTV n kind) = (\n' -> KindedTV n' kind) <$> fn n #endif -- | Traverse the @flag@ of a 'TyVarBndr'. traverseTVFlag :: Applicative f => (flag -> f flag') -> TyVarBndr_ flag -> f (TyVarBndr_ flag') #if MIN_VERSION_template_haskell(2,17,0) traverseTVFlag fflag (PlainTV n flag) = PlainTV n <$> fflag flag traverseTVFlag fflag (KindedTV n flag kind) = (\flag' -> KindedTV n flag' kind) <$> fflag flag #else traverseTVFlag _ = pure #endif -- | Traverse the 'Kind' of a 'TyVarBndr'. traverseTVKind :: Applicative f => (Kind -> f Kind) -> TyVarBndr_ flag -> f (TyVarBndr_ flag) #if MIN_VERSION_template_haskell(2,17,0) traverseTVKind _fkind tvb@PlainTV{} = pure tvb traverseTVKind fkind (KindedTV n flag kind) = KindedTV n flag <$> fkind kind #else traverseTVKind _fkind tvb@PlainTV{} = pure tvb traverseTVKind fkind (KindedTV n kind) = KindedTV n <$> fkind kind #endif -- | Map over the components of a 'TyVarBndr' in a monadic fashion. -- -- This is the same as 'traverseTV', but with a 'Monad' constraint. This is -- mainly useful for use with old versions of @base@ where 'Applicative' was -- not a superclass of 'Monad'. mapMTV :: Monad m => (Name -> m Name) -> (flag -> m flag') -> (Kind -> m Kind) -> TyVarBndr_ flag -> m (TyVarBndr_ flag') #if MIN_VERSION_template_haskell(2,17,0) mapMTV fn fflag _fkind (PlainTV n flag) = liftM2 PlainTV (fn n) (fflag flag) mapMTV fn fflag fkind (KindedTV n flag kind) = liftM3 KindedTV (fn n) (fflag flag) (fkind kind) #else mapMTV fn _fflag _fkind (PlainTV n) = liftM PlainTV (fn n) mapMTV fn _fflag fkind (KindedTV n kind) = liftM2 KindedTV (fn n) (fkind kind) #endif -- | Map over the 'Name' of a 'TyVarBndr' in a monadic fashion. -- -- This is the same as 'traverseTVName', but with a 'Monad' constraint. This is -- mainly useful for use with old versions of @base@ where 'Applicative' was -- not a superclass of 'Monad'. mapMTVName :: Monad m => (Name -> m Name) -> TyVarBndr_ flag -> m (TyVarBndr_ flag) #if MIN_VERSION_template_haskell(2,17,0) mapMTVName fn (PlainTV n flag) = liftM (\n' -> PlainTV n' flag) (fn n) mapMTVName fn (KindedTV n flag kind) = liftM (\n' -> KindedTV n' flag kind) (fn n) #else mapMTVName fn (PlainTV n) = liftM PlainTV (fn n) mapMTVName fn (KindedTV n kind) = liftM (\n' -> KindedTV n' kind) (fn n) #endif -- | Map over the @flag@ of a 'TyVarBndr' in a monadic fashion. -- -- This is the same as 'traverseTVFlag', but with a 'Monad' constraint. This is -- mainly useful for use with old versions of @base@ where 'Applicative' was -- not a superclass of 'Monad'. mapMTVFlag :: Monad m => (flag -> m flag') -> TyVarBndr_ flag -> m (TyVarBndr_ flag') #if MIN_VERSION_template_haskell(2,17,0) mapMTVFlag fflag (PlainTV n flag) = liftM (PlainTV n) (fflag flag) mapMTVFlag fflag (KindedTV n flag kind) = liftM (\flag' -> KindedTV n flag' kind) (fflag flag) #else mapMTVFlag _ = return #endif -- | Map over the 'Kind' of a 'TyVarBndr' in a monadic fashion. -- -- This is the same as 'traverseTVKind', but with a 'Monad' constraint. This is -- mainly useful for use with old versions of @base@ where 'Applicative' was -- not a superclass of 'Monad'. mapMTVKind :: Monad m => (Kind -> m Kind) -> TyVarBndr_ flag -> m (TyVarBndr_ flag) #if MIN_VERSION_template_haskell(2,17,0) mapMTVKind _fkind tvb@PlainTV{} = return tvb mapMTVKind fkind (KindedTV n flag kind) = liftM (KindedTV n flag) (fkind kind) #else mapMTVKind _fkind tvb@PlainTV{} = return tvb mapMTVKind fkind (KindedTV n kind) = liftM (KindedTV n) (fkind kind) #endif -- | Set the flag in a list of 'TyVarBndr's. This is often useful in contexts -- where one needs to re-use a list of 'TyVarBndr's from one flag setting to -- another flag setting. For example, in order to re-use the 'TyVarBndr's bound -- by a 'DataD' in a 'ForallT', one can do the following: -- -- @ -- case x of -- 'DataD' _ _ tvbs _ _ _ -> -- 'ForallT' ('changeTVFlags' 'SpecifiedSpec' tvbs) ... -- @ changeTVFlags :: newFlag -> [TyVarBndr_ oldFlag] -> [TyVarBndr_ newFlag] #if MIN_VERSION_template_haskell(2,17,0) changeTVFlags newFlag = map (newFlag <$) #else changeTVFlags _ = id #endif -- | Extract the type variable name from a 'TyVarBndr', ignoring the -- kind signature if one exists. tvName :: TyVarBndr_ flag -> Name tvName = elimTV id (\n _ -> n) -- | Extract the kind from a 'TyVarBndr'. Assumes 'PlainTV' has kind @*@. tvKind :: TyVarBndr_ flag -> Kind tvKind = elimTV (\_ -> starK) (\_ k -> k) th-abstraction-0.5.0.0/test/0000755000000000000000000000000007346545000013744 5ustar0000000000000000th-abstraction-0.5.0.0/test/Harness.hs0000644000000000000000000001272307346545000015710 0ustar0000000000000000{-# Language CPP, TemplateHaskell #-} {-| Module : Harness Description : Comparison functions for data type info used in tests Copyright : Eric Mertens 2017 License : ISC Maintainer : emertens@gmail.com This module provides comparison functions that are able to check that the computed 'DatatypeInfo' values match the expected ones up to alpha renaming. -} module Harness ( validateDI , validateCI , equateCxt -- * Utilities , varKCompat ) where import Control.Monad import qualified Data.Map as Map import Data.Map (Map) import Data.Maybe import Language.Haskell.TH import Language.Haskell.TH.Datatype import Language.Haskell.TH.Datatype.TyVarBndr import Language.Haskell.TH.Lib (starK) validateDI :: DatatypeInfo -> DatatypeInfo -> ExpQ validateDI = validate equateDI validateCI :: ConstructorInfo -> ConstructorInfo -> ExpQ validateCI = validate equateCI validate :: (a -> a -> Either String ()) -> a -> a -> ExpQ validate equate x y = either fail (\_ -> [| return () |]) (equate x y) -- | If the arguments are equal up to renaming return @'Right' ()@, -- otherwise return a string explaining the mismatch. equateDI :: DatatypeInfo -> DatatypeInfo -> Either String () equateDI dat1 dat2 = do check "datatypeName" (nameBase . datatypeName) dat1 dat2 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 "datatypeVars" id (datatypeVars dat1) (substIntoTyVarBndrs sub (datatypeVars dat2)) check "datatypeInstTypes" id (datatypeInstTypes dat1) (applySubstitution sub (datatypeInstTypes dat2)) zipWithM_ (equateCxt "datatypeContext") (datatypeContext dat1) (applySubstitution sub (datatypeContext dat2)) zipWithM_ equateCI (datatypeCons dat1) (datatypeCons dat2) -- Don't bother applying the substitution here, as -- equateCI takes care of this for us equateCxt :: String -> Pred -> Pred -> Either String () equateCxt lbl pred1 pred2 = do check (lbl ++ " class") asClassPred pred1 pred2 check (lbl ++ " equality") asEqualPred pred1 pred2 -- | If the arguments are equal up to renaming return @'Right' ()@, -- otherwise return a string explaining the mismatch. equateCI :: ConstructorInfo -> ConstructorInfo -> Either String () equateCI con1 con2 = do check "constructorName" (nameBase . constructorName) con1 con2 check "constructorVariant" constructorVariantBase con1 con2 let sub1 = Map.fromList (zip (freeVariables (bndrParams (constructorVars con2))) (map VarT (freeVariables (bndrParams (constructorVars con1))))) sub2 = Map.fromList (zip (freeVariables con2) (map VarT (freeVariables con1))) sub = Map.unions [sub1, sub2] zipWithM_ (equateCxt "constructorContext") (constructorContext con1) (applySubstitution sub (constructorContext con2)) check "constructorVars" id (constructorVars con1) (substIntoTyVarBndrs sub (constructorVars con2)) check "constructorFields" id (constructorFields con1) (applySubstitution sub (constructorFields con2)) zipWithM_ equateStrictness (constructorStrictness con1) (constructorStrictness con2) where constructorVariantBase :: ConstructorInfo -> ConstructorVariant constructorVariantBase con = case constructorVariant con of NormalConstructor -> NormalConstructor i@InfixConstructor{} -> i RecordConstructor fields -> RecordConstructor $ map (mkName . nameBase) fields -- Substitutes both type variable names and kinds. substIntoTyVarBndrs :: Map Name Type -> [TyVarBndr_ flag] -> [TyVarBndr_ flag] substIntoTyVarBndrs subst = map go where go = mapTV (substName subst) id (applySubstitution subst) substName :: Map Name Type -> Name -> Name substName subst n = fromMaybe n $ do nty <- Map.lookup n subst case nty of VarT n' -> Just n' _ -> Nothing bndrParams :: [TyVarBndr_ flag] -> [Type] bndrParams = map $ elimTV VarT (\n k -> SigT (VarT n) k) equateStrictness :: FieldStrictness -> FieldStrictness -> Either String () equateStrictness fs1 fs2 = check "constructorStrictness" oldGhcHack fs1 fs2 where #if MIN_VERSION_template_haskell(2,7,0) oldGhcHack = id #else -- GHC 7.0 and 7.2 didn't have an Unpacked TH constructor, so as a -- simple workaround, we will treat unpackedAnnot as isStrictAnnot -- (the closest equivalent). oldGhcHack fs | fs == unpackedAnnot = isStrictAnnot | otherwise = fs #endif check :: (Show b, Eq b) => String -> (a -> b) -> a -> a -> Either String () check lbl f x y | f x == f y = Right () | otherwise = Left (lbl ++ ":\n\n" ++ show (f x) ++ "\n\n" ++ show (f y)) -- If on a recent-enough version of Template Haskell, construct a kind variable. -- Otherwise, default to starK. varKCompat :: Name -> Kind #if MIN_VERSION_template_haskell(2,8,0) varKCompat = VarT #else varKCompat _ = starK #endif th-abstraction-0.5.0.0/test/Main.hs0000644000000000000000000012430707346545000015173 0ustar0000000000000000{-# Language CPP, FlexibleContexts, TypeFamilies, KindSignatures, TemplateHaskell, GADTs #-} #if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE ConstraintKinds #-} #endif #if __GLASGOW_HASKELL__ >= 807 {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeApplications #-} #endif #if MIN_VERSION_template_haskell(2,8,0) {-# Language PolyKinds #-} #endif {-| Module : Main Description : Test cases for the th-abstraction package Copyright : Eric Mertens 2017 License : ISC Maintainer : emertens@gmail.com This module checks that the 'reifyDatatype' logic works consistently across a wide range of datatypes. These tests are validated across the versions of GHC supported by this package. -} module Main (main) where #if __GLASGOW_HASKELL__ >= 704 import Control.Monad (zipWithM_) #endif import Control.Monad (unless, when) import qualified Data.Map as Map #if MIN_VERSION_base(4,7,0) import Data.Type.Equality ((:~:)(..)) #endif import Language.Haskell.TH import Language.Haskell.TH.Datatype as Datatype import Language.Haskell.TH.Datatype.TyVarBndr import Language.Haskell.TH.Lib (starK) import Harness import Types -- | Test entry point. Tests will pass or fail at compile time. main :: IO () main = do adt1Test gadt1Test gadt2Test gadtrec1Test equalTest showableTest recordTest 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 polyTest gadtFamTest famLocalDecTest1 famLocalDecTest2 recordFamTest 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 regressionTest44 t63Test t70Test t88Test captureAvoidanceTest #if MIN_VERSION_template_haskell(2,20,0) t100Test #endif adt1Test :: IO () adt1Test = $(do info <- reifyDatatype ''Adt1 let names = map mkName ["a","b"] [aTvb,bTvb] = map (\v -> kindedTV v starK) names vars@[aVar,bVar] = map (VarT . mkName) ["a","b"] [aSig,bSig] = map (\v -> SigT v starK) vars validateDI info DatatypeInfo { datatypeName = ''Adt1 , datatypeContext = [] , datatypeVars = [aTvb,bTvb] , datatypeInstTypes = [aSig, bSig] , datatypeVariant = Datatype , datatypeCons = [ ConstructorInfo { constructorName = 'Adtc1 , constructorContext = [] , constructorVars = [] , constructorFields = [AppT (AppT (TupleT 2) aVar) bVar] , constructorStrictness = [notStrictAnnot] , constructorVariant = NormalConstructor } , ConstructorInfo { constructorName = 'Adtc2 , constructorContext = [] , constructorVars = [] , constructorFields = [ConT ''Bool, ConT ''Int] , constructorStrictness = [notStrictAnnot, notStrictAnnot] , constructorVariant = InfixConstructor } ] } ) gadt1Test :: IO () gadt1Test = $(do info <- reifyDatatype ''Gadt1 let a = mkName "a" aVar = VarT a validateDI info DatatypeInfo { datatypeName = ''Gadt1 , datatypeContext = [] , datatypeVars = [kindedTV a starK] , datatypeInstTypes = [SigT aVar starK] , datatypeVariant = Datatype , datatypeCons = [ ConstructorInfo { constructorName = 'Gadtc1 , constructorVars = [] , constructorContext = [equalPred aVar (ConT ''Int)] , constructorFields = [ConT ''Int] , constructorStrictness = [notStrictAnnot] , constructorVariant = NormalConstructor } , ConstructorInfo { constructorName = 'Gadtc2 , constructorVars = [] , constructorContext = [] , constructorFields = [AppT (AppT (TupleT 2) aVar) aVar] , constructorStrictness = [notStrictAnnot] , constructorVariant = NormalConstructor } , ConstructorInfo { constructorName = '(:**:) , constructorVars = [] , constructorContext = [equalPred aVar (TupleT 0)] , constructorFields = [ConT ''Bool, ConT ''Char] , constructorStrictness = [notStrictAnnot, notStrictAnnot] , constructorVariant = InfixConstructor } , ConstructorInfo { constructorName = '(:!!:) , constructorVars = [] , constructorContext = [equalPred aVar (ConT ''Double)] , constructorFields = [ConT ''Char, ConT ''Bool] , constructorStrictness = [notStrictAnnot, notStrictAnnot] , constructorVariant = NormalConstructor } ] } ) gadtrec1Test :: IO () gadtrec1Test = $(do info <- reifyDatatype ''Gadtrec1 let a = mkName "a" con = gadtRecVanillaCI validateDI info DatatypeInfo { datatypeName = ''Gadtrec1 , datatypeContext = [] , datatypeVars = [kindedTV a starK] , datatypeInstTypes = [SigT (VarT a) starK] , datatypeVariant = Datatype , datatypeCons = [ con, con { constructorName = 'Gadtrecc2 } ] } ) equalTest :: IO () equalTest = $(do info <- reifyDatatype ''Equal let names = map mkName ["a","b","c"] [aTvb,bTvb,cTvb] = map (\v -> kindedTV v starK) names vars@[aVar,bVar,cVar] = map VarT names [aSig,bSig,cSig] = map (\v -> SigT v starK) vars validateDI info DatatypeInfo { datatypeName = ''Equal , datatypeContext = [] , datatypeVars = [aTvb, bTvb, cTvb] , datatypeInstTypes = [aSig, bSig, cSig] , datatypeVariant = Datatype , datatypeCons = [ ConstructorInfo { constructorName = 'Equalc , constructorVars = [] , constructorContext = [ equalPred aVar cVar , equalPred bVar cVar , classPred ''Read [cVar] , classPred ''Show [cVar] ] , constructorFields = [ListT `AppT` cVar, ConT ''Maybe `AppT` cVar] , constructorStrictness = [notStrictAnnot, notStrictAnnot] , constructorVariant = NormalConstructor } ] } ) showableTest :: IO () showableTest = $(do info <- reifyDatatype ''Showable let a = mkName "a" validateDI info DatatypeInfo { datatypeName = ''Showable , datatypeContext = [] , datatypeVars = [] , datatypeInstTypes = [] , datatypeVariant = Datatype , datatypeCons = [ ConstructorInfo { constructorName = 'Showable , constructorVars = [kindedTV a starK] , constructorContext = [classPred ''Show [VarT a]] , constructorFields = [VarT a] , constructorStrictness = [notStrictAnnot] , constructorVariant = NormalConstructor } ] } ) recordTest :: IO () recordTest = $(do info <- reifyDatatype ''R validateDI info DatatypeInfo { datatypeName = ''R , datatypeContext = [] , datatypeVars = [] , datatypeInstTypes = [] , datatypeVariant = Datatype , datatypeCons = [ ConstructorInfo { constructorName = 'R1 , constructorVars = [] , constructorContext = [] , constructorFields = [ConT ''Int, ConT ''Int] , constructorStrictness = [notStrictAnnot, notStrictAnnot] , constructorVariant = RecordConstructor ['field1, 'field2] } ] } ) gadt2Test :: IO () gadt2Test = $(do info <- reifyDatatype ''Gadt2 let names = map mkName ["a","b"] [aTvb,bTvb] = map (\v -> kindedTV v starK) names vars@[aVar,bVar] = map VarT names [aSig,bSig] = map (\v -> SigT v starK) vars x = mkName "x" con = ConstructorInfo { constructorName = undefined , constructorVars = [] , constructorContext = [] , constructorFields = [] , constructorStrictness = [] , constructorVariant = NormalConstructor } validateDI info DatatypeInfo { datatypeName = ''Gadt2 , datatypeContext = [] , datatypeVars = [aTvb, bTvb] , datatypeInstTypes = [aSig, bSig] , datatypeVariant = Datatype , datatypeCons = [ con { constructorName = 'Gadt2c1 , constructorContext = [equalPred bVar (AppT ListT aVar)] } , con { constructorName = 'Gadt2c2 , constructorContext = [equalPred aVar (AppT ListT bVar)] } , con { constructorName = 'Gadt2c3 , constructorVars = [kindedTV x starK] , constructorContext = [equalPred aVar (AppT ListT (VarT x)) ,equalPred bVar (AppT ListT (VarT x))] } ] } ) voidstosTest :: IO () voidstosTest = $(do info <- reifyDatatype ''VoidStoS let g = mkName "g" validateDI info DatatypeInfo { datatypeName = ''VoidStoS , datatypeContext = [] , datatypeVars = [kindedTV g (arrowKCompat starK starK)] , datatypeInstTypes = [SigT (VarT g) (arrowKCompat starK starK)] , datatypeVariant = Datatype , datatypeCons = [] } ) strictDemoTest :: IO () strictDemoTest = $(do info <- reifyDatatype ''StrictDemo validateDI info DatatypeInfo { datatypeName = ''StrictDemo , datatypeContext = [] , datatypeVars = [] , datatypeInstTypes = [] , datatypeVariant = Datatype , datatypeCons = [ ConstructorInfo { constructorName = 'StrictDemo , constructorVars = [] , constructorContext = [] , constructorFields = [ConT ''Int, ConT ''Int, ConT ''Int] , constructorStrictness = [ notStrictAnnot , isStrictAnnot , unpackedAnnot ] , constructorVariant = NormalConstructor } ] } ) recordVanillaTest :: IO () recordVanillaTest = $(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 |] infoPlain <- normalizeDec decPlain validateDI infoPlain DatatypeInfo { datatypeName = mkName "T43Plain" , datatypeContext = [] , datatypeVars = [] , datatypeInstTypes = [] , datatypeVariant = Datatype , datatypeCons = [ ConstructorInfo { constructorName = mkName "MkT43Plain" , constructorVars = [] , constructorContext = [] , constructorFields = [] , constructorStrictness = [] , constructorVariant = NormalConstructor } ] } [decFam] <- [d| data instance T43Fam where MkT43Fam :: T43Fam |] infoFam <- normalizeDec decFam validateDI infoFam DatatypeInfo { datatypeName = mkName "T43Fam" , datatypeContext = [] , datatypeVars = [] , datatypeInstTypes = [] , datatypeVariant = DataInstance , datatypeCons = [ ConstructorInfo { constructorName = mkName "MkT43Fam" , constructorVars = [] , constructorContext = [] , constructorFields = [] , constructorStrictness = [] , constructorVariant = NormalConstructor } ] } ) t58Test :: IO () t58Test = $(do [dec] <- [d| data Foo where MkFoo :: a -> Foo |] info <- normalizeDec dec let a = mkName "a" validateDI info DatatypeInfo { datatypeName = mkName "Foo" , datatypeContext = [] , datatypeVars = [] , datatypeInstTypes = [] , datatypeVariant = Datatype , datatypeCons = [ ConstructorInfo { constructorName = mkName "MkFoo" , constructorVars = [plainTV a] , constructorContext = [] , constructorFields = [VarT a] , constructorStrictness = [notStrictAnnot] , constructorVariant = NormalConstructor } ] } ) #endif #if MIN_VERSION_template_haskell(2,7,0) dataFamilyTest :: IO () dataFamilyTest = $(do info <- reifyDatatype 'DFMaybe let a = mkName "a" validateDI info DatatypeInfo { datatypeName = ''DF , datatypeContext = [] , datatypeVars = [kindedTV a starK] , datatypeInstTypes = [AppT (ConT ''Maybe) (VarT a)] , datatypeVariant = DataInstance , datatypeCons = [ ConstructorInfo { constructorName = 'DFMaybe , constructorVars = [] , constructorContext = [] , constructorFields = [ConT ''Int, ListT `AppT` VarT a] , constructorStrictness = [notStrictAnnot, notStrictAnnot] , constructorVariant = NormalConstructor } ] } ) ghc78bugTest :: IO () ghc78bugTest = $(do info <- reifyDatatype 'DF1 let c = mkName "c" cVar = VarT c validateDI info DatatypeInfo { datatypeName = ''DF1 , datatypeContext = [] , datatypeVars = [kindedTV c starK] , datatypeInstTypes = [SigT cVar starK] , datatypeVariant = DataInstance , datatypeCons = [ ConstructorInfo { constructorName = 'DF1 , constructorVars = [] , constructorContext = [] , constructorFields = [cVar] , constructorStrictness = [notStrictAnnot] , constructorVariant = NormalConstructor } ] } ) quotedTest :: IO () quotedTest = $(do [dec] <- [d| data instance Quoted a = MkQuoted a |] info <- normalizeDec dec let a = mkName "a" aVar = VarT a validateDI info DatatypeInfo { datatypeName = mkName "Quoted" , datatypeContext = [] , datatypeVars = [plainTV a] , datatypeInstTypes = [aVar] , datatypeVariant = DataInstance , datatypeCons = [ ConstructorInfo { constructorName = mkName "MkQuoted" , constructorVars = [] , constructorContext = [] , constructorFields = [aVar] , constructorStrictness = [notStrictAnnot] , constructorVariant = NormalConstructor } ] } ) polyTest :: IO () polyTest = $(do info <- reifyDatatype 'MkPoly let [a,k] = map mkName ["a","k"] kVar = varKCompat k validateDI info DatatypeInfo { datatypeName = ''Poly , datatypeContext = [] , datatypeVars = [ #if __GLASGOW_HASKELL__ >= 800 kindedTV k starK, #endif kindedTV a kVar ] , datatypeInstTypes = [SigT (VarT a) kVar] , datatypeVariant = DataInstance , datatypeCons = [ ConstructorInfo { constructorName = 'MkPoly , constructorVars = [] , constructorContext = [] , constructorFields = [] , constructorStrictness = [] , constructorVariant = NormalConstructor } ] } ) gadtFamTest :: IO () gadtFamTest = $(do info <- reifyDatatype 'MkGadtFam1 let names@[c,d,e,q] = map mkName ["c","d","e","q"] [cTvb,dTvb,eTvb,qTvb] = map (\v -> kindedTV v starK) names [cTy,dTy,eTy,qTy] = map VarT names [cSig,dSig] = map (\v -> SigT v starK) [cTy,dTy] validateDI info DatatypeInfo { datatypeName = ''GadtFam , datatypeContext = [] , datatypeVars = [cTvb,dTvb] , datatypeInstTypes = [cSig,dSig] , datatypeVariant = DataInstance , datatypeCons = [ ConstructorInfo { constructorName = 'MkGadtFam1 , constructorVars = [] , constructorContext = [] , constructorFields = [dTy,cTy] , constructorStrictness = [notStrictAnnot, notStrictAnnot] , constructorVariant = NormalConstructor } , ConstructorInfo { constructorName = '(:&&:) , constructorVars = [kindedTV e starK] , constructorContext = [equalPred cTy (AppT ListT eTy)] , constructorFields = [eTy,dTy] , constructorStrictness = [notStrictAnnot, notStrictAnnot] , constructorVariant = InfixConstructor } , ConstructorInfo { constructorName = '(:^^:) , constructorVars = [] , constructorContext = [ equalPred cTy (ConT ''Int) , equalPred dTy (ConT ''Int) ] , constructorFields = [ConT ''Int, ConT ''Int] , constructorStrictness = [notStrictAnnot, notStrictAnnot] , constructorVariant = NormalConstructor } , gadtRecFamCI , ConstructorInfo { constructorName = 'MkGadtFam4 , constructorVars = [] , constructorContext = [ equalPred cTy dTy , equalPred (ConT ''Int) dTy ] , constructorFields = [dTy] , constructorStrictness = [notStrictAnnot] , constructorVariant = NormalConstructor } , ConstructorInfo { constructorName = 'MkGadtFam5 , constructorVars = [kindedTV q starK] , constructorContext = [ equalPred cTy (ConT ''Bool) , equalPred dTy (ConT ''Bool) , equalPred qTy (ConT ''Char) ] , constructorFields = [qTy] , constructorStrictness = [notStrictAnnot] , constructorVariant = NormalConstructor } ] } ) famLocalDecTest1 :: IO () famLocalDecTest1 = $(do [dec] <- [d| data instance FamLocalDec1 Int = FamLocalDec1Int { mochi :: Double } |] info <- normalizeDec dec validateDI info DatatypeInfo { datatypeName = ''FamLocalDec1 , datatypeContext = [] , datatypeVars = [] , datatypeInstTypes = [ConT ''Int] , datatypeVariant = DataInstance , datatypeCons = [ ConstructorInfo { constructorName = mkName "FamLocalDec1Int" , constructorVars = [] , constructorContext = [] , constructorFields = [ConT ''Double] , constructorStrictness = [notStrictAnnot] , constructorVariant = RecordConstructor [mkName "mochi"] }] } ) famLocalDecTest2 :: IO () famLocalDecTest2 = $(do [dec] <- [d| data instance FamLocalDec2 Int (a, b) a = FamLocalDec2Int { fm0 :: (b, a), fm1 :: Int } |] info <- normalizeDec dec let names = map mkName ["a", "b"] [aTvb,bTvb] = map plainTV names vars@[aVar,bVar] = map (VarT . mkName) ["a", "b"] validateDI info DatatypeInfo { datatypeName = ''FamLocalDec2 , datatypeContext = [] , datatypeVars = [aTvb,bTvb] , datatypeInstTypes = [ConT ''Int, TupleT 2 `AppT` aVar `AppT` bVar, aVar] , datatypeVariant = DataInstance , datatypeCons = [ ConstructorInfo { constructorName = mkName "FamLocalDec2Int" , constructorVars = [] , constructorContext = [] , constructorFields = [TupleT 2 `AppT` bVar `AppT` aVar, ConT ''Int] , constructorStrictness = [notStrictAnnot, notStrictAnnot] , constructorVariant = RecordConstructor [mkName "fm0", mkName "fm1"] }] } ) recordFamTest :: IO () recordFamTest = $(do info <- reifyRecord 'famRec1 validateCI info gadtRecFamCI) t46Test :: IO () t46Test = $(do info <- reifyDatatype 'MkT46 case info of DatatypeInfo { datatypeCons = [ConstructorInfo { constructorContext = ctxt }]} -> unless (null ctxt) (fail "regression test for ticket #46 failed") _ -> fail "T46 should have exactly one constructor" [| return () |]) t73Test :: IO () t73Test = $(do info <- reifyDatatype 'MkT73 let b = mkName "b" bTvb = kindedTV b starK bVar = VarT b validateDI info DatatypeInfo { datatypeName = ''T73 , datatypeContext = [] , datatypeVars = [bTvb] , datatypeInstTypes = [ConT ''Int, SigT bVar starK] , datatypeVariant = DataInstance , datatypeCons = [ ConstructorInfo { constructorName = 'MkT73 , constructorVars = [] , constructorContext = [] , constructorFields = [bVar] , constructorStrictness = [notStrictAnnot] , constructorVariant = NormalConstructor }] } ) t95Test :: IO () t95Test = $(do info <- reifyDatatype 'MkT95 let a = mkName "a" aTvb = kindedTV a starK aVar = VarT a validateDI info DatatypeInfo { datatypeName = ''T95 , datatypeContext = [] , datatypeVars = [aTvb] , datatypeInstTypes = [AppT ListT aVar] , datatypeVariant = DataInstance , datatypeCons = [ ConstructorInfo { constructorName = 'MkT95 , constructorVars = [] , constructorContext = [] , constructorFields = [aVar] , constructorStrictness = [notStrictAnnot] , constructorVariant = NormalConstructor }] } ) #endif fixityLookupTest :: IO () fixityLookupTest = $(do Just (Fixity 6 InfixR) <- reifyFixityCompat '(:**:) [| return () |]) #if __GLASGOW_HASKELL__ >= 704 resolvePredSynonymsTest :: IO () resolvePredSynonymsTest = $(do info <- reifyDatatype ''PredSynT [cxt1,cxt2,cxt3] <- sequence $ map (mapM resolvePredSynonyms . constructorContext) $ datatypeCons info let mkTest = zipWithM_ (equateCxt "resolvePredSynonymsTest") test1 = mkTest cxt1 [classPred ''Show [ConT ''Int]] test2 = mkTest cxt2 [classPred ''Show [ConT ''Int]] test3 = mkTest cxt3 [equalPred (ConT ''Int) (ConT ''Int)] mapM_ (either fail return) [test1,test2,test3] [| return () |]) #endif reifyDatatypeWithConNameTest :: IO () reifyDatatypeWithConNameTest = $(do info <- reifyDatatype 'Just let a = mkName "a" validateDI info DatatypeInfo { datatypeContext = [] , datatypeName = ''Maybe , datatypeVars = [kindedTV a starK] , datatypeInstTypes = [SigT (VarT a) starK] , datatypeVariant = Datatype , datatypeCons = [ ConstructorInfo { constructorName = 'Nothing , constructorVars = [] , constructorContext = [] , constructorFields = [] , constructorStrictness = [] , constructorVariant = NormalConstructor } , justCI ] } ) reifyConstructorTest :: IO () reifyConstructorTest = $(do info <- reifyConstructor 'Just validateCI info justCI) #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 validateDI info DatatypeInfo { datatypeContext = [] , datatypeName = ''(:~:) , datatypeVars = [ #if __GLASGOW_HASKELL__ >= 800 kindedTV k starK, #endif kindedTV a kKind, kindedTV b kKind] , datatypeInstTypes = [SigT aVar kKind, SigT bVar kKind] , datatypeVariant = Datatype , datatypeCons = [ ConstructorInfo { constructorName = 'Refl , constructorVars = [] , constructorContext = [equalPred aVar bVar] , constructorFields = [] , constructorStrictness = [] , constructorVariant = NormalConstructor } ] } ) #endif #if MIN_VERSION_template_haskell(2,8,0) kindSubstTest :: IO () kindSubstTest = $(do k1 <- newName "k1" k2 <- newName "k2" a <- newName "a" let ty = ForallT [kindedTVSpecified a (VarT k1)] [] (VarT a) substTy = applySubstitution (Map.singleton k1 (VarT k2)) ty checkFreeVars :: Type -> [Name] -> Q () checkFreeVars t freeVars = unless (freeVariables t == freeVars) $ fail $ "free variables of " ++ show t ++ " should be " ++ show freeVars checkFreeVars ty [k1] checkFreeVars substTy [k2] [| return () |]) t59Test :: IO () t59Test = $(do k <- newName "k" a <- newName "a" 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) $ fail $ "quantifyType does not respect dependency order: " ++ unlines [ "Expected: " ++ pprint expected , "Actual: " ++ pprint actual ] [| return () |]) t61Test :: IO () t61Test = $(do let test :: Type -> Type -> Q () test orig expected = do actual <- resolveTypeSynonyms orig unless (expected == actual) $ fail $ "Type synonym expansion failed: " ++ unlines [ "Expected: " ++ pprint expected , "Actual: " ++ pprint actual ] 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)] [idAppT (ConT ''Show `AppT` VarT a)] (idAppT $ VarT a)) (ForallT [kindedTVSpecified a StarT] [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)) #endif [| return () |]) t66Test :: IO () t66Test = $(do [dec] <- [d| data Foo a b :: (* -> *) -> * -> * where MkFoo :: a -> b -> f x -> Foo a b f x |] info <- normalizeDec dec let [a,b,f,x] = map mkName ["a","b","f","x"] fKind = arrowKCompat starK starK validateDI info DatatypeInfo { datatypeName = mkName "Foo" , datatypeContext = [] , datatypeVars = [ plainTV a, plainTV b , kindedTV f fKind, kindedTV x starK ] , datatypeInstTypes = [ VarT a, VarT b , SigT (VarT f) fKind, SigT (VarT x) starK ] , datatypeVariant = Datatype , datatypeCons = [ ConstructorInfo { constructorName = mkName "MkFoo" , constructorVars = [] , constructorContext = [] , constructorFields = [VarT a, VarT b, VarT f `AppT` VarT x] , constructorStrictness = [notStrictAnnot, notStrictAnnot, notStrictAnnot] , constructorVariant = NormalConstructor } ] } ) t80Test :: IO () t80Test = do let [k,a,b] = map mkName ["k","a","b"] -- forall k (a :: k) (b :: k). () t = ForallT [ plainTVSpecified k , kindedTVSpecified a (VarT k) , kindedTVSpecified b (VarT k) ] [] (ConT ''()) expected, actual :: [Name] expected = [] actual = freeVariables t unless (expected == actual) $ fail $ "Bug in ForallT substitution: " ++ unlines [ "Expected: " ++ pprint expected , "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"] t = ForallT [kindedTVSpecified a (UInfixT (VarT b) ''(:+:) (VarT c))] [] (ConT ''()) expected = ForallT [kindedTVSpecified a (ConT ''(:+:) `AppT` VarT b `AppT` VarT c)] [] (ConT ''()) actual <- resolveInfixT t unless (expected == actual) $ fail $ "resolveInfixT does not recur into the kinds of " ++ "ForallT type variable binders: " ++ unlines [ "Expected: " ++ pprint expected , "Actual: " ++ pprint actual ] [| return () |]) #endif #if MIN_VERSION_template_haskell(2,19,0) t79TestB :: IO () t79TestB = $(do let [a,b,c] = map mkName ["a","b","c"] t = ForallT [kindedTVSpecified a (PromotedUInfixT (VarT b) '(:^:) (VarT c))] [] (ConT ''()) expected = ForallT [kindedTVSpecified a (PromotedT '(:^:) `AppT` VarT b `AppT` VarT c)] [] (ConT ''()) actual <- resolveInfixT t unless (expected == actual) $ fail $ "resolveInfixT does not recur into the kinds of " ++ "ForallT type variable binders: " ++ unlines [ "Expected: " ++ pprint expected , "Actual: " ++ pprint actual ] [| return () |]) #endif #if __GLASGOW_HASKELL__ >= 800 t37Test :: IO () t37Test = $(do infoA <- reifyDatatype ''T37a let names@[k,a] = map mkName ["k","a"] [kVar,aVar] = map VarT names kSig = SigT kVar starK aSig = SigT aVar kVar kTvb = kindedTV k starK aTvb = kindedTV a kVar validateDI infoA DatatypeInfo { datatypeContext = [] , datatypeName = ''T37a , datatypeVars = [kTvb, aTvb] , datatypeInstTypes = [kSig, aSig] , datatypeVariant = Datatype , datatypeCons = [ ConstructorInfo { constructorName = 'MkT37a , constructorVars = [] , constructorContext = [equalPred kVar (ConT ''Bool)] , constructorFields = [] , constructorStrictness = [] , constructorVariant = NormalConstructor } ] } infoB <- reifyDatatype ''T37b validateDI infoB DatatypeInfo { datatypeContext = [] , datatypeName = ''T37b , datatypeVars = [kTvb, aTvb] , datatypeInstTypes = [aSig] , datatypeVariant = Datatype , datatypeCons = [ ConstructorInfo { constructorName = 'MkT37b , constructorVars = [] , constructorContext = [equalPred kVar (ConT ''Bool)] , constructorFields = [] , constructorStrictness = [] , constructorVariant = NormalConstructor } ] } infoC <- reifyDatatype ''T37c validateDI infoC DatatypeInfo { datatypeContext = [] , datatypeName = ''T37c , datatypeVars = [kTvb, aTvb] , datatypeInstTypes = [aSig] , datatypeVariant = Datatype , datatypeCons = [ ConstructorInfo { constructorName = 'MkT37c , constructorVars = [] , constructorContext = [equalPred aVar (ConT ''Bool)] , constructorFields = [] , constructorStrictness = [] , constructorVariant = NormalConstructor } ] } ) polyKindedExTyvarTest :: IO () polyKindedExTyvarTest = $(do info <- reifyDatatype ''T48 let [a,x] = map mkName ["a","x"] aVar = VarT a validateDI info DatatypeInfo { datatypeContext = [] , datatypeName = ''T48 , datatypeVars = [kindedTV a starK] , datatypeInstTypes = [SigT aVar starK] , datatypeVariant = Datatype , datatypeCons = [ ConstructorInfo { constructorName = 'MkT48 , constructorVars = [kindedTV x aVar] , constructorContext = [] , constructorFields = [ConT ''Prox `AppT` VarT x] , constructorStrictness = [notStrictAnnot] , constructorVariant = NormalConstructor } ] } -- Because validateCI uses a type variable substitution to normalize -- away any alpha-renaming differences between constructors, it -- unfortunately does not check if the uses of `a` in datatypeVars and -- constructorVars are the same. We perform this check explicitly here. case info of DatatypeInfo { datatypeVars = [v1] , datatypeCons = [ConstructorInfo { constructorVars = [v2] }] } | a1 <- tvName v1, starK == tvKind v1, VarT a2 <- tvKind v2 -> unless (a1 == a2) $ fail $ "Two occurrences of the same variable have different names: " ++ show [a1, a2] [| return () |] ) t75Test :: IO () t75Test = $(do info <- reifyDatatype ''T75 case datatypeCons info of [c] -> let datatypeVarTypes = map (VarT . tvName) $ datatypeVars info constructorVarKinds = map tvKind $ constructorVars c in unless (datatypeVarTypes == constructorVarKinds) $ fail $ "Mismatch between datatypeVars and constructorVars' kinds: " ++ unlines [ "datatypeVars: " ++ pprint datatypeVarTypes , "constructorVars' kinds: " ++ pprint constructorVarKinds ] cs -> fail $ "Unexpected number of constructors for T75: " ++ show (length cs) [| return () |] ) #endif #if __GLASGOW_HASKELL__ >= 807 resolveTypeSynonymsVKATest :: IO () resolveTypeSynonymsVKATest = $(do t <- [t| T37b @Bool True |] t' <- resolveTypeSynonyms t unless (t == t') $ fail $ "Type synonym expansion breaks with visible kind application: " ++ show [t, t'] [| return () |]) #endif regressionTest44 :: IO () regressionTest44 = $(do intToInt <- [t| Int -> Int |] unified <- unifyTypes [intToInt, intToInt] unless (Map.null unified) (fail "regression test for ticket #44 failed") [| return () |]) t63Test :: IO () t63Test = $(do a <- newName "a" b <- newName "b" t <- newName "T" let tauType = ArrowT `AppT` VarT a `AppT` (ArrowT `AppT` VarT b `AppT` (ConT t `AppT` VarT a)) sigmaType = ForallT [plainTVSpecified b] [] tauType expected = ForallT [plainTVSpecified a, plainTVSpecified b] [] tauType actual = quantifyType sigmaType unless (expected == actual) $ fail $ "quantifyType does not collapse consecutive foralls: " ++ unlines [ "Expected: " ++ pprint expected , "Actual: " ++ pprint actual ] [| return () |]) t70Test :: IO () t70Test = $(do a <- newName "a" b <- newName "b" let [aVar, bVar] = map VarT [a, b] [aTvb, bTvb] = map plainTV [a, b] let fvsABExpected = [aTvb, bTvb] fvsABActual = freeVariablesWellScoped [aVar, bVar] fvsBAExpected = [bTvb, aTvb] fvsBAActual = freeVariablesWellScoped [bVar, aVar] check expected actual = unless (expected == actual) $ fail $ "freeVariablesWellScoped does not preserve left-to-right order: " ++ unlines [ "Expected: " ++ pprint expected , "Actual: " ++ pprint actual ] check fvsABExpected fvsABActual check fvsBAExpected fvsBAActual [| return () |]) t88Test :: IO () t88Test = $(do let unexpandedType = ConT ''Id expected = unexpandedType actual <- resolveTypeSynonyms (ConT ''Id) unless (expected == actual) $ fail $ "resolveTypeSynonyms incorrectly expands an undersaturated type synonym: " ++ unlines [ "Expected: " ++ pprint expected , "Actual: " ++ pprint actual ] [| return () |]) captureAvoidanceTest :: IO () captureAvoidanceTest = do let a = mkName "a" b = mkName "b" subst = Map.singleton b (VarT a) origTy = ForallT [plainTVSpecified a] [] (VarT b) substTy = applySubstitution subst origTy wrongTy = ForallT [plainTVSpecified a] [] (VarT a) when (substTy == wrongTy) $ fail $ "applySubstitution captures during substitution" #if MIN_VERSION_template_haskell(2,20,0) t100Test :: IO () t100Test = $(do let expectedInfo = DatatypeInfo { datatypeName = ''T100 , datatypeContext = [] , datatypeVars = [] , datatypeInstTypes = [] , datatypeVariant = Datatype.TypeData , datatypeCons = [ ConstructorInfo { constructorName = ''MkT100 , constructorContext = [] , constructorVars = [] , constructorFields = [] , constructorStrictness = [] , constructorVariant = NormalConstructor } ] } t100Info <- reifyDatatype ''T100 validateDI t100Info expectedInfo mkT100Info <- reifyDatatype ''MkT100 validateDI mkT100Info expectedInfo ) #endif th-abstraction-0.5.0.0/test/Types.hs0000644000000000000000000001270107346545000015405 0ustar0000000000000000{-# Language CPP, FlexibleContexts, TypeFamilies, KindSignatures, TemplateHaskell, GADTs, ScopedTypeVariables, TypeOperators #-} #if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE ConstraintKinds #-} #endif #if MIN_VERSION_template_haskell(2,8,0) {-# Language PolyKinds #-} #endif #if __GLASGOW_HASKELL__ >= 800 {-# Language DataKinds #-} # if __GLASGOW_HASKELL__ < 806 {-# Language TypeInType #-} # endif #endif #if MIN_VERSION_template_haskell(2,20,0) {-# Language TypeData #-} #endif {-| Module : Types Description : Test cases for the th-abstraction package Copyright : Eric Mertens 2017 License : ISC Maintainer : emertens@gmail.com This module defined types used for testing features of @th-abstraction@ on various versions of GHC. -} module Types where #if __GLASGOW_HASKELL__ >= 704 import GHC.Exts (Constraint) #endif import Language.Haskell.TH 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 #endif type Gadt1Int = Gadt1 Int infixr 6 :**: data Gadt1 (a :: *) where Gadtc1 :: Int -> Gadt1Int Gadtc2 :: (a,a) -> Gadt1 a (:**:) :: Bool -> Char -> Gadt1 () -- This is declared infix (:!!:) :: Char -> Bool -> Gadt1 Double -- This is not data Adt1 (a :: *) (b :: *) = Adtc1 (a,b) | Bool `Adtc2` Int data Gadtrec1 a where Gadtrecc1, Gadtrecc2 :: { gadtrec1a :: a, gadtrec1b :: b } -> Gadtrec1 (a,b) data Equal :: * -> * -> * -> * where Equalc :: (Read a, Show a) => [a] -> Maybe a -> Equal a a a data Showable :: * where Showable :: Show a => a -> Showable data R = R1 { field1, field2 :: Int } data Gadt2 :: * -> * -> * where Gadt2c1 :: Gadt2 a [a] Gadt2c2 :: Gadt2 [a] a Gadt2c3 :: Gadt2 [a] [a] data VoidStoS (f :: * -> *) data StrictDemo = StrictDemo Int !Int {-# UNPACK #-} !Int type (:+:) = Either data MyPair a b = a :^: b -- Data families data family T43Fam 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 :: *) data instance GadtFam c d where MkGadtFam1 :: x -> y -> GadtFam y x (:&&:) :: e -> f -> GadtFam [e] f -- This is declard infix (:^^:) :: Int -> Int -> GadtFam Int Int -- This is not (:#%:) :: { famRec1, famRec2 :: Bool } -> GadtFam Bool Bool -- Nor is this MkGadtFam4 :: (Int ~ z) => z -> GadtFam z z MkGadtFam5 :: (q ~ Char) => q -> GadtFam Bool Bool infixl 3 :&&:, :#%: data family FamLocalDec1 a data family FamLocalDec2 a b c data family T46 a b c data instance T46 (f (p :: *)) (f p) q = MkT46 q data family T73 a b data instance T73 Int b = MkT73 b 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) type PredSyn3 c = Int ~ c data PredSynT = 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 data T37b (a :: k) where MkT37b :: forall (a :: Bool). T37b a data T37c (a :: k) where MkT37c :: T37c Bool data Prox (a :: k) = Prox data T48 :: Type -> Type where MkT48 :: forall a (x :: a). Prox x -> T48 a 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 -- We must define these here due to Template Haskell staging restrictions justCI :: ConstructorInfo justCI = ConstructorInfo { constructorName = 'Just , constructorVars = [] , constructorContext = [] , constructorFields = [VarT (mkName "a")] , constructorStrictness = [notStrictAnnot] , constructorVariant = NormalConstructor } gadtRecVanillaCI :: ConstructorInfo gadtRecVanillaCI = ConstructorInfo { constructorName = 'Gadtrecc1 , constructorVars = [v1K, v2K] , constructorContext = [equalPred a (AppT (AppT (TupleT 2) (VarT v1)) (VarT v2))] , constructorFields = [VarT v1, VarT v2] , constructorStrictness = [notStrictAnnot, notStrictAnnot] , constructorVariant = RecordConstructor ['gadtrec1a, 'gadtrec1b] } where a = VarT (mkName "a") names@[v1,v2] = map mkName ["v1","v2"] [v1K,v2K] = map (\n -> kindedTV n starK) names #if MIN_VERSION_template_haskell(2,7,0) gadtRecFamCI :: ConstructorInfo gadtRecFamCI = ConstructorInfo { constructorName = '(:#%:) , constructorVars = [] , constructorContext = [ equalPred cTy (ConT ''Bool) , equalPred dTy (ConT ''Bool) ] , constructorFields = [ConT ''Bool, ConT ''Bool] , constructorStrictness = [notStrictAnnot, notStrictAnnot] , constructorVariant = RecordConstructor ['famRec1, 'famRec2] } where [cTy,dTy] = map (VarT . mkName) ["c", "d"] #endif th-abstraction-0.5.0.0/th-abstraction.cabal0000644000000000000000000000427407346545000016702 0ustar0000000000000000name: th-abstraction version: 0.5.0.0 synopsis: Nicer interface for reified information about data types description: This package normalizes variations in the interface for inspecting datatype information via Template Haskell so that packages and support a single, easier to use informational datatype while supporting many versions of Template Haskell. license: ISC license-file: LICENSE author: Eric Mertens maintainer: emertens@gmail.com copyright: 2017 Eric Mertens homepage: https://github.com/glguy/th-abstraction bug-reports: https://github.com/glguy/th-abstraction/issues category: Development 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 source-repository head type: git location: https://github.com/glguy/th-abstraction.git library 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 hs-source-dirs: src default-language: Haskell2010 if impl(ghc >= 9.0) -- these flags may abort compilation with GHC-8.10 -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/3295 ghc-options: -Winferred-safe-imports -Wmissing-safe-haskell-mode test-suite unit-tests other-modules: Harness Types type: exitcode-stdio-1.0 main-is: Main.hs build-depends: th-abstraction, base, containers, template-haskell hs-source-dirs: test default-language: Haskell2010 if impl(ghc >= 8.6) ghc-options: -Wno-star-is-type