th-abstraction 0.2.11.0 → 0.7.2.0
raw patch · 10 files changed
Files
- ChangeLog.md +260/−0
- LICENSE +1/−1
- README.md +2/−2
- src/Language/Haskell/TH/Datatype.hs +2274/−1873
- src/Language/Haskell/TH/Datatype/Internal.hs +14/−9
- src/Language/Haskell/TH/Datatype/TyVarBndr.hs +467/−0
- test/Harness.hs +41/−56
- test/Main.hs +767/−214
- test/Types.hs +47/−28
- th-abstraction.cabal +14/−6
ChangeLog.md view
@@ -1,5 +1,265 @@ # Revision history for th-abstraction +## 0.7.2.0 -- 2026.01.03+* Support GHC 9.14.++## 0.7.1.0 -- 2024.12.05+* Drop support for pre-8.0 versions of GHC.++## 0.7.0.0 -- 2024.03.17+* `DatatypeInfo` now has an additional `datatypeReturnKind` field. Most of the+ time, this will be `StarT`, but this can also be more exotic kinds such as+ `ConT ''UnliftedType` if dealing with primitive types, `UnliftedDatatypes`,+ or `UnliftedNewtypes`.+* `reifyDatatype` and related functions now support primitive types such as+ `Int#`. These will be reified as `DatatypeInfo`s with no `ConstructorInfo`s+ and with `Datatype` as the `datatypeVariant`.+* `normalizeCon` now takes a `Kind` argument representing the return kind of+ the parent data type. (This is sometimes necessary to determine which type+ variables in the data constructor are universal or existential, depending+ on if the variables appear in the return kind.)+* Fix a couple of bugs in which `normalizeDec` would return incorrect results+ for GADTs that use `forall`s in their return kind.++## 0.6.0.0 -- 2023.07.31+* Support building with `template-haskell-2.21.0.0` (GHC 9.8).+* Adapt to `TyVarBndr`s for type-level declarations changing their type from+ `TyVarBndr ()` to `TyVarBndr BndrVis` in `template-haskell`:++ * `Language.Haskell.TH.Datatype.TyVarBndr` now backports `type BndrVis = ()`,+ as well as `BndrReq` and `BndrInvis` pattern synonyms. These make it+ possible to write code involving `BndrVis` that is somewhat backwards+ compatible (but do see the caveats in the Haddocks for `BndrInvis`).+ * `Language.Haskell.TH.Datatype.TyVarBndr` also backports the following+ definitions:+ * The `type TyVarBndrVis = TyVarBndr BndrVis` type synonym.+ * The `DefaultBndrFlag` class, which can be used to write code that is+ polymorphic over `TyVarBndr` flags while still allowing the code to return+ a reasonable default value for the flag.+ * The `bndrReq` and `bndrInvis` definitions, which behave identically to+ `BndrReq` and `BndrInvis`.+ * `Language.Haskell.TH.Datatype.TyVarBndr` now defines the following utility+ functions, which are not present in `template-haskell`:+ * `plainTVReq`, `plainTVInvis`, `kindedTVReq`, and `kindedTVInvis`+ functions, which construct `PlainTV`s and `KindedTV`s with particular+ `BndrVis` flags.+ * An `elimTVFlag`, which behaves like `elimTV`, but where the continuation+ arguments also take a `flag` argument. (Note that the type of this+ function is slightly different on old versions of `template-haskell`.+ See the Haddocks for more.)+ * A `tvFlag` function, which extracts the `flag` from a `TyVarBndr`. (Note+ that the type of this function is slightly different on old versions of+ `template-haskell`. See the Haddocks for more.)+ * The types of the `dataDCompat` and `newtypeDCompat` functions have had+ their `[TyVarBndrUnit]` arguments changed to `[TyVarBndrVis]`, matching+ similar changes to `DataD` and `NewtypeD` in `template-haskell`.++ Because `BndrVis` is a synonym for `()` on pre-9.8 versions of GHC, this+ change is unlikely to break any existing code, provided that you build it+ with GHC 9.6 or earlier. If you build with GHC 9.8 or later, on the other+ hand, it is likely that you will need to update your existing code. Here are+ some possible ways that your code might fail to compile with GHC 9.8, along+ with some migration strategies:++ * Your code passes a `TyVarBndrUnit` in a place where a `TyVarBndrVis` is now+ expected in GHC 9.8, such as in the arguments to `dataDCompat`:++ ```hs+ import "template-haskell" Language.Haskell.TH+ import "th-abstraction" Language.Haskell.TH.Datatype (dataDCompat)++ dec :: DecQ+ dec = dataDCompat (pure []) d [PlainTV a ()] [] []+ where+ d = mkName "d"+ a = mkName "a"+ ```++ With GHC 9.8, this will fail to compile with:++ ```+ error: [GHC-83865]+ • Couldn't match expected type ‘BndrVis’ with actual type ‘()’+ • In the second argument of ‘PlainTV’, namely ‘()’+ In the expression: PlainTV a ()+ In the third argument of ‘dataDCompat’, namely ‘[PlainTV a ()]’+ |+ | dec = dataDCompat (pure []) d [PlainTV a ()] [] []+ | ^^+ ```++ Some possible ways to migrate this code include:++ * Use the `bndrReq` function or `BndrReq` pattern synonym in place of `()`,+ making sure to import them from `Language.Haskell.TH.Datatype.TyVarBndr`:++ ```hs+ ...+ import "th-abstraction" Language.Haskell.TH.Datatype.TyVarBndr++ dec :: DecQ+ dec = dataDCompat (pure []) d [PlainTV a bndrReq] [] []+ -- Or, alternatively:+ {-+ dec = dataDCompat (pure []) d [PlainTV a BndrReq] [] []+ -}+ where+ ...+ ```+ * Use the `plainTV` function from `Language.Haskell.TH.Datatype.TyVarBndr`,+ which is now sufficiently polymorphic to work as both a `TyVarBndrUnit`+ and a `TyVarBndrVis`:++ ```hs+ ...+ import Language.Haskell.TH.Datatype.TyVarBndr++ dec :: DecQ+ dec = dataDCompat (pure []) d [plainTV a] [] []+ where+ ...+ ```+ * You may have to replace some uses of `TyVarBndrUnit` with `TyVarBndrVis`+ in your code. For instance, this will no longer typecheck in GHC 9.8 for+ similar reasons to the previous example:++ ```hs+ import "template-haskell" Language.Haskell.TH+ import "th-abstraction" Language.Haskell.TH.Datatype (dataDCompat)++ dec :: DecQ+ dec = dataDCompat (pure []) d tvbs [] []+ where+ tvbs :: [TyVarBndrUnit]+ tvbs = [plainTV a]++ d = mkName "d"+ a = mkName "a"+ ```++ Here is a version that will typecheck with GHC 9.8 and earlier:++ ```hs+ ...+ import "th-abstraction" Language.Haskell.TH.Datatype.TyVarBndr++ dec :: DecQ+ dec = dataDCompat (pure []) d tvbs [] []+ where+ tvbs :: [TyVarBndrVis]+ tvbs = [plainTV a]++ ...+ ```+ * In some cases, the `TyVarBndrUnit`s might come from another place in the+ code, e.g.,++ ```hs+ import "template-haskell" Language.Haskell.TH+ import "th-abstraction" Language.Haskell.TH.Datatype (dataDCompat)++ dec :: [TyVarBndrUnit] -> DecQ+ dec tvbs = dataDCompat (pure []) d tvbs [] []+ where+ d = mkName "d"+ ```++ If it is not straightforward to change `dec`'s type to accept+ `[TyVarBndrVis]` as an argument, another viable option is to use the+ `changeTVFlags` function:++ ```hs+ ...+ import "th-abstraction" Language.Haskell.TH.Datatype.TyVarBndr++ dec :: [TyVarBndrUnit] -> DecQ+ dec tvbs = dataDCompat (pure []) d tvbs' [] []+ where+ tvbs' :: [TyVarBndrVis]+ tvbs' = changeTVFlags bndrReq tvbs++ ...+ ```++ This guide, while not comprehensive, should cover most of the common cases one+ will encounter when migrating their `th-abstraction` code to support GHC 9.8.++## 0.5.0.0 -- 2023.02.27+* Support the `TypeData` language extension added in GHC 9.6. The+ `DatatypeVariant` data type now has a separate `TypeData` constructor to+ 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`.
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2017 Eric Mertens+Copyright (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
README.md view
@@ -1,7 +1,7 @@ th-abstraction ============== -[](https://hackage.haskell.org/package/th-abstraction) [](http://travis-ci.org/glguy/th-abstraction)+[](https://hackage.haskell.org/package/th-abstraction) [](https://github.com/glguy/th-abstraction/actions?query=workflow%3AHaskell-CI) This package provides a consistent interface to a subset of Template Haskell. @@ -13,4 +13,4 @@ Contact Information ------------------- -Please contact me via GitHub or on the #haskell IRC channel on irc.freenode.net+Please contact me via GitHub or on the #haskell IRC channel on irc.libera.chat
src/Language/Haskell/TH/Datatype.hs view
@@ -1,1876 +1,2277 @@-{-# Language CPP, DeriveDataTypeable #-}--#if MIN_VERSION_base(4,4,0)-#define HAS_GENERICS-{-# Language DeriveGeneric #-}-#endif--{-|-Module : Language.Haskell.TH.Datatype-Description : Backwards-compatible interface to reified information about datatypes.-Copyright : Eric Mertens 2017-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' = [ '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 (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.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.------ 'datatypeVars' types will have an outermost 'SigT' to indicate the--- parameter's kind. These types will be simple variables for /ADT/s--- declared with @data@ and @newtype@, but can be more complex for--- types declared with @data instance@ and @newtype instance@.-data DatatypeInfo = DatatypeInfo- { datatypeContext :: Cxt -- ^ Data type context (deprecated)- , datatypeName :: Name -- ^ Type constructor- , datatypeVars :: [Type] -- ^ Type parameters- , 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@- | DataInstance -- ^ Type declared with @data instance@- | NewtypeInstance -- ^ Type declared with @newtype instance@- deriving (Show, Read, Eq, Ord, Typeable, Data-#ifdef HAS_GENERICS- ,Generic-#endif- )---- | Normalized information about constructors associated with newtypes and--- data types.-data ConstructorInfo = ConstructorInfo- { constructorName :: Name -- ^ Constructor name- , constructorVars :: [TyVarBndr] -- ^ Constructor type parameters- , constructorContext :: Cxt -- ^ Constructor constraints- , constructorFields :: [Type] -- ^ Constructor fields- , 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- $ datatypeVars 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 let instances1 = map (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' :: [TyVarBndr] -> [Type] -> [Type]-repairVarKindsWith' dvars 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 applySubstitution (Map.fromList (zip kparams tsKinds')) $- repairVarKindsWith dvars 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 -} ->- Dec {- ^ instance declaration -}--repairDataFam- (FamilyD _ _ dvars _)- (NewtypeInstD cx n ts con deriv) =- NewtypeInstD cx n (repairVarKindsWith' dvars ts) con deriv-repairDataFam- (FamilyD _ _ dvars _)- (DataInstD cx n ts cons deriv) =- DataInstD cx n (repairVarKindsWith' dvars ts) cons deriv-#else-repairDataFam famD instD-# if MIN_VERSION_template_haskell(2,11,0)- | DataFamilyD _ dvars _ <- famD- , NewtypeInstD cx n ts k c deriv <- instD- = NewtypeInstD cx n (repairVarKindsWith dvars ts) k c deriv-- | DataFamilyD _ dvars _ <- famD- , DataInstD cx n ts k c deriv <- instD- = DataInstD cx n (repairVarKindsWith dvars ts) k c deriv-# else- | FamilyD _ _ dvars _ <- famD- , NewtypeInstD cx n ts c deriv <- instD- = NewtypeInstD cx n (repairVarKindsWith dvars ts) c deriv-- | FamilyD _ _ dvars _ <- famD- , DataInstD cx n ts c deriv <- instD- = DataInstD cx n (repairVarKindsWith dvars ts) c deriv-# endif-#endif-repairDataFam _ instD = instD--repairVarKindsWith :: [TyVarBndr] -> [Type] -> [Type]-repairVarKindsWith = zipWith stealKindForType---- If a VarT is missing an explicit kind signature, steal it from a TyVarBndr.-stealKindForType :: TyVarBndr -> Type -> Type-stealKindForType tvb t@VarT{} = SigT t (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,12,0)- NewtypeD context name tyvars _kind con _derives ->- giveTypesStarKinds <$> normalizeDec' isReified context name (bndrParams tyvars) [con] Newtype- DataD context name tyvars _kind cons _derives ->- giveTypesStarKinds <$> normalizeDec' isReified context name (bndrParams tyvars) cons Datatype- NewtypeInstD context name params _kind con _derives ->- repair13618' . giveTypesStarKinds =<<- normalizeDec' isReified context name params [con] NewtypeInstance- DataInstD context name params _kind cons _derives ->- repair13618' . giveTypesStarKinds =<<- normalizeDec' isReified context name params cons DataInstance-#elif MIN_VERSION_template_haskell(2,11,0)- NewtypeD context name tyvars _kind con _derives ->- giveTypesStarKinds <$> normalizeDec' isReified context name (bndrParams tyvars) [con] Newtype- DataD context name tyvars _kind cons _derives ->- giveTypesStarKinds <$> normalizeDec' isReified context name (bndrParams tyvars) cons Datatype- NewtypeInstD context name params _kind con _derives ->- repair13618' . giveTypesStarKinds =<<- normalizeDec' isReified context name params [con] NewtypeInstance- DataInstD context name params _kind cons _derives ->- repair13618' . giveTypesStarKinds =<<- normalizeDec' isReified context name params cons DataInstance-#else- NewtypeD context name tyvars con _derives ->- giveTypesStarKinds <$> normalizeDec' isReified context name (bndrParams tyvars) [con] Newtype- DataD context name tyvars cons _derives ->- giveTypesStarKinds <$> normalizeDec' isReified context name (bndrParams tyvars) cons Datatype- NewtypeInstD context name params con _derives ->- repair13618' . giveTypesStarKinds =<<- normalizeDec' isReified context name params [con] NewtypeInstance- DataInstD context name params cons _derives ->- repair13618' . giveTypesStarKinds =<<- normalizeDec' isReified context name params cons DataInstance-#endif- _ -> fail "normalizeDecFor: DataD or NewtypeD required"- where- repair13618' | isReified = repair13618- | otherwise = return--bndrParams :: [TyVarBndr] -> [Type]-bndrParams = map $ \bndr ->- case bndr of- KindedTV t k -> SigT (VarT t) k- PlainTV t -> VarT t---- | Extract the kind from a 'TyVarBndr'. Assumes 'PlainTV' has kind @*@.-tvKind :: TyVarBndr -> Kind-tvKind (PlainTV _) = starK-tvKind (KindedTV _ k) = 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 -} ->- [Type] {- ^ Type parameters -} ->- [Con] {- ^ Constructors -} ->- DatatypeVariant {- ^ Extra information -} ->- Q DatatypeInfo-normalizeDec' reifiedDec context name params cons variant =- do cons' <- concat <$> mapM (normalizeConFor reifiedDec name params variant) cons- return DatatypeInfo- { datatypeContext = context- , datatypeName = name- , datatypeVars = params- , 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 -} ->- [Type] {- ^ Type parameters -} ->- DatatypeVariant {- ^ Extra information -} ->- Con {- ^ Constructor -} ->- Q [ConstructorInfo]-normalizeCon = normalizeConFor isn'tReified--normalizeConFor ::- IsReifiedDec {- ^ Is this a reified 'Dec'? -} ->- Name {- ^ Type constructor -} ->- [Type] {- ^ Type parameters -} ->- DatatypeVariant {- ^ Extra information -} ->- Con {- ^ Constructor -} ->- Q [ConstructorInfo]-normalizeConFor reifiedDec typename params variant = fmap (map giveTyVarBndrsStarKinds) . dispatch- where- -- A GADT constructor is declared infix when:- --- -- 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 :: [TyVarBndr]- -> Cxt- -> Bool -- Is this a GADT? (see the documentation for- -- for checkGadtFixity)- -> Con- -> Q [ConstructorInfo]- go tyvars context gadt c =- case c of- NormalC n xs -> do- let (bangs, ts) = unzip xs- stricts = map normalizeStrictness bangs- fi <- if gadt- then checkGadtFixity ts n- else return NormalConstructor- return [ConstructorInfo n tyvars context ts stricts fi]- InfixC l n r ->- let (bangs, ts) = unzip [l,r]- stricts = map normalizeStrictness bangs in- return [ConstructorInfo n tyvars context ts stricts- InfixConstructor]- RecC n xs ->- let fns = takeFieldNames xs- stricts = takeFieldStrictness xs in- return [ConstructorInfo n tyvars context- (takeFieldTypes xs) stricts (RecordConstructor fns)]- ForallC tyvars' context' c' ->- go (tyvars'++tyvars) (context'++context) True c'-#if MIN_VERSION_template_haskell(2,11,0)- GadtC ns xs innerType ->- let (bangs, ts) = unzip xs- stricts = map normalizeStrictness bangs in- gadtCase ns innerType ts stricts (checkGadtFixity ts)- RecGadtC ns xs innerType ->- let fns = takeFieldNames xs- stricts = takeFieldStrictness xs in- gadtCase ns innerType (takeFieldTypes xs) stricts- (const $ return $ RecordConstructor fns)- where- gadtCase = normalizeGadtC typename params tyvars context-#endif-#if MIN_VERSION_template_haskell(2,8,0) && (!MIN_VERSION_template_haskell(2,10,0))- dataFamCompatCase :: Con -> Q [ConstructorInfo]- dataFamCompatCase = go []- where- go tyvars c =- case c of- NormalC n xs ->- let stricts = map (normalizeStrictness . fst) xs in- dataFamCase' n tyvars stricts NormalConstructor- InfixC l n r ->- let stricts = map (normalizeStrictness . fst) [l,r] in- dataFamCase' n tyvars stricts InfixConstructor- RecC n xs ->- let stricts = takeFieldStrictness xs in- dataFamCase' n tyvars stricts- (RecordConstructor (takeFieldNames xs))- ForallC tyvars' context' c' ->- go (tyvars'++tyvars) c'-- dataFamCase' :: Name -> [TyVarBndr] -> [FieldStrictness]- -> ConstructorVariant- -> Q [ConstructorInfo]- dataFamCase' n tyvars stricts variant = do- mbInfo <- reifyMaybe n- case mbInfo of- Just (DataConI _ ty _ _) -> do- let (context, argTys :|- returnTy) = uncurryType ty- returnTy' <- resolveTypeSynonyms returnTy- -- Notice that we've ignored the Cxt and argument Types from the- -- Con argument above, as they might be scoped over eta-reduced- -- variables. Instead of trying to figure out what the- -- eta-reduced variables should be substituted with post facto,- -- we opt for the simpler approach of using the context and- -- argument types from the reified constructor Info, which will- -- at least be correctly scoped. This will make the task of- -- substituting those types with the variables we put in- -- place of the eta-reduced variables (in normalizeDec)- -- much easier.- normalizeGadtC typename params tyvars context [n]- returnTy' argTys stricts (const $ return variant)- _ -> fail $ 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 params- -> dataFamCompatCase- NewtypeInstance- | reifiedDec, mightHaveBeenEtaReduced params- -> 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 -} ->- [Type] {- ^ Type parameters -} ->- [TyVarBndr] {- ^ Constructor parameters -} ->- Cxt {- ^ Constructor context -} ->- [Name] {- ^ Constructor names -} ->- Type {- ^ Declared type of constructor -} ->- [Type] {- ^ Constructor field types -} ->- [FieldStrictness] {- ^ Constructor field strictness -} ->- (Name -> Q ConstructorVariant)- {- ^ Determine a constructor variant- from its 'Name' -} ->- Q [ConstructorInfo]-normalizeGadtC typename params tyvars context names innerType- fields stricts getVariant =- do -- 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)) tyvars- conSubst <- T.sequence $ Map.fromList [ (n, newName (nameBase n))- | n <- conBoundNames ]- let conSubst' = fmap VarT conSubst- renamedTyvars =- map (\tvb -> case tvb of- PlainTV n -> PlainTV (conSubst Map.! n)- KindedTV n k -> KindedTV (conSubst Map.! n)- (applySubstitution conSubst' k)) tyvars- 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)- (kindsOfFVsOfTypes params)- (mergeArguments params ts)- subst = VarT <$> substName- exTyvars = [ tv | tv <- renamedTyvars, Map.notMember (tvName tv) subst ]-- exTyvars' = substTyVarBndrs 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 (ForallT {}) = error "`forall` type used in data family pattern"- 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 _ = Map.empty---- 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] -> Map Name Kind-kindsOfFVsOfTvbs = foldMap go- where- go :: TyVarBndr -> Map Name Kind- go (PlainTV n) = Map.singleton n starK- go (KindedTV 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 = decomposeType t-- notTypeSynCase :: Type -> Q Type- notTypeSynCase ty = foldl AppT ty <$> mapM resolveTypeSynonyms 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))- -> resolveTypeSynonyms $ expandSynonymRHS synvars xs def- _ -> notTypeSynCase 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- notTypeSynCase $ SigT ty' ki'- ConT n -> expandCon n (ConT n)-#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- _ -> notTypeSynCase f---- | 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 -> Q TyVarBndr-resolve_tvb_syns tvb@PlainTV{} = return tvb-resolve_tvb_syns (KindedTV n k) = KindedTV n <$> resolveKindSynonyms k--expandSynonymRHS ::- [TyVarBndr] {- ^ Substitute these variables... -} ->- [Type] {- ^ ...with these types... -} ->- Type {- ^ ...inside of this type. -} ->- Type-expandSynonymRHS synvars ts def =- let argNames = map tvName synvars- (args,rest) = splitAt (length argNames) ts- subst = Map.fromList (zip argNames args)- in foldl AppT (applySubstitution subst def) rest---- | Expand all of the type synonyms in a 'Pred'.-resolvePredSynonyms :: Pred -> Q Pred-#if MIN_VERSION_template_haskell(2,10,0)-resolvePredSynonyms = resolveTypeSynonyms-#else-resolvePredSynonyms (ClassP n ts) = do- mbInfo <- reifyMaybe n- case mbInfo of- Just (TyConI (TySynD _ synvars def))- -> resolvePredSynonyms $ typeToPred $ expandSynonymRHS synvars ts def- _ -> ClassP n <$> mapM resolveTypeSynonyms ts-resolvePredSynonyms (EqualP t1 t2) = do- t1' <- resolveTypeSynonyms t1- t2' <- resolveTypeSynonyms t2- return (EqualP t1' t2')--typeToPred :: Type -> Pred-typeToPred t =- let f :| xs = decomposeType t in- case f of- ConT n- | n == eqTypeName-# if __GLASGOW_HASKELL__ == 704- -- There's an unfortunate bug in GHC 7.4 where the (~) type is reified- -- with an explicit kind argument. To work around this, we ignore it.- , [_,t1,t2] <- xs-# else- , [t1,t2] <- xs-# endif- -> EqualP t1 t2- | otherwise- -> ClassP n xs- _ -> error $ "typeToPred: Can't handle type " ++ show t-#endif---- | Decompose a type into a list of it's outermost applications. This process--- forgets about infix application and explicit parentheses.------ 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 = go []- where- go args (AppT f x) = go (x:args) f-#if MIN_VERSION_template_haskell(2,11,0)- go args (ParensT t) = go args t-#endif- go args t = t :| args---- '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 types. For instance, this------ (Show a, b ~ Int) => (a -> b) -> Char -> Int------ becomes------ ([Show a, b ~ Int], [a -> b, Char] :|- Int)-uncurryType :: Type -> (Cxt, NonEmptySnoc Type)-uncurryType = go [] []- where- go ctxt args (AppT (AppT ArrowT t1) t2) = go ctxt (t1:args) t2- go ctxt args (ForallT _ ctxt' t) = go (ctxt++ctxt') args t- go ctxt args t = (ctxt, reverse args :|- t)---- | Resolve any infix type application in a type using the fixities that--- are currently available. Starting in `template-haskell-2.11` types could--- contain unresolved infix applications.-resolveInfixT :: Type -> Q Type--#if MIN_VERSION_template_haskell(2,11,0)-resolveInfixT (ForallT vs cx t) = forallT vs (mapM resolveInfixT cx) (resolveInfixT t)-resolveInfixT (f `AppT` x) = resolveInfixT f `appT` resolveInfixT x-resolveInfixT (ParensT t) = resolveInfixT t-resolveInfixT (InfixT l o r) = conT o `appT` resolveInfixT l `appT` resolveInfixT r-resolveInfixT (SigT t k) = SigT <$> resolveInfixT t <*> resolveInfixT k-resolveInfixT t@UInfixT{} = resolveInfixT =<< resolveInfixT1 (gatherUInfixT t)-resolveInfixT t = return t--gatherUInfixT :: Type -> InfixList-gatherUInfixT (UInfixT l o r) = ilAppend (gatherUInfixT l) o (gatherUInfixT r)-gatherUInfixT t = ILNil t---- This can fail due to incompatible fixities-resolveInfixT1 :: InfixList -> TypeQ-resolveInfixT1 = go []- where- go :: [(Type,Name,Fixity)] -> InfixList -> TypeQ- go ts (ILNil u) = return (foldl (\acc (l,o,_) -> ConT o `AppT` l `AppT` acc) u ts)- go ts (ILCons l o r) =- do ofx <- fromMaybe defaultFixity <$> reifyFixityCompat o- let push = go ((l,o,ofx):ts) r- case ts of- (l1,o1,o1fx):ts' ->- case compareFixity o1fx ofx of- Just True -> go ((ConT o1 `AppT` l1 `AppT` l, o, ofx):ts') r- Just False -> push- Nothing -> fail (precedenceError o1 o1fx o ofx)- _ -> push-- 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 Name InfixList | ILNil Type--ilAppend :: InfixList -> Name -> InfixList -> InfixList-ilAppend (ILNil l) o r = ILCons l o r-ilAppend (ILCons l1 o1 r1) o r = ILCons l1 o1 (ilAppend r1 o 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"----- | Extract the type variable name from a 'TyVarBndr' ignoring the--- kind signature if one exists.-tvName :: TyVarBndr -> Name-tvName (PlainTV name ) = name-tvName (KindedTV name _) = name--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 = 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] -> [TyVarBndr]-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- 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.- --- -- Note that 'applySubstitution' is /not/ capture-avoiding. To illustrate- -- this, observe that if you call this function with the following- -- substitution:- --- -- * @b :-> a@- --- -- On the following 'Type':- --- -- * @forall a. b@- --- -- Then it will return:- --- -- * @forall a. a@- --- -- However, because the same @a@ type variable was used in the range of the- -- substitution as was bound by the @forall@, the substituted @a@ is now- -- captured by the @forall@, resulting in a completely different function.- --- -- For @th-abstraction@'s purposes, this is acceptable, as it usually only- -- deals with globally unique type variable 'Name's. If you use- -- 'applySubstitution' in a context where the 'Name's aren't globally unique,- -- however, be aware of this potential problem.- 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' = foldl' (flip Map.delete) subst (map tvName tvs)-- mapTvbKind :: (Kind -> Kind) -> TyVarBndr -> TyVarBndr- mapTvbKind f (PlainTV n) = PlainTV n- mapTvbKind f (KindedTV n k) = KindedTV n (f k) in- ForallT (map (mapTvbKind (applySubstitution subst')) 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- go t = t-- freeVariables t =- case t of- ForallT tvs context t' ->- (concatMap (freeVariables . tvKind) tvs- `union` freeVariables context- `union` freeVariables t')- \\ map tvName tvs- 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- _ -> []--instance TypeSubstitution ConstructorInfo where- freeVariables ci =- (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 { 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.--- Not capture-avoiding.-substTyVarBndrs :: Map Name Type -> [TyVarBndr] -> [TyVarBndr]-substTyVarBndrs subst = map go- where- go tvb@(PlainTV {}) = tvb- go (KindedTV n k) = KindedTV n (applySubstitution subst k)----------------------------------------------------------------------------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 types without a signature.--giveTypesStarKinds :: DatatypeInfo -> DatatypeInfo-giveTypesStarKinds info =- info { datatypeVars = annotateVars (datatypeVars info) }- where- annotateVars :: [Type] -> [Type]- annotateVars = map $ \t ->- case t of- VarT n -> SigT (VarT n) starK- _ -> t--giveTyVarBndrsStarKinds :: ConstructorInfo -> ConstructorInfo-giveTyVarBndrsStarKinds info =- info { constructorVars = annotateVars (constructorVars info) }- where- annotateVars :: [TyVarBndr] -> [TyVarBndr]- annotateVars = map $ \tvb ->- case tvb of- PlainTV n -> KindedTV n starK- _ -> tvb---- | Prior to GHC 8.2.1, reify was broken for data instances and newtype--- instances. This code attempts to detect the problem and repair it if--- possible.------ 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 = freeVariables (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 -} ->- [TyVarBndr] {- ^ 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 -} ->- [TyVarBndr] {- ^ 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 -} ->- [TypeQ] {- ^ instance parameters -} ->- TypeQ {- ^ instance result -} ->- DecQ-#if MIN_VERSION_template_haskell(2,9,0)-tySynInstDCompat n ps r = TySynInstD n <$> (TySynEqn <$> sequence ps <*> r)-#else-tySynInstDCompat = tySynInstD-#endif---- | Backward compatible version of 'pragLineD'. Returns--- 'Nothing' if line pragmas are not suported.-pragLineDCompat ::- Int {- ^ line number -} ->- String {- ^ file name -} ->- Maybe DecQ-#if MIN_VERSION_template_haskell(2,10,0)-pragLineDCompat ln fn = Just (pragLineD ln fn)-#else-pragLineDCompat _ _ = Nothing-#endif--arrowKCompat :: Kind -> Kind -> Kind-#if MIN_VERSION_template_haskell(2,8,0)-arrowKCompat x y = arrowK `appK` x `appK` y-#else-arrowKCompat = arrowK-#endif------------------------------------------------------------------------------ | Backwards compatibility wrapper for 'Fixity' lookup.------ In @template-haskell-2.11.0.0@ and later, the answer will always--- be 'Just' of a fixity.------ Before @template-haskell-2.11.0.0@ it was only possible to determine--- fixity information for variables, class methods, and data constructors.--- In this case for type operators the answer could be 'Nothing', which--- indicates that the answer is unavailable.-reifyFixityCompat :: Name -> Q (Maybe Fixity)-#if MIN_VERSION_template_haskell(2,11,0)-reifyFixityCompat n = recover (return Nothing) ((`mplus` Just defaultFixity) <$> reifyFixity n)-#else-reifyFixityCompat n = recover (return Nothing) $- do info <- reify n- return $! case info of- ClassOpI _ _ _ fixity -> Just fixity- DataConI _ _ _ fixity -> Just fixity- VarI _ _ _ fixity -> Just fixity- _ -> Nothing-#endif+{-# Language CPP, DeriveDataTypeable, DeriveGeneric, ScopedTypeVariables, TupleSections #-}++#if MIN_VERSION_template_haskell(2,12,0)+{-# Language Safe #-}+#else+{-# Language Trustworthy #-}+#endif++{-|+Module : Language.Haskell.TH.Datatype+Description : Backwards-compatible interface to reified information about datatypes.+Copyright : Eric Mertens 2017-2020+License : ISC+Maintainer : emertens@gmail.com++This module provides a flattened view of information about data types+and newtypes that can be supported uniformly across multiple versions+of the @template-haskell@ package.++Sample output for @'reifyDatatype' ''Maybe@++@+'DatatypeInfo'+ { 'datatypeContext' = []+ , 'datatypeName' = GHC.Base.Maybe+ , 'datatypeVars' = [ 'KindedTV' a_3530822107858468866 () 'StarT' ]+ , 'datatypeInstTypes' = [ 'SigT' ('VarT' a_3530822107858468866) 'StarT' ]+ , 'datatypeVariant' = 'Datatype'+ , 'datatypeReturnKind' = 'StarT'+ , 'datatypeCons' =+ [ 'ConstructorInfo'+ { 'constructorName' = GHC.Base.Nothing+ , 'constructorVars' = []+ , 'constructorContext' = []+ , 'constructorFields' = []+ , 'constructorStrictness' = []+ , 'constructorVariant' = 'NormalConstructor'+ }+ , 'ConstructorInfo'+ { 'constructorName' = GHC.Base.Just+ , 'constructorVars' = []+ , 'constructorContext' = []+ , 'constructorFields' = [ 'VarT' a_3530822107858468866 ]+ , 'constructorStrictness' = [ 'FieldStrictness'+ 'UnspecifiedUnpackedness'+ 'Lazy'+ ]+ , 'constructorVariant' = 'NormalConstructor'+ }+ ]+ }+@++Datatypes declared with GADT syntax are normalized to constructors with existentially+quantified type variables and equality constraints.++-}+module Language.Haskell.TH.Datatype+ (+ -- * Types+ DatatypeInfo(..)+ , ConstructorInfo(..)+ , DatatypeVariant(..)+ , ConstructorVariant(..)+ , FieldStrictness(..)+ , Unpackedness(..)+ , Strictness(..)++ -- * Normalization functions+ , reifyDatatype+ , reifyConstructor+ , reifyRecord+ , normalizeInfo+ , normalizeDec+ , normalizeCon++ -- * 'DatatypeInfo' lookup functions+ , lookupByConstructorName+ , lookupByRecordName++ -- * Type variable manipulation+ , TypeSubstitution(..)+ , quantifyType+ , freeVariablesWellScoped+ , freshenFreeVariables++ -- * 'Pred' functions+ , equalPred+ , classPred+ , asEqualPred+ , asClassPred++ -- * Backward compatible data definitions+ , dataDCompat+ , newtypeDCompat+ , tySynInstDCompat+ , pragLineDCompat+ , arrowKCompat++ -- * Strictness annotations+ , isStrictAnnot+ , notStrictAnnot+ , unpackedAnnot++ -- * Type simplification+ , resolveTypeSynonyms+ , resolveKindSynonyms+ , resolvePredSynonyms+ , resolveInfixT++ -- * Fixities+ , reifyFixityCompat+ , showFixity+ , showFixityDirection++ -- * Convenience functions+ , unifyTypes+ , tvName+ , tvKind+ , datatypeType+ ) where++import Control.Monad+import Data.Data (Data)+import Data.Foldable (foldMap, foldl')+import Data.List (mapAccumL, nub, find, union, (\\))+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe+import qualified Data.Set as Set+import Data.Set (Set)+import qualified Data.Traversable as T+import GHC.Generics (Generic)+import Language.Haskell.TH hiding (Extension(..))+import Language.Haskell.TH.Datatype.Internal+import Language.Haskell.TH.Datatype.TyVarBndr+import Language.Haskell.TH.Lib (arrowK, starK) -- needed for th-2.4++-- | Normalized information about newtypes and data types.+--+-- 'DatatypeInfo' contains two fields, 'datatypeVars' and 'datatypeInstTypes',+-- which encode information about the argument types. The simplest explanation+-- is that 'datatypeVars' contains all the type /variables/ bound by the data+-- type constructor, while 'datatypeInstTypes' contains the type /arguments/+-- to the data type constructor. To be more precise:+--+-- * For ADTs declared with @data@ and @newtype@, it will likely be the case+-- that 'datatypeVars' and 'datatypeInstTypes' coincide. For instance, given+-- @newtype Id a = MkId a@, in the 'DatatypeInfo' for @Id@ we would+-- have @'datatypeVars' = ['KindedTV' a () 'StarT']@ and+-- @'datatypeInstVars' = ['SigT' ('VarT' a) 'StarT']@.+--+-- ADTs that leverage @PolyKinds@ may have more 'datatypeVars' than+-- 'datatypeInstTypes'. For instance, given @data Proxy (a :: k) = MkProxy@,+-- in the 'DatatypeInfo' for @Proxy@ we would have+-- @'datatypeVars' = ['KindedTV' k () 'StarT', 'KindedTV' a () ('VarT' k)]@+-- (since there are two variables, @k@ and @a@), whereas+-- @'datatypeInstTypes' = ['SigT' ('VarT' a) ('VarT' k)]@, since there is+-- only one explicit type argument to @Proxy@.+--+-- The same outcome would occur if @Proxy@ were declared using+-- @TypeAbstractions@, i.e., if it were declared as+-- @data Proxy \@k (a :: k) = MkProxy@. The 'datatypeInstTypes' would /not/+-- include a separate type for @\@k@.+--+-- * For @data instance@s and @newtype instance@s of data families,+-- 'datatypeVars' and 'datatypeInstTypes' can be quite different. Here is+-- an example to illustrate the difference:+--+-- @+-- data family F a b+-- data instance F (Maybe c) (f x) = MkF c (f x)+-- @+--+-- Then in the 'DatatypeInfo' for @F@'s data instance, we would have:+--+-- @+-- 'datatypeVars' = [ 'KindedTV' c () 'StarT'+-- , 'KindedTV' f () 'StarT'+-- , 'KindedTV' x () 'StarT' ]+-- 'datatypeInstTypes' = [ 'AppT' ('ConT' ''Maybe) ('VarT' c)+-- , 'AppT' ('VarT' f) ('VarT' x) ]+-- @+data DatatypeInfo = DatatypeInfo+ { datatypeContext :: Cxt -- ^ Data type context (deprecated)+ , datatypeName :: Name -- ^ Type constructor+ , datatypeVars :: [TyVarBndrUnit] -- ^ Type parameters+ , datatypeInstTypes :: [Type] -- ^ Argument types+ , datatypeVariant :: DatatypeVariant -- ^ Extra information+ , datatypeReturnKind:: Kind -- ^ Return 'Kind' of the type.+ --+ -- If normalization is unable to determine the return kind,+ -- then this is conservatively set to @StarT@.+ , datatypeCons :: [ConstructorInfo] -- ^ Normalize constructor information+ }+ deriving (Show, Eq, Data, Generic)++-- | Possible variants of data type declarations.+data DatatypeVariant+ = Datatype -- ^ Type declared with @data@ or a primitive datatype.+ | Newtype -- ^ Type declared with @newtype@.+ --+ -- A 'DatatypeInfo' that uses 'Newtype' will uphold the+ -- invariant that there will be exactly one+ -- 'ConstructorInfo' in the 'datatypeCons'.+ | DataInstance -- ^ Type declared with @data instance@.+ | NewtypeInstance -- ^ Type declared with @newtype instance@.+ --+ -- A 'DatatypeInfo' that uses 'NewtypeInstance' will+ -- uphold the invariant that there will be exactly one+ -- 'ConstructorInfo' in the 'datatypeCons'.+ | TypeData -- ^ Type declared with @type data@.+ --+ -- A 'DatatypeInfo' that uses 'TypeData' will uphold the+ -- following invariants:+ --+ -- * The 'datatypeContext' will be empty.+ --+ -- * None of the 'constructorVariant's in any of the+ -- 'datatypeCons' will be 'RecordConstructor'.+ --+ -- * Each of the 'constructorStrictness' values in each+ -- of the 'datatypeCons' will be equal to+ -- 'notStrictAnnot'.+ deriving (Show, Read, Eq, Ord, Data, Generic)++-- | Normalized information about constructors associated with newtypes and+-- data types.+data ConstructorInfo = ConstructorInfo+ { constructorName :: Name -- ^ Constructor name+ , constructorVars :: [TyVarBndrUnit] -- ^ Constructor type parameters+ , constructorContext :: Cxt -- ^ Constructor constraints+ , constructorFields :: [Type] -- ^ Constructor fields+ , constructorStrictness :: [FieldStrictness] -- ^ Constructor fields' strictness+ -- (Invariant: has the same length+ -- as constructorFields)+ , constructorVariant :: ConstructorVariant -- ^ Extra information+ }+ deriving (Show, Eq, Data, Generic)++-- | Possible variants of data constructors.+data ConstructorVariant+ = NormalConstructor -- ^ Constructor without field names+ | InfixConstructor -- ^ Constructor without field names that is+ -- declared infix+ | RecordConstructor [Name] -- ^ Constructor with field names+ deriving (Show, Eq, Ord, Data, Generic)++-- | Normalized information about a constructor field's @UNPACK@ and+-- strictness annotations.+--+-- Note that the interface for reifying strictness in Template Haskell changed+-- considerably in GHC 8.0. The presentation in this library mirrors that which+-- can be found in GHC 8.0 or later, whereas previously, unpackedness and+-- strictness were represented with a single data type:+--+-- @+-- data Strict+-- = IsStrict+-- | NotStrict+-- | Unpacked -- On GHC 7.4 or later+-- @+--+-- For backwards compatibility, we retrofit these constructors onto the+-- following three values, respectively:+--+-- @+-- 'isStrictAnnot' = 'FieldStrictness' 'UnspecifiedUnpackedness' 'Strict'+-- 'notStrictAnnot' = 'FieldStrictness' 'UnspecifiedUnpackedness' 'UnspecifiedStrictness'+-- 'unpackedAnnot' = 'FieldStrictness' 'Unpack' 'Strict'+-- @+data FieldStrictness = FieldStrictness+ { fieldUnpackedness :: Unpackedness+ , fieldStrictness :: Strictness+ }+ deriving (Show, Eq, Ord, Data, Generic)++-- | Information about a constructor field's unpackedness annotation.+data Unpackedness+ = UnspecifiedUnpackedness -- ^ No annotation whatsoever+ | NoUnpack -- ^ Annotated with @{\-\# NOUNPACK \#-\}@+ | Unpack -- ^ Annotated with @{\-\# UNPACK \#-\}@+ deriving (Show, Eq, Ord, Data, Generic)++-- | Information about a constructor field's strictness annotation.+data Strictness+ = UnspecifiedStrictness -- ^ No annotation whatsoever+ | Lazy -- ^ Annotated with @~@+ | Strict -- ^ Annotated with @!@+ deriving (Show, Eq, Ord, Data, Generic)++isStrictAnnot, notStrictAnnot, unpackedAnnot :: FieldStrictness+isStrictAnnot = FieldStrictness UnspecifiedUnpackedness Strict+notStrictAnnot = FieldStrictness UnspecifiedUnpackedness UnspecifiedStrictness+unpackedAnnot = FieldStrictness Unpack Strict++-- | Construct a Type using the datatype's type constructor and type+-- parameters. Kind signatures are removed.+datatypeType :: DatatypeInfo -> Type+datatypeType di+ = foldl AppT (ConT (datatypeName di))+ $ map stripSigT+ $ datatypeInstTypes di+++-- | Compute a normalized view of the metadata about a data type or newtype+-- given a constructor.+--+-- This function will accept any constructor (value or type) for a type+-- declared with newtype or data. Value constructors must be used to+-- lookup datatype information about /data instances/ and /newtype instances/,+-- as giving the type constructor of a data family is often not enough to+-- determine a particular data family instance.+--+-- In addition, this function will also accept a record selector for a+-- data type with a constructor which uses that record.+--+-- GADT constructors are normalized into datatypes with explicit equality+-- constraints. Note that no effort is made to distinguish between equalities of+-- the same (homogeneous) kind and equalities between different (heterogeneous)+-- kinds. For instance, the following GADT's constructors:+--+-- @+-- data T (a :: k -> *) where+-- MkT1 :: T Proxy+-- MkT2 :: T Maybe+-- @+--+-- will be normalized to the following equality constraints:+--+-- @+-- AppT (AppT EqualityT (VarT a)) (ConT Proxy) -- MkT1+-- AppT (AppT EqualityT (VarT a)) (ConT Maybe) -- MkT2+-- @+--+-- But only the first equality constraint is well kinded, since in the second+-- constraint, the kinds of @(a :: k -> *)@ and @(Maybe :: * -> *)@ are different.+-- Trying to categorize which constraints need homogeneous or heterogeneous+-- equality is tricky, so we leave that task to users of this library.+--+-- Primitive types (other than unboxed sums and tuples) will have+-- no @datatypeCons@ in their normalization.+--+-- This function will apply various bug-fixes to the output of the underlying+-- @template-haskell@ library in order to provide a view of datatypes in+-- as uniform a way as possible.+reifyDatatype ::+ Name {- ^ data type or constructor name -} ->+ Q DatatypeInfo+reifyDatatype n = normalizeInfo' "reifyDatatype" isReified =<< reify n++-- | Compute a normalized view of the metadata about a constructor given its+-- 'Name'. This is useful for scenarios when you don't care about the info for+-- the enclosing data type.+reifyConstructor ::+ Name {- ^ constructor name -} ->+ Q ConstructorInfo+reifyConstructor conName = do+ dataInfo <- reifyDatatype conName+ return $ lookupByConstructorName conName dataInfo++-- | Compute a normalized view of the metadata about a constructor given the+-- 'Name' of one of its record selectors. This is useful for scenarios when you+-- don't care about the info for the enclosing data type.+reifyRecord ::+ Name {- ^ record name -} ->+ Q ConstructorInfo+reifyRecord recordName = do+ dataInfo <- reifyDatatype recordName+ return $ lookupByRecordName recordName dataInfo++-- | Given a 'DatatypeInfo', find the 'ConstructorInfo' corresponding to the+-- 'Name' of one of its constructors.+lookupByConstructorName ::+ Name {- ^ constructor name -} ->+ DatatypeInfo {- ^ info for the datatype which has that constructor -} ->+ ConstructorInfo+lookupByConstructorName conName dataInfo =+ case find ((== conName) . constructorName) (datatypeCons dataInfo) of+ Just conInfo -> conInfo+ Nothing -> error $ "Datatype " ++ nameBase (datatypeName dataInfo)+ ++ " does not have a constructor named " ++ nameBase conName+-- | Given a 'DatatypeInfo', find the 'ConstructorInfo' corresponding to the+-- 'Name' of one of its constructors.+lookupByRecordName ::+ Name {- ^ record name -} ->+ DatatypeInfo {- ^ info for the datatype which has that constructor -} ->+ ConstructorInfo+lookupByRecordName recordName dataInfo =+ case find (conHasRecord recordName) (datatypeCons dataInfo) of+ Just conInfo -> conInfo+ Nothing -> error $ "Datatype " ++ nameBase (datatypeName dataInfo)+ ++ " does not have any constructors with a "+ ++ "record selector named " ++ nameBase recordName++-- | Normalize 'Info' for a newtype or datatype into a 'DatatypeInfo'.+-- Fail in 'Q' otherwise.+normalizeInfo :: Info -> Q DatatypeInfo+normalizeInfo = normalizeInfo' "normalizeInfo" isn'tReified++normalizeInfo' :: String -> IsReifiedDec -> Info -> Q DatatypeInfo+normalizeInfo' entry reifiedDec i =+ case i of+ (PrimTyConI name arity unlifted) -> do+#if MIN_VERSION_template_haskell(2,16,0)+ -- We provide a minimal @DataD@ because, since TH 2.16,+ -- we can rely on the call to @reifyType@ in+ -- @normalizeDecFor@ to fill in the missing details.+ normalizeDecFor reifiedDec $ DataD [] name [] Nothing [] []+#else+ -- On older versions, we are very limited in what we can deduce.+ -- All we know is the appropriate amount of type constructors.+ -- Note that this will default all kinds to @Type@, which is all+ -- that is available anyway.+ args <- replicateM arity (newName "x")+ dec <- dataDCompat (return []) name (map plainTV args) [] []+ normalizeDecFor reifiedDec dec+#endif+ ClassI{} -> bad "Class not supported"+ FamilyI DataFamilyD{} _ -> bad "Use a value constructor to reify a data family instance"+ FamilyI _ _ -> bad "Type families not supported"+ TyConI dec -> normalizeDecFor reifiedDec dec+ DataConI name _ parent -> reifyParent name parent+ -- NB: We do not pass the IsReifiedDec information here+ -- because there's no point. We have no choice but to+ -- call reify here, since we need to determine the+ -- parent data type/family.+ VarI recName recTy _ -> reifyRecordType recName recTy+ -- NB: Similarly, we do not pass the IsReifiedDec+ -- information here.+ _ -> bad "Expected a type constructor"+ where+ bad msg = fail (entry ++ ": " ++ msg)+++reifyParent :: Name -> Name -> Q DatatypeInfo+reifyParent con = reifyParentWith "reifyParent" p+ where+ p :: DatatypeInfo -> Bool+ p info = con `elem` map constructorName (datatypeCons info)++reifyRecordType :: Name -> Type -> Q DatatypeInfo+reifyRecordType recName recTy =+ let (_, _, argTys :|- _) = uncurryType recTy+ in case argTys of+ dataTy:_ -> decomposeDataType dataTy+ _ -> notRecSelFailure+ where+ decomposeDataType :: Type -> Q DatatypeInfo+ decomposeDataType ty =+ do case decomposeType ty of+ ConT parent :| _ -> reifyParentWith "reifyRecordType" p parent+ _ -> notRecSelFailure++ notRecSelFailure :: Q a+ notRecSelFailure = fail $+ "reifyRecordType: Not a record selector type: " +++ nameBase recName ++ " :: " ++ show recTy++ p :: DatatypeInfo -> Bool+ p info = any (conHasRecord recName) (datatypeCons info)++reifyParentWith ::+ String {- ^ prefix for error messages -} ->+ (DatatypeInfo -> Bool) {- ^ predicate for finding the right+ data family instance -} ->+ Name {- ^ parent data type name -} ->+ Q DatatypeInfo+reifyParentWith prefix p n =+ do info <- reify n+ case info of+ TyConI dec -> normalizeDecFor isReified dec+ FamilyI dec instances ->+ do instances1 <- mapM (repairDataFam dec) instances+ instances2 <- mapM (normalizeDecFor isReified) instances1+ case find p instances2 of+ Just inst -> return inst+ Nothing -> panic "lost the instance"+ _ -> panic "unexpected parent"+ where+ dataFamiliesOnOldGHCsError :: Q a+ dataFamiliesOnOldGHCsError = fail $+ prefix ++ ": Data family instances can only be reified with GHC 7.4 or later"++ panic :: String -> Q a+ panic message = fail $ "PANIC: " ++ prefix ++ " " ++ message++-- Sadly, Template Haskell's treatment of data family instances leaves much+-- to be desired. On all versions of GHC, TH leaves off the kind signatures on+-- the type patterns of data family instances where a kind signature isn't+-- specified explicitly. Here, we can use the parent data family's type variable+-- binders to reconstruct the kind signatures if they are missing.+repairDataFam ::+ Dec {- ^ family declaration -} ->+ Dec {- ^ instance declaration -} ->+ Q Dec {- ^ instance declaration -}+repairDataFam famD instD+#if MIN_VERSION_template_haskell(2,15,0)+ | DataFamilyD _ dvars dk <- famD+ , NewtypeInstD cx mbInstVars nts k c deriv <- instD+ , con :| ts <- decomposeType nts+ = do ts' <- repairVarKindsWith dvars dk ts+ return $ NewtypeInstD cx mbInstVars (foldl' AppT con ts') k c deriv++ | DataFamilyD _ dvars dk <- famD+ , DataInstD cx mbInstVars nts k c deriv <- instD+ , con :| ts <- decomposeType nts+ = do ts' <- repairVarKindsWith dvars dk ts+ return $ DataInstD cx mbInstVars (foldl' AppT con ts') k c deriv+#else+ | DataFamilyD _ dvars dk <- famD+ , NewtypeInstD cx n ts k c deriv <- instD+ = do ts' <- repairVarKindsWith dvars dk ts+ return $ NewtypeInstD cx n ts' k c deriv++ | DataFamilyD _ dvars dk <- famD+ , DataInstD cx n ts k c deriv <- instD+ = do ts' <- repairVarKindsWith dvars dk ts+ return $ DataInstD cx n ts' k c deriv+#endif+repairDataFam _ instD = return instD++-- | @'repairVarKindsWith' tvbs mbKind ts@ returns @ts@, but where each element+-- has an explicit kind signature taken from a 'TyVarBndr' in the corresponding+-- position in @tvbs@, or from the corresponding kind argument in 'mbKind' if+-- there aren't enough 'TyVarBndr's available. An example where @tvbs@ can be+-- shorter than @ts@ can be found in this example from #95:+--+-- @+-- data family F :: Type -> Type+-- data instance F a = C+-- @+--+-- The @F@ has no type variable binders in its @data family@ declaration, and+-- it has a return kind of @Type -> Type@. As a result, we pair up @Type@ with+-- @VarT a@ to get @SigT a (ConT ''Type)@.+repairVarKindsWith :: [TyVarBndrVis] -> Maybe Kind -> [Type] -> Q [Type]+repairVarKindsWith tvbs mbKind ts = do+ extra_tvbs <- mkExtraKindBinders $ fromMaybe starK mbKind+ -- This list should be the same length as @ts@. If it isn't, something has+ -- gone terribly wrong.+ let tvbs' = changeTVFlags () tvbs ++ extra_tvbs+ return $ zipWith stealKindForType tvbs' ts++-- If a VarT is missing an explicit kind signature, steal it from a TyVarBndr.+stealKindForType :: TyVarBndr_ flag -> Type -> Type+stealKindForType tvb t@VarT{} = SigT t (tvKind tvb)+stealKindForType _ t = t++-- | Normalize 'Dec' for a newtype or datatype into a 'DatatypeInfo'.+-- Fail in 'Q' otherwise.+--+-- Beware: 'normalizeDec' can have surprising behavior when it comes to fixity.+-- For instance, if you have this quasiquoted data declaration:+--+-- @+-- [d| infix 5 :^^:+-- data Foo where+-- (:^^:) :: Int -> Int -> Foo |]+-- @+--+-- Then if you pass the 'Dec' for @Foo@ to 'normalizeDec' without splicing it+-- in a previous Template Haskell splice, then @(:^^:)@ will be labeled a 'NormalConstructor'+-- instead of an 'InfixConstructor'. This is because Template Haskell has no way to+-- reify the fixity declaration for @(:^^:)@, so it must assume there isn't one. To+-- work around this behavior, use 'reifyDatatype' instead.+normalizeDec :: Dec -> Q DatatypeInfo+normalizeDec = normalizeDecFor isn'tReified++normalizeDecFor :: IsReifiedDec -> Dec -> Q DatatypeInfo+normalizeDecFor isReified dec =+ case dec of+#if MIN_VERSION_template_haskell(2,20,0)+ TypeDataD name tyvars mbKind cons ->+ normalizeDataD [] name tyvars mbKind cons TypeData+#endif+#if MIN_VERSION_template_haskell(2,12,0)+ NewtypeD context name tyvars mbKind con _derives ->+ normalizeDataD context name tyvars mbKind [con] Newtype+ DataD context name tyvars mbKind cons _derives ->+ normalizeDataD context name tyvars mbKind cons Datatype+# if MIN_VERSION_template_haskell(2,15,0)+ NewtypeInstD context mbTyvars nameInstTys mbKind con _derives ->+ normalizeDataInstDPostTH2'15 "newtype" context mbTyvars nameInstTys+ mbKind [con] NewtypeInstance+ DataInstD context mbTyvars nameInstTys mbKind cons _derives ->+ normalizeDataInstDPostTH2'15 "data" context mbTyvars nameInstTys+ mbKind cons DataInstance+# else+ NewtypeInstD context name instTys mbKind con _derives ->+ normalizeDataInstDPreTH2'15 context name instTys mbKind [con] NewtypeInstance+ DataInstD context name instTys mbKind cons _derives ->+ normalizeDataInstDPreTH2'15 context name instTys mbKind cons DataInstance+# endif+#else+ NewtypeD context name tyvars mbKind con _derives ->+ normalizeDataD context name tyvars mbKind [con] Newtype+ DataD context name tyvars mbKind cons _derives ->+ normalizeDataD context name tyvars mbKind cons Datatype+ NewtypeInstD context name instTys mbKind con _derives ->+ normalizeDataInstDPreTH2'15 context name instTys mbKind [con] NewtypeInstance+ DataInstD context name instTys mbKind cons _derives ->+ normalizeDataInstDPreTH2'15 context name instTys mbKind cons DataInstance+#endif+ _ -> fail "normalizeDecFor: DataD or NewtypeD required"+ where+ -- We only need to repair reified declarations for data family instances.+ repair13618' :: DatatypeInfo -> Q DatatypeInfo+ repair13618' di@DatatypeInfo{datatypeVariant = variant}+ | isReified && isFamInstVariant variant+ = repair13618 di+ | otherwise+ = return di++ -- If a data type lacks an explicit return kind, use `reifyType` to compute+ -- it, as described in step (1) of Note [Tricky result kinds].+ normalizeMbKind :: Name -> [Type] -> Maybe Kind -> Q (Maybe Kind)+ normalizeMbKind _name _instTys mbKind@(Just _) = return mbKind+ normalizeMbKind name instTys Nothing = do+#if MIN_VERSION_template_haskell(2,16,0)+ mbReifiedKind <- return Nothing `recover` fmap Just (reifyType name)+ T.mapM normalizeKind mbReifiedKind+ where+ normalizeKind :: Kind -> Q Kind+ normalizeKind k = do+ k' <- resolveKindSynonyms k+ -- Step (1) in Note [Tricky result kinds]+ -- (Wrinkle: normalizeMbKind argument unification).+ let (args, res) = unravelKindUpTo instTys k'+ -- Step (2) in Note [Tricky result kinds]+ -- (Wrinkle: normalizeMbKind argument unification).+ (instTys', args') =+ unzip $+ mapMaybe+ (\(instTy, arg) ->+ case arg of+ VisFADep tvb -> Just (instTy, bndrParam tvb)+ VisFAAnon k -> (, k) <$> sigTMaybeKind instTy)+ args+ (subst, _) = mergeArguments args' instTys'+ -- Step (3) in Note [Tricky result kinds]+ -- (Wrinkle: normalizeMbKind argument unification).+ pure $ applySubstitution (VarT <$> subst) res+#else+ return Nothing+#endif++ -- Given a data type declaration's binders, as well as the arguments and+ -- result of its explicit return kind, compute the free type variables.+ -- For example, this:+ --+ -- @+ -- data T (a :: j) :: forall k. Maybe k -> Type+ -- @+ --+ -- Would yield:+ --+ -- @+ -- [j, (a :: j), k, (b :: k)]+ -- @+ --+ -- Where @b@ is a fresh name that is generated in 'mkExtraFunArgForalls'.+ datatypeFreeVars :: [TyVarBndr_ flag] -> FunArgs -> Kind -> [TyVarBndrUnit]+ datatypeFreeVars declBndrs kindArgs kindRes =+ freeVariablesWellScoped $+ bndrParams declBndrs ++ funArgTys kindArgs ++ [kindRes]++ normalizeDataD :: Cxt -> Name -> [TyVarBndrVis] -> Maybe Kind+ -> [Con] -> DatatypeVariant -> Q DatatypeInfo+ normalizeDataD context name tyvars mbKind cons variant = do+ -- NB: use `filter isRequiredTvb tyvars` here. It is possible for some of+ -- the `tyvars` to be `BndrInvis` if the data type is quoted, e.g.,+ --+ -- data D @k (a :: k)+ --+ -- th-abstraction adopts the convention that all binders in the+ -- 'datatypeInstTypes' are required, so we want to filter out the `@k`.+ let tys = bndrParams $ filter isRequiredTvb tyvars+ mbKind' <- normalizeMbKind name tys mbKind+ normalize' context name tyvars tys mbKind' cons variant++ normalizeDataInstDPostTH2'15+ :: String -> Cxt -> Maybe [TyVarBndrUnit] -> Type -> Maybe Kind+ -> [Con] -> DatatypeVariant -> Q DatatypeInfo+ normalizeDataInstDPostTH2'15 what context mbTyvars nameInstTys+ mbKind cons variant =+ case decomposeType nameInstTys of+ ConT name :| instTys -> do+ mbKind' <- normalizeMbKind name instTys mbKind+ normalize' context name+ (fromMaybe (freeVariablesWellScoped instTys) mbTyvars)+ instTys mbKind' cons variant+ _ -> fail $ "Unexpected " ++ what ++ " instance head: " ++ pprint nameInstTys++ normalizeDataInstDPreTH2'15+ :: Cxt -> Name -> [Type] -> Maybe Kind+ -> [Con] -> DatatypeVariant -> Q DatatypeInfo+ normalizeDataInstDPreTH2'15 context name instTys mbKind cons variant = do+ mbKind' <- normalizeMbKind name instTys mbKind+ normalize' context name (freeVariablesWellScoped instTys)+ instTys mbKind' cons variant++ -- The main worker of this function.+ normalize' :: Cxt -> Name -> [TyVarBndr_ flag] -> [Type] -> Maybe Kind+ -> [Con] -> DatatypeVariant -> Q DatatypeInfo+ normalize' context name tvbs instTys mbKind cons variant = do+ -- If `mbKind` is *still* Nothing after all of the work done in+ -- normalizeMbKind, then conservatively assume that the return kind is+ -- `Type`. See step (1) of Note [Tricky result kinds].+ let kind = fromMaybe starK mbKind+ kind' <- resolveKindSynonyms kind+ let (kindArgs, kindRes) = unravelType kind'+ (extra_vis_tvbs, kindArgs') <- mkExtraFunArgForalls kindArgs+ let tvbs' = datatypeFreeVars tvbs kindArgs' kindRes+ instTys' = instTys ++ bndrParams extra_vis_tvbs+ dec <- normalizeDec' isReified context name tvbs' instTys' kindRes cons variant+ repair13618' $ giveDIVarsStarKinds isReified dec++{-+Note [Tricky result kinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this example, which uses UnliftedNewtypes:++ type T :: TYPE r+ newtype T where+ MkT :: forall r. Any @(TYPE r) -> T @r++This has one universally quantified type variable `r`, but making+`reifyDatatype ''T` realize this is surprisingly tricky. There root of the+trickiness is the fact that `Language.Haskell.TH.reify ''T` will yield this:++ newtype T where+ MkT :: forall r. (Any :: TYPE r) -> (T :: TYPE r)++In particular, note that:++1. `reify` does not give `T` an explicit return kind of `TYPE r`. This is bad,+ because without this, we cannot conclude that `r` is universally quantified.+2. The reified type of the `MkT` constructor uses explicit kind annotations+ instead of visible kind applications. That is, the return type is+ `T :: TYPE r` instead of `T @r`. This makes it even trickier to figure out+ that `r` is universally quantified, as `r` does not appear directly+ underneath an application of `T`.++We resolve each of these issues as follows:++1. In `normalizeDecFor.normalizeMbKind`, we attempt to use `reifyType` to look+ up the return kind of the data type. In the `T` example above, this suffices+ to conclude that `T :: TYPE r`. `reifyType` won't always work (e.g., when+ using `normalizeDec` on a data type without an explicit return kind), so for+ those situations, we conservatively assume that the data type has return kind+ `Type`.++ The implementation of `normalizeMbKind` is somewhat involved. See+ "Wrinkle: normalizeMbKind argument unification" below for more details.+2. After determining the result kind `K1`, we pass `K1` through to+ `normalizeGadtC`. In that function, we check if the return type of the data+ constructor is of the form `Ty :: K2`, and if so, we attempt to unify `K1`+ and `K2` by passing through to `mergeArguments`. In the example above, this+ lets us conclude that the `r` in the data type return kind is the same `r`+ as in the data constructor.++===================================================+== Wrinkle: normalizeMbKind argument unification ==+===================================================++Here is a slightly more involved example:++ type T2 :: TYPE r1 -> TYPE r1+ newtype T2 (a :: TYPE r2) = MkT2 a++Here, we must use `reifyType` in `normalizeMbKind` to determine that the return+kind is `TYPE r1`. But we must be careful here: `r1` is actually the same type+variable as `r2`! We don't want to accidentally end up quantifying over the two+variables separately in `datatypeInstVars`, since they're really one and the+same.++We accomplish this by doing the following:++1. After calling `reifyKind` in `normalizeMbKind`, split the result kind into+ as many arguments as there are visible binders in the data type declaration.+ In the `T2` example above, there is exactly one visible binder in+ `newtype T2 a`, so we split the kind `TYPE r1 -> TYPE r1` by one argument to+ get ([TYPE r1], TYPE r1). See `unravelKindUpTo` for how this splitting logic+ is implemented.+2. We then unify the argument kinds resuling from the splitting in the previous+ step with the corresponding kinds from the data type declaration. In the+ example above, the split argument kind is `TYPE r1`, and the binder in the+ declaration has kind `TYPE r2`, so we unify `TYPE r1` with `TYPE r2` using+ `mergeArguments` to get a substitution [r1 :-> r2].+3. We then apply the substitution from the previous step to the rest of the+ kind. In the example above, that means we apply the [r1 :-> r2] substitution+ to `TYPE r1` to obtain `TYPE r2`.++The payoff is that everything consistently refers to `r2`, rather than the mix+of `r1` and `r2` as before.+-}++-- | Create new kind variable binder names corresponding to the return kind of+-- a data type. This is useful when you have a data type like:+--+-- @+-- data Foo :: forall k. k -> Type -> Type where ...+-- @+--+-- But you want to be able to refer to the type @Foo a b@.+-- 'mkExtraKindBinders' will take the kind @forall k. k -> Type -> Type@,+-- discover that is has two visible argument kinds, and return as a result+-- two new kind variable binders @[a :: k, b :: Type]@, where @a@ and @b@+-- are fresh type variable names.+--+-- This expands kind synonyms if necessary.+mkExtraKindBinders :: Kind -> Q [TyVarBndrUnit]+mkExtraKindBinders kind = do+ kind' <- resolveKindSynonyms kind+ let (args, _) = unravelType kind'+ (extra_kvbs, _) <- mkExtraFunArgForalls args+ return extra_kvbs++-- | Take the supplied function kind arguments ('FunArgs') and do two things:+--+-- 1. For each 'FAAnon' with kind @k@, generate a fresh name @a@ and return+-- the 'TyVarBndr' @a :: k@. Also return each visible @forall@ in an+-- 'FAForalls' as a 'TyVarBndr'. (This is what the list of 'TyVarBndrUnit's+-- in the return type consists of.)+--+-- 2. Return a new 'FunArgs' value where each 'FAAnon' has been replaced with+-- @'FAForalls' ('ForallVis' [a :: k])@, where @a :: k@ the corresponding+-- 'TyVarBndr' computed in step (1).+--+-- As an example, consider this function kind:+--+-- @+-- forall k. k -> Type -> Type+-- @+--+-- After splitting this kind into its 'FunArgs':+--+-- @+-- ['FAForalls' ('ForallInvis' [k]), 'FAAnon' k, 'FAAnon' Type]+-- @+--+-- Calling 'mkExtraFunArgForalls' on this 'FunArgs' value would return:+--+-- @+-- ( [a :: k, b :: Type]+-- , [ 'FAForalls' ('ForallInvis' [k])+-- , 'FAForalls' ('ForallVis' [a :: k])+-- , 'FAForalls' ('ForallVis' [b :: Type])+-- ]+-- )+-- @+--+-- Where @a@ and @b@ are fresh.+--+-- This function is used in two places:+--+-- 1. As the workhorse for 'mkExtraKindBinders'.+--+-- 2. In 'normalizeDecFor', as part of computing the 'datatypeInstVars' and as+-- part of eta expanding the explicit return kind.+mkExtraFunArgForalls :: FunArgs -> Q ([TyVarBndrUnit], FunArgs)+mkExtraFunArgForalls FANil =+ return ([], FANil)+mkExtraFunArgForalls (FAForalls tele args) = do+ (extra_vis_tvbs', args') <- mkExtraFunArgForalls args+ case tele of+ ForallVis tvbs ->+ return ( tvbs ++ extra_vis_tvbs'+ , FAForalls (ForallVis tvbs) args'+ )+ ForallInvis tvbs ->+ return ( extra_vis_tvbs'+ , FAForalls (ForallInvis tvbs) args'+ )+mkExtraFunArgForalls (FACxt ctxt args) = do+ (extra_vis_tvbs', args') <- mkExtraFunArgForalls args+ return (extra_vis_tvbs', FACxt ctxt args')+mkExtraFunArgForalls (FAAnon anon args) = do+ name <- newName "x"+ let tvb = kindedTV name anon+ (extra_vis_tvbs', args') <- mkExtraFunArgForalls args+ return ( tvb : extra_vis_tvbs'+ , FAForalls (ForallVis [tvb]) args'+ )++-- | Is a declaration for a @data instance@ or @newtype instance@?+isFamInstVariant :: DatatypeVariant -> Bool+isFamInstVariant dv =+ case dv of+ Datatype -> False+ Newtype -> False+ DataInstance -> True+ NewtypeInstance -> True+ TypeData -> False++bndrParams :: [TyVarBndr_ flag] -> [Type]+bndrParams = map bndrParam++bndrParam :: TyVarBndr_ flag -> Type+bndrParam = elimTV VarT (\n k -> SigT (VarT n) k)++-- | Returns 'True' if the flag of the supplied 'TyVarBndrVis' is 'BndrReq'.+isRequiredTvb :: TyVarBndrVis -> Bool+isRequiredTvb tvb = tvFlag tvb == BndrReq++-- | Remove the outermost 'SigT'.+stripSigT :: Type -> Type+stripSigT (SigT t _) = t+stripSigT t = t++-- | If the supplied 'Type' is a @'SigT' _ k@, return @'Just' k@. Otherwise,+-- return 'Nothing'.+sigTMaybeKind :: Type -> Maybe Kind+sigTMaybeKind (SigT _ k) = Just k+sigTMaybeKind _ = Nothing++normalizeDec' ::+ IsReifiedDec {- ^ Is this a reified 'Dec'? -} ->+ Cxt {- ^ Datatype context -} ->+ Name {- ^ Type constructor -} ->+ [TyVarBndrUnit] {- ^ Type parameters -} ->+ [Type] {- ^ Argument types -} ->+ Kind {- ^ Result kind -} ->+ [Con] {- ^ Constructors -} ->+ DatatypeVariant {- ^ Extra information -} ->+ Q DatatypeInfo+normalizeDec' reifiedDec context name params instTys resKind cons variant =+ do cons' <- concat <$> mapM (normalizeConFor reifiedDec name params instTys resKind variant) cons+ return DatatypeInfo+ { datatypeContext = context+ , datatypeName = name+ , datatypeVars = params+ , datatypeInstTypes = instTys+ , datatypeCons = cons'+ , datatypeReturnKind = resKind+ , datatypeVariant = variant+ }++-- | Normalize a 'Con' into a 'ConstructorInfo'. This requires knowledge of+-- the type and parameters of the constructor, as well as whether the constructor+-- is for a data family instance, as extracted from the outer+-- 'Dec'.+normalizeCon ::+ Name {- ^ Type constructor -} ->+ [TyVarBndrUnit] {- ^ Type parameters -} ->+ [Type] {- ^ Argument types -} ->+ Kind {- ^ Result kind -} ->+ DatatypeVariant {- ^ Extra information -} ->+ Con {- ^ Constructor -} ->+ Q [ConstructorInfo]+normalizeCon = normalizeConFor isn'tReified++normalizeConFor ::+ IsReifiedDec {- ^ Is this a reified 'Dec'? -} ->+ Name {- ^ Type constructor -} ->+ [TyVarBndrUnit] {- ^ Type parameters -} ->+ [Type] {- ^ Argument types -} ->+ Kind {- ^ Result kind -} ->+ DatatypeVariant {- ^ Extra information -} ->+ Con {- ^ Constructor -} ->+ Q [ConstructorInfo]+normalizeConFor reifiedDec typename params instTys resKind variant =+ fmap (map (giveCIVarsStarKinds reifiedDec)) . dispatch+ where+ -- A GADT constructor is declared infix when:+ --+ -- 1. Its name uses operator syntax (e.g., (:*:))+ -- 2. It has exactly two fields+ -- 3. It has a programmer-supplied fixity declaration+ checkGadtFixity :: [Type] -> Name -> Q ConstructorVariant+ checkGadtFixity ts n = do+ -- Don't call reifyFixityCompat here! We need to be able to distinguish+ -- between a default fixity and an explicit @infixl 9@.+ mbFi <- return Nothing `recover` reifyFixity n+ let userSuppliedFixity = isJust mbFi+ return $ if isInfixDataCon (nameBase n)+ && length ts == 2+ && userSuppliedFixity+ then InfixConstructor+ else NormalConstructor++ -- Checks if a String names a valid Haskell infix data+ -- constructor (i.e., does it begin with a colon?).+ isInfixDataCon :: String -> Bool+ isInfixDataCon (':':_) = True+ isInfixDataCon _ = False++ dispatch :: Con -> Q [ConstructorInfo]+ dispatch =+ let defaultCase :: Con -> Q [ConstructorInfo]+ defaultCase = go [] [] False+ where+ go :: [TyVarBndrUnit]+ -> Cxt+ -> Bool -- Is this a GADT? (see the documentation for+ -- for checkGadtFixity)+ -> Con+ -> Q [ConstructorInfo]+ go tyvars context gadt c =+ case c of+ NormalC n xs -> do+ let (bangs, ts) = unzip xs+ stricts = map normalizeStrictness bangs+ fi <- if gadt+ then checkGadtFixity ts n+ else return NormalConstructor+ return [ConstructorInfo n tyvars context ts stricts fi]+ InfixC l n r ->+ let (bangs, ts) = unzip [l,r]+ stricts = map normalizeStrictness bangs in+ return [ConstructorInfo n tyvars context ts stricts+ InfixConstructor]+ RecC n xs ->+ let fns = takeFieldNames xs+ stricts = takeFieldStrictness xs in+ return [ConstructorInfo n tyvars context+ (takeFieldTypes xs) stricts (RecordConstructor fns)]+ ForallC tyvars' context' c' ->+ go (changeTVFlags () tyvars'++tyvars) (context'++context) True c'+ GadtC ns xs innerType ->+ let (bangs, ts) = unzip xs+ stricts = map normalizeStrictness bangs in+ gadtCase ns innerType ts stricts (checkGadtFixity ts)+ RecGadtC ns xs innerType ->+ let fns = takeFieldNames xs+ stricts = takeFieldStrictness xs in+ gadtCase ns innerType (takeFieldTypes xs) stricts+ (const $ return $ RecordConstructor fns)+ where+ gadtCase = normalizeGadtC typename params instTys resKind tyvars context+ in defaultCase++normalizeStrictness :: Bang -> FieldStrictness+normalizeStrictness (Bang upk str) =+ FieldStrictness (normalizeSourceUnpackedness upk)+ (normalizeSourceStrictness str)+ where+ normalizeSourceUnpackedness :: SourceUnpackedness -> Unpackedness+ normalizeSourceUnpackedness NoSourceUnpackedness = UnspecifiedUnpackedness+ normalizeSourceUnpackedness SourceNoUnpack = NoUnpack+ normalizeSourceUnpackedness SourceUnpack = Unpack++ normalizeSourceStrictness :: SourceStrictness -> Strictness+ normalizeSourceStrictness NoSourceStrictness = UnspecifiedStrictness+ normalizeSourceStrictness SourceLazy = Lazy+ normalizeSourceStrictness SourceStrict = Strict++normalizeGadtC ::+ Name {- ^ Type constructor -} ->+ [TyVarBndrUnit] {- ^ Type parameters -} ->+ [Type] {- ^ Argument types -} ->+ Kind {- ^ Result kind -} ->+ [TyVarBndrUnit] {- ^ Constructor parameters -} ->+ Cxt {- ^ Constructor context -} ->+ [Name] {- ^ Constructor names -} ->+ Type {- ^ Declared type of constructor -} ->+ [Type] {- ^ Constructor field types -} ->+ [FieldStrictness] {- ^ Constructor field strictness -} ->+ (Name -> Q ConstructorVariant)+ {- ^ Determine a constructor variant+ from its 'Name' -} ->+ Q [ConstructorInfo]+normalizeGadtC typename params instTys resKind tyvars context names innerType+ fields stricts getVariant =+ do -- It's possible that the constructor has implicitly quantified type+ -- variables, such as in the following example (from #58):+ --+ -- [d| data Foo where+ -- MkFoo :: a -> Foo |]+ --+ -- normalizeGadtC assumes that all type variables have binders, however,+ -- so we use freeVariablesWellScoped to obtain the implicit type+ -- variables' binders before proceeding.+ let implicitTyvars = freeVariablesWellScoped+ [curryType (changeTVFlags SpecifiedSpec tyvars)+ context fields innerType]+ allTyvars = implicitTyvars ++ tyvars++ -- Due to GHC Trac #13885, it's possible that the type variables bound by+ -- a GADT constructor will shadow those that are bound by the data type.+ -- This function assumes this isn't the case in certain parts (e.g., when+ -- mergeArguments is invoked), so we do an alpha-renaming of the+ -- constructor-bound variables before proceeding. See #36 for an example+ -- of what can go wrong if this isn't done.+ let conBoundNames =+ concatMap (\tvb -> tvName tvb:freeVariables (tvKind tvb)) allTyvars+ conSubst <- T.sequence $ Map.fromList [ (n, newName (nameBase n))+ | n <- conBoundNames ]+ let conSubst' = fmap VarT conSubst+ renamedTyvars =+ map (elimTV (\n -> plainTV (conSubst Map.! n))+ (\n k -> kindedTV (conSubst Map.! n)+ (applySubstitution conSubst' k))) allTyvars+ renamedContext = applySubstitution conSubst' context+ renamedInnerType = applySubstitution conSubst' innerType+ renamedFields = applySubstitution conSubst' fields++ innerType' <- resolveTypeSynonyms renamedInnerType++ -- If the return type in the data constructor is of the form `T :: K`, then+ -- return (T, Just K, Just resKind), where `resKind` is the result kind of+ -- the parent data type. Otherwise, return (T :: K, Nothing, Nothing). The+ -- two `Maybe` values are passed below to `mergeArguments` such that if+ -- they are both `Just`, then we will attempt to unify `K` and `resKind`.+ -- See step (2) of Note [Tricky result kinds].+ let (innerType'', mbInnerResKind, mbResKind) =+ case innerType' of+ SigT t innerResKind -> (t, Just innerResKind, Just resKind)+ _ -> (innerType', Nothing, Nothing)++ case decomposeType innerType'' of+ ConT innerTyCon :| ts | typename == innerTyCon ->++ let -- See step (2) of Note [Tricky result kinds].+ instTys' = maybeToList mbResKind ++ instTys+ ts' = maybeToList mbInnerResKind ++ ts++ (substName, context1) =+ closeOverKinds (kindsOfFVsOfTvbs renamedTyvars)+ (kindsOfFVsOfTvbs params)+ (mergeArguments instTys' ts')+ subst = VarT <$> substName+ exTyvars = [ tv | tv <- renamedTyvars, Map.notMember (tvName tv) subst ]++ -- The use of substTyVarBndrKinds below will never capture, as the+ -- range of the substitution will always use distinct names from+ -- exTyvars due to the alpha-renaming pass above.+ exTyvars' = substTyVarBndrKinds subst exTyvars+ context2 = applySubstitution subst (context1 ++ renamedContext)+ fields' = applySubstitution subst renamedFields+ in sequence [ ConstructorInfo name exTyvars' context2+ fields' stricts <$> variantQ+ | name <- names+ , let variantQ = getVariant name+ ]++ _ -> fail "normalizeGadtC: Expected type constructor application"++{-+Extend a type variable renaming subtitution and a list of equality+predicates by looking into kind information as much as possible.++Why is this necessary? Consider the following example:++ data (a1 :: k1) :~: (b1 :: k1) where+ Refl :: forall k2 (a2 :: k2). a2 :~: a2++After an initial call to mergeArguments, we will have the following+substitution and context:++* Substitution: [a2 :-> a1]+* Context: (a2 ~ b1)++We shouldn't stop there, however! We determine the existentially quantified+type variables of a constructor by filtering out those constructor-bound+variables which do not appear in the substitution that mergeArguments+returns. In this example, Refl's bound variables are k2 and a2. a2 appears+in the returned substitution, but k2 does not, which means that we would+mistakenly conclude that k2 is existential!++Although we don't have the full power of kind inference to guide us here, we+can at least do the next best thing. Generally, the datatype-bound type+variables and the constructor type variable binders contain all of the kind+information we need, so we proceed as follows:++1. Construct a map from each constructor-bound variable to its kind. (Do the+ same for each datatype-bound variable). These maps are the first and second+ arguments to closeOverKinds, respectively.+2. Call mergeArguments once on the GADT return type and datatype-bound types,+ and pass that in as the third argument to closeOverKinds.+3. For each name-name pair in the supplied substitution, check if the first and+ second names map to kinds in the first and second kind maps in+ closeOverKinds, respectively. If so, associate the first kind with the+ second kind.+4. For each kind association discovered in part (3), call mergeArguments+ on the lists of kinds. This will yield a kind substitution and kind+ equality context.+5. If the kind substitution is non-empty, then go back to step (3) and repeat+ the process on the new kind substitution and context.++ Otherwise, if the kind substitution is empty, then we have reached a fixed-+ point (i.e., we have closed over the kinds), so proceed.+6. Union up all of the substitutions and contexts, and return those.++This algorithm is not perfect, as it will only catch everything if all of+the kinds are explicitly mentioned somewhere (and not left quantified+implicitly). Thankfully, reifying data types via Template Haskell tends to+yield a healthy amount of kind signatures, so this works quite well in+practice.+-}+closeOverKinds :: Map Name Kind+ -> Map Name Kind+ -> (Map Name Name, Cxt)+ -> (Map Name Name, Cxt)+closeOverKinds domainFVKinds rangeFVKinds = go+ where+ go :: (Map Name Name, Cxt) -> (Map Name Name, Cxt)+ go (subst, context) =+ let substList = Map.toList subst+ (kindsInner, kindsOuter) =+ unzip $+ mapMaybe (\(d, r) -> do d' <- Map.lookup d domainFVKinds+ r' <- Map.lookup r rangeFVKinds+ return (d', r'))+ substList+ (kindSubst, kindContext) = mergeArguments kindsOuter kindsInner+ (restSubst, restContext)+ = if Map.null kindSubst -- Fixed-point calculation+ then (Map.empty, [])+ else go (kindSubst, kindContext)+ finalSubst = Map.unions [subst, kindSubst, restSubst]+ finalContext = nub $ concat [context, kindContext, restContext]+ -- Use `nub` here in an effort to minimize the number of+ -- redundant equality constraints in the returned context.+ in (finalSubst, finalContext)++-- Look into a list of types and map each free variable name to its kind.+kindsOfFVsOfTypes :: [Type] -> Map Name Kind+kindsOfFVsOfTypes = foldMap go+ where+ go :: Type -> Map Name Kind+ go (AppT t1 t2) = go t1 `Map.union` go t2+ go (SigT t k) =+ let kSigs = go k+ in case t of+ VarT n -> Map.insert n k kSigs+ _ -> go t `Map.union` kSigs++ go (ForallT {}) = forallError+#if MIN_VERSION_template_haskell(2,16,0)+ go (ForallVisT {}) = forallError+#endif++ go _ = Map.empty++ forallError :: a+ forallError = error "`forall` type used in data family pattern"++-- Look into a list of type variable binder and map each free variable name+-- to its kind (also map the names that KindedTVs bind to their respective+-- kinds). This function considers the kind of a PlainTV to be *.+kindsOfFVsOfTvbs :: [TyVarBndr_ flag] -> Map Name Kind+kindsOfFVsOfTvbs = foldMap go+ where+ go :: TyVarBndr_ flag -> Map Name Kind+ go = elimTV (\n -> Map.singleton n starK)+ (\n k -> let kSigs = kindsOfFVsOfTypes [k]+ in Map.insert n k kSigs)++mergeArguments ::+ [Type] {- ^ outer parameters -} ->+ [Type] {- ^ inner parameters (specializations ) -} ->+ (Map Name Name, Cxt)+mergeArguments ns ts = foldr aux (Map.empty, []) (zip ns ts)+ where++ aux (f `AppT` x, g `AppT` y) sc =+ aux (x,y) (aux (f,g) sc)++ aux (VarT n,p) (subst, context) =+ case p of+ VarT m | m == n -> (subst, context)+ -- If the two variables are the same, don't bother extending+ -- the substitution. (This is purely an optimization.)+ | Just n' <- Map.lookup m subst+ , n == n' -> (subst, context)+ -- If a variable is already in a substitution and it maps+ -- to the variable that we are trying to unify with, then+ -- leave the context alone. (Not doing so caused #46.)+ | Map.notMember m subst -> (Map.insert m n subst, context)+ _ -> (subst, equalPred (VarT n) p : context)++ aux (SigT x _, y) sc = aux (x,y) sc -- learn about kinds??+ -- This matches *after* VarT so that we can compute a substitution+ -- that includes the kind signature.+ aux (x, SigT y _) sc = aux (x,y) sc++ aux _ sc = sc++-- | Expand all of the type synonyms in a type.+--+-- Note that this function will drop parentheses as a side effect.+resolveTypeSynonyms :: Type -> Q Type+resolveTypeSynonyms t =+ let (f, xs) = decomposeTypeArgs t+ normal_xs = filterTANormals xs++ -- Either the type is not headed by a type synonym, or it is headed by a+ -- type synonym that is not applied to enough arguments. Leave the type+ -- alone and only expand its arguments.+ defaultCase :: Type -> Q Type+ defaultCase ty = foldl appTypeArg ty <$> mapM resolveTypeArgSynonyms xs++ expandCon :: Name -- The Name to check whether it is a type synonym or not+ -> Type -- The argument type to fall back on if the supplied+ -- Name isn't a type synonym+ -> Q Type+ expandCon n ty = do+ mbInfo <- reifyMaybe n+ case mbInfo of+ Just (TyConI (TySynD _ synvars def))+ | length normal_xs >= length synvars -- Don't expand undersaturated type synonyms (#88)+ -> resolveTypeSynonyms $ expandSynonymRHS synvars normal_xs def+ _ -> defaultCase ty++ in case f of+ ForallT tvbs ctxt body ->+ ForallT `fmap` mapM resolve_tvb_syns tvbs+ `ap` mapM resolvePredSynonyms ctxt+ `ap` resolveTypeSynonyms body+ SigT ty ki -> do+ ty' <- resolveTypeSynonyms ty+ ki' <- resolveKindSynonyms ki+ defaultCase $ SigT ty' ki'+ ConT n -> expandCon n f+ InfixT t1 n t2 -> do+ t1' <- resolveTypeSynonyms t1+ t2' <- resolveTypeSynonyms t2+ expandCon n (InfixT t1' n t2')+ UInfixT t1 n t2 -> do+ t1' <- resolveTypeSynonyms t1+ t2' <- resolveTypeSynonyms t2+ expandCon n (UInfixT t1' n t2')+#if MIN_VERSION_template_haskell(2,15,0)+ ImplicitParamT n t -> do+ ImplicitParamT n <$> resolveTypeSynonyms t+#endif+#if MIN_VERSION_template_haskell(2,16,0)+ ForallVisT tvbs body ->+ ForallVisT `fmap` mapM resolve_tvb_syns tvbs+ `ap` resolveTypeSynonyms body+#endif+#if MIN_VERSION_template_haskell(2,19,0)+ PromotedInfixT t1 n t2 -> do+ t1' <- resolveTypeSynonyms t1+ t2' <- resolveTypeSynonyms t2+ return $ PromotedInfixT t1' n t2'+ PromotedUInfixT t1 n t2 -> do+ t1' <- resolveTypeSynonyms t1+ t2' <- resolveTypeSynonyms t2+ return $ PromotedUInfixT t1' n t2'+#endif+ _ -> defaultCase f++-- | Expand all of the type synonyms in a 'TypeArg'.+resolveTypeArgSynonyms :: TypeArg -> Q TypeArg+resolveTypeArgSynonyms (TANormal t) = TANormal <$> resolveTypeSynonyms t+resolveTypeArgSynonyms (TyArg k) = TyArg <$> resolveKindSynonyms k++-- | Expand all of the type synonyms in a 'Kind'.+resolveKindSynonyms :: Kind -> Q Kind+resolveKindSynonyms = resolveTypeSynonyms++-- | Expand all of the type synonyms in a the kind of a 'TyVarBndr'.+resolve_tvb_syns :: TyVarBndr_ flag -> Q (TyVarBndr_ flag)+resolve_tvb_syns = mapMTVKind resolveKindSynonyms++expandSynonymRHS ::+ [TyVarBndr_ flag] {- ^ Substitute these variables... -} ->+ [Type] {- ^ ...with these types... -} ->+ Type {- ^ ...inside of this type. -} ->+ Type+expandSynonymRHS synvars ts def =+ let argNames = map tvName synvars+ (args,rest) = splitAt (length argNames) ts+ subst = Map.fromList (zip argNames args)+ in foldl AppT (applySubstitution subst def) rest++-- | Expand all of the type synonyms in a 'Pred'.+resolvePredSynonyms :: Pred -> Q Pred+resolvePredSynonyms = resolveTypeSynonyms++-- | Decompose a type into a list of it's outermost applications. This process+-- forgets about infix application, explicit parentheses, and visible kind+-- applications.+--+-- This operation should be used after all 'UInfixT' cases have been resolved+-- by 'resolveFixities' if the argument is being user generated.+--+-- > t ~= foldl1 AppT (decomposeType t)+decomposeType :: Type -> NonEmpty Type+decomposeType t =+ case decomposeTypeArgs t of+ (f, x) -> f :| filterTANormals x++-- | A variant of 'decomposeType' that preserves information about visible kind+-- applications by returning a 'NonEmpty' list of 'TypeArg's.+decomposeTypeArgs :: Type -> (Type, [TypeArg])+decomposeTypeArgs = go []+ where+ go :: [TypeArg] -> Type -> (Type, [TypeArg])+ go args (AppT f x) = go (TANormal x:args) f+ go args (ParensT t) = go args t+#if MIN_VERSION_template_haskell(2,15,0)+ go args (AppKindT f x) = go (TyArg x:args) f+#endif+ go args t = (t, args)++-- | An argument to a type, either a normal type ('TANormal') or a visible+-- kind application ('TyArg').+data TypeArg+ = TANormal Type+ | TyArg Kind++-- | Apply a 'Type' to a 'TypeArg'.+appTypeArg :: Type -> TypeArg -> Type+appTypeArg f (TANormal x) = f `AppT` x+appTypeArg f (TyArg _k) =+#if MIN_VERSION_template_haskell(2,15,0)+ f `AppKindT` _k+#else+ f -- VKA isn't supported, so conservatively drop the argument+#endif++-- | Filter out all of the normal type arguments from a list of 'TypeArg's.+filterTANormals :: [TypeArg] -> [Type]+filterTANormals = mapMaybe f+ where+ f :: TypeArg -> Maybe Type+ f (TANormal t) = Just t+ f (TyArg {}) = Nothing++-- 'NonEmpty' didn't move into base until recently. Reimplementing it locally+-- saves dependencies for supporting older GHCs+data NonEmpty a = a :| [a]++data NonEmptySnoc a = [a] :|- a++-- Decompose a function type into its context, argument types,+-- and return type. For instance, this+--+-- forall a b. (Show a, b ~ Int) => (a -> b) -> Char -> Int+--+-- becomes+--+-- ([a, b], [Show a, b ~ Int], [a -> b, Char] :|- Int)+uncurryType :: Type -> ([TyVarBndrSpec], Cxt, NonEmptySnoc Type)+uncurryType = go [] [] []+ where+ go tvbs ctxt args (AppT (AppT ArrowT t1) t2) = go tvbs ctxt (t1:args) t2+ go tvbs ctxt args (ForallT tvbs' ctxt' t) = go (tvbs++tvbs') (ctxt++ctxt') args t+ go tvbs ctxt args t = (tvbs, ctxt, reverse args :|- t)++-- Reconstruct a function type from its type variable binders, context,+-- argument types and return type.+curryType :: [TyVarBndrSpec] -> Cxt -> [Type] -> Type -> Type+curryType tvbs ctxt args res =+ ForallT tvbs ctxt $ foldr (\arg t -> ArrowT `AppT` arg `AppT` t) res args++-- All of the code from @ForallTelescope@ through @unravelType@ is taken from+-- the @th-desugar@ library, which is licensed under a 3-Clause BSD license.++-- | The type variable binders in a @forall@. This is not used by the TH AST+-- itself, but this is used as an intermediate data type in 'FAForalls'.+data ForallTelescope+ = ForallVis [TyVarBndrUnit]+ -- ^ A visible @forall@ (e.g., @forall a -> {...}@).+ -- These do not have any notion of specificity, so we use+ -- '()' as a placeholder value in the 'TyVarBndr's.+ | ForallInvis [TyVarBndrSpec]+ -- ^ An invisible @forall@ (e.g., @forall a {b} c -> {...}@),+ -- where each binder has a 'Specificity'.++-- | The list of arguments in a function 'Type'.+data FunArgs+ = FANil+ -- ^ No more arguments.+ | FAForalls ForallTelescope FunArgs+ -- ^ A series of @forall@ed type variables followed by a dot (if+ -- 'ForallInvis') or an arrow (if 'ForallVis'). For example,+ -- the type variables @a1 ... an@ in @forall a1 ... an. r@.+ | FACxt Cxt FunArgs+ -- ^ A series of constraint arguments followed by @=>@. For example,+ -- the @(c1, ..., cn)@ in @(c1, ..., cn) => r@.+ | FAAnon Kind FunArgs+ -- ^ An anonymous argument followed by an arrow. For example, the @a@+ -- in @a -> r@.++-- | A /visible/ function argument type (i.e., one that must be supplied+-- explicitly in the source code). This is in contrast to /invisible/+-- arguments (e.g., the @c@ in @c => r@), which are instantiated without+-- the need for explicit user input.+data VisFunArg+ = VisFADep TyVarBndrUnit+ -- ^ A visible @forall@ (e.g., @forall a -> a@).+ | VisFAAnon Kind+ -- ^ An anonymous argument followed by an arrow (e.g., @a -> r@).++-- | Decompose a function 'Type' into its arguments (the 'FunArgs') and its+-- result type (the 'Type).+unravelType :: Type -> (FunArgs, Type)+unravelType (ForallT tvbs cxt ty) =+ let (args, res) = unravelType ty in+ (FAForalls (ForallInvis tvbs) (FACxt cxt args), res)+unravelType (AppT (AppT ArrowT t1) t2) =+ let (args, res) = unravelType t2 in+ (FAAnon t1 args, res)+#if __GLASGOW_HASKELL__ >= 809+unravelType (ForallVisT tvbs ty) =+ let (args, res) = unravelType ty in+ (FAForalls (ForallVis tvbs) args, res)+#endif+unravelType t = (FANil, t)++-- | Reconstruct an arrow 'Type' from its argument and result types.+ravelType :: FunArgs -> Type -> Type+ravelType FANil res = res+-- We need a special case for FAForalls ForallInvis followed by FACxt so that we may+-- collapse them into a single ForallT when raveling.+ravelType (FAForalls (ForallInvis tvbs) (FACxt p args)) res =+ ForallT tvbs p (ravelType args res)+ravelType (FAForalls (ForallInvis tvbs) args) res = ForallT tvbs [] (ravelType args res)+ravelType (FAForalls (ForallVis _tvbs) _args) _res =+#if __GLASGOW_HASKELL__ >= 809+ ForallVisT _tvbs (ravelType _args _res)+#else+ error "Visible dependent quantification supported only on GHC 8.10+"+#endif+ravelType (FACxt cxt args) res = ForallT [] cxt (ravelType args res)+ravelType (FAAnon t args) res = AppT (AppT ArrowT t) (ravelType args res)++-- | Convert a 'FunArg's value into the list of 'Type's that it contains.+-- For example, given this function type:+--+-- @+-- forall k (a :: k). Proxy a -> forall b. Maybe b+-- @+--+-- Then calling @funArgTys@ on the arguments would yield:+--+-- @+-- [k, (a :: k), Proxy a, b, Maybe b]+-- @+--+-- This is primarily used for the purposes of computing all of the type+-- variables that appear in a 'FunArgs' value.+funArgTys :: FunArgs -> [Type]+funArgTys FANil = []+funArgTys (FAForalls tele args) =+ forallTelescopeTys tele ++ funArgTys args+funArgTys (FACxt ctxt args) =+ ctxt ++ funArgTys args+funArgTys (FAAnon anon args) =+ anon : funArgTys args++-- | Convert a 'ForallTelescope' value into the list of 'Type's that it+-- contains. See the Haddocks for 'funArgTys' for an example of what this does.+forallTelescopeTys :: ForallTelescope -> [Type]+forallTelescopeTys (ForallVis tvbs) = bndrParams tvbs+forallTelescopeTys (ForallInvis tvbs) = bndrParams tvbs++-- | @'filterVisFunArgsUpTo' xs args@ will split @args@ into 'VisFunArg's as+-- many times as there are elements in @xs@, pairing up each entry in @xs@ with+-- the corresponding 'VisFunArg' in the process. This will stop after the last+-- entry in @xs@ has been paired up.+--+-- For example, this:+--+-- @+-- 'filterVisFunArgsUpTo'+-- [Bool, True]+-- [ FAForalls (ForallVis [j])+-- , FAAnon j+-- , FAForalls (ForallInvis [k])+-- , FAAnon k+-- ]+-- @+--+-- Will yield:+--+-- @+-- ( [(Bool, VisFADep j), (True, VisFAAnon j)]+-- , [FAForalls (ForallInvis [k]), FAAnon k]+-- )+-- @+--+-- This function assumes the precondition that there are at least as many+-- visible function arguments in @args@ as there are elements in @xs@. If this+-- is not the case, this function will raise an error.+filterVisFunArgsUpTo :: forall a. [a] -> FunArgs -> ([(a, VisFunArg)], FunArgs)+filterVisFunArgsUpTo = go_fun_args+ where+ go_fun_args :: [a] -> FunArgs -> ([(a, VisFunArg)], FunArgs)+ go_fun_args [] args =+ ([], args)+ go_fun_args (_:_) FANil =+ error "filterVisFunArgsUpTo.go_fun_args: Too few FunArgs"+ go_fun_args xs (FACxt _ args) =+ go_fun_args xs args+ go_fun_args (x:xs) (FAAnon t args) =+ let (xs', args') = go_fun_args xs args in+ ((x, VisFAAnon t):xs', args')+ go_fun_args xs (FAForalls tele args) =+ case tele of+ ForallVis tvbs ->+ go_vis_tvbs tvbs xs args+ ForallInvis _ ->+ go_fun_args xs args++ go_vis_tvbs :: [TyVarBndrUnit] -> [a] -> FunArgs -> ([(a, VisFunArg)], FunArgs)+ go_vis_tvbs [] xs args =+ go_fun_args xs args+ go_vis_tvbs (tvb:tvbs) (x:xs) args =+ let (xs', args') = go_vis_tvbs tvbs xs args in+ ((x, VisFADep tvb):xs', args')+ go_vis_tvbs tvbs [] args =+ ([], FAForalls (ForallVis tvbs) args)++-- | @'unravelKindUpTo' xs k@ will split the function kind @k@ into its argument+-- kinds @args@ and result kind @res@, and then it will call+-- @'filterVisFunArgsUpTo' xs args@. The leftover arguments that were not split+-- apart by 'filterVisFunArgsUpTo' are then raveled back into @res@.+--+-- For example, this:+--+-- @+-- 'filterVisFunArgsUpTo'+-- [Bool, True]+-- (forall j -> j -> forall k. k -> Type)+-- @+--+-- Will yield:+--+-- @+-- ( [(Bool, VisFADep j), (True, VisFAAnon j)]+-- , forall k. k -> Type+-- )+-- @+--+-- This function assumes the precondition that there are at least as many+-- visible function arguments in @args@ as there are elements in @xs@. If this+-- is not the case, this function will raise an error.+unravelKindUpTo :: [a] -> Kind -> ([(a, VisFunArg)], Kind)+unravelKindUpTo xs k = (xs', ravelType args' res)+ where+ (args, res) = unravelType k+ (xs', args') = filterVisFunArgsUpTo xs args++-- | Resolve any infix type application in a type using the fixities that+-- are currently available. Starting in `template-haskell-2.11` types could+-- contain unresolved infix applications.+resolveInfixT :: Type -> Q Type++resolveInfixT (ForallT vs cx t) = ForallT <$> traverse (traverseTVKind resolveInfixT) vs+ <*> mapM resolveInfixT cx+ <*> resolveInfixT t+resolveInfixT (f `AppT` x) = resolveInfixT f `appT` resolveInfixT x+resolveInfixT (ParensT t) = resolveInfixT t+resolveInfixT (InfixT l o r) = conT o `appT` resolveInfixT l `appT` resolveInfixT r+resolveInfixT (SigT t k) = SigT <$> resolveInfixT t <*> resolveInfixT k+resolveInfixT t@UInfixT{} = resolveInfixT =<< resolveInfixT1 (gatherUInfixT t)+#if MIN_VERSION_template_haskell(2,15,0)+resolveInfixT (f `AppKindT` x) = appKindT (resolveInfixT f) (resolveInfixT x)+resolveInfixT (ImplicitParamT n t)+ = implicitParamT n $ resolveInfixT t+#endif+#if MIN_VERSION_template_haskell(2,16,0)+resolveInfixT (ForallVisT vs t) = ForallVisT <$> traverse (traverseTVKind resolveInfixT) vs+ <*> resolveInfixT t+#endif+#if MIN_VERSION_template_haskell(2,19,0)+resolveInfixT (PromotedInfixT l o r)+ = promotedT o `appT` resolveInfixT l `appT` resolveInfixT r+resolveInfixT t@PromotedUInfixT{}+ = resolveInfixT =<< resolveInfixT1 (gatherUInfixT t)+#endif+resolveInfixT t = return t++gatherUInfixT :: Type -> InfixList+gatherUInfixT (UInfixT l o r) = ilAppend (gatherUInfixT l) o False (gatherUInfixT r)+#if MIN_VERSION_template_haskell(2,19,0)+gatherUInfixT (PromotedUInfixT l o r) = ilAppend (gatherUInfixT l) o True (gatherUInfixT r)+#endif+gatherUInfixT t = ILNil t++-- This can fail due to incompatible fixities+resolveInfixT1 :: InfixList -> TypeQ+resolveInfixT1 = go []+ where+ go :: [(Type,Name,Bool,Fixity)] -> InfixList -> TypeQ+ go ts (ILNil u) = return (foldl (\acc (l,o,p,_) -> mkConT p o `AppT` l `AppT` acc) u ts)+ go ts (ILCons l o p r) =+ do ofx <- fromMaybe defaultFixity <$> reifyFixityCompat o+ let push = go ((l,o,p,ofx):ts) r+ case ts of+ (l1,o1,p1,o1fx):ts' ->+ case compareFixity o1fx ofx of+ Just True -> go ((mkConT p1 o1 `AppT` l1 `AppT` l, o, p, ofx):ts') r+ Just False -> push+ Nothing -> fail (precedenceError o1 o1fx o ofx)+ _ -> push++ mkConT :: Bool -> Name -> Type+ mkConT promoted = if promoted then PromotedT else ConT++ compareFixity :: Fixity -> Fixity -> Maybe Bool+ compareFixity (Fixity n1 InfixL) (Fixity n2 InfixL) = Just (n1 >= n2)+ compareFixity (Fixity n1 InfixR) (Fixity n2 InfixR) = Just (n1 > n2)+ compareFixity (Fixity n1 _ ) (Fixity n2 _ ) =+ case compare n1 n2 of+ GT -> Just True+ LT -> Just False+ EQ -> Nothing++ precedenceError :: Name -> Fixity -> Name -> Fixity -> String+ precedenceError o1 ofx1 o2 ofx2 =+ "Precedence parsing error: cannot mix ‘" +++ nameBase o1 ++ "’ [" ++ showFixity ofx1 ++ "] and ‘" +++ nameBase o2 ++ "’ [" ++ showFixity ofx2 +++ "] in the same infix type expression"++data InfixList+ = ILCons Type -- The first argument to the type operator+ Name -- The name of the infix type operator+ Bool -- 'True' if this is a promoted infix data constructor,+ -- 'False' otherwise+ InfixList -- The rest of the infix applications to resolve+ | ILNil Type++ilAppend :: InfixList -> Name -> Bool -> InfixList -> InfixList+ilAppend (ILNil l) o p r = ILCons l o p r+ilAppend (ILCons l1 o1 p1 r1) o p r = ILCons l1 o1 p1 (ilAppend r1 o p r)+++-- | Render a 'Fixity' as it would appear in Haskell source.+--+-- Example: @infixl 5@+showFixity :: Fixity -> String+showFixity (Fixity n d) = showFixityDirection d ++ " " ++ show n+++-- | Render a 'FixityDirection' like it would appear in Haskell source.+--+-- Examples: @infixl@ @infixr@ @infix@+showFixityDirection :: FixityDirection -> String+showFixityDirection InfixL = "infixl"+showFixityDirection InfixR = "infixr"+showFixityDirection InfixN = "infix"++takeFieldNames :: [(Name,a,b)] -> [Name]+takeFieldNames xs = [a | (a,_,_) <- xs]++takeFieldStrictness :: [(a,Bang,b)] -> [FieldStrictness]+takeFieldStrictness xs = [normalizeStrictness a | (_,a,_) <- xs]++takeFieldTypes :: [(a,b,Type)] -> [Type]+takeFieldTypes xs = [a | (_,_,a) <- xs]++conHasRecord :: Name -> ConstructorInfo -> Bool+conHasRecord recName info =+ case constructorVariant info of+ NormalConstructor -> False+ InfixConstructor -> False+ RecordConstructor fields -> recName `elem` fields++------------------------------------------------------------------------++-- | Add universal quantifier for all free variables in the type. This is+-- useful when constructing a type signature for a declaration.+-- This code is careful to ensure that the order of the variables quantified+-- is determined by their order of appearance in the type signature. (In+-- contrast with being dependent upon the Ord instance for 'Name')+quantifyType :: Type -> Type+quantifyType t+ | null tvbs+ = t+ | ForallT tvbs' ctxt' t' <- t -- Collapse two consecutive foralls (#63)+ = ForallT (tvbs ++ tvbs') ctxt' t'+ | otherwise+ = ForallT tvbs [] t+ where+ tvbs = changeTVFlags SpecifiedSpec $ freeVariablesWellScoped [t]++-- | Take a list of 'Type's, find their free variables, and sort them+-- according to dependency order.+--+-- As an example of how this function works, consider the following type:+--+-- @+-- Proxy (a :: k)+-- @+--+-- Calling 'freeVariables' on this type would yield @[a, k]@, since that is+-- the order in which those variables appear in a left-to-right fashion. But+-- this order does not preserve the fact that @k@ is the kind of @a@. Moreover,+-- if you tried writing the type @forall a k. Proxy (a :: k)@, GHC would reject+-- this, since GHC would demand that @k@ come before @a@.+--+-- 'freeVariablesWellScoped' orders the free variables of a type in a way that+-- preserves this dependency ordering. If one were to call+-- 'freeVariablesWellScoped' on the type above, it would return+-- @[k, (a :: k)]@. (This is why 'freeVariablesWellScoped' returns a list of+-- 'TyVarBndr's instead of 'Name's, since it must make it explicit that @k@+-- is the kind of @a@.)+--+-- 'freeVariablesWellScoped' guarantees the free variables returned will be+-- ordered such that:+--+-- 1. Whenever an explicit kind signature of the form @(A :: K)@ is+-- encountered, the free variables of @K@ will always appear to the left of+-- the free variables of @A@ in the returned result.+--+-- 2. The constraint in (1) notwithstanding, free variables will appear in+-- left-to-right order of their original appearance.+--+-- On older GHCs, this takes measures to avoid returning explicitly bound+-- kind variables, which was not possible before @TypeInType@.+freeVariablesWellScoped :: [Type] -> [TyVarBndrUnit]+freeVariablesWellScoped tys =+ let fvs :: [Name]+ fvs = freeVariables tys++ varKindSigs :: Map Name Kind+ varKindSigs = foldMap go_ty tys+ where+ go_ty :: Type -> Map Name Kind+ go_ty (ForallT tvbs ctxt t) =+ foldr (\tvb -> Map.delete (tvName tvb))+ (foldMap go_ty ctxt `mappend` go_ty t) tvbs+ go_ty (AppT t1 t2) = go_ty t1 `mappend` go_ty t2+ go_ty (SigT t k) =+ let kSigs = go_ty k+ in case t of+ VarT n -> Map.insert n k kSigs+ _ -> go_ty t `mappend` kSigs+#if MIN_VERSION_template_haskell(2,15,0)+ go_ty (AppKindT t k) = go_ty t `mappend` go_ty k+ go_ty (ImplicitParamT _ t) = go_ty t+#endif+#if MIN_VERSION_template_haskell(2,16,0)+ go_ty (ForallVisT tvbs t) =+ foldr (\tvb -> Map.delete (tvName tvb)) (go_ty t) tvbs+#endif+ go_ty _ = mempty++ -- | Do a topological sort on a list of tyvars,+ -- so that binders occur before occurrences+ -- E.g. given [ a::k, k::*, b::k ]+ -- it'll return a well-scoped list [ k::*, a::k, b::k ]+ --+ -- This is a deterministic sorting operation+ -- (that is, doesn't depend on Uniques).+ --+ -- It is also meant to be stable: that is, variables should not+ -- be reordered unnecessarily.+ scopedSort :: [Name] -> [Name]+ scopedSort = go [] []++ go :: [Name] -- already sorted, in reverse order+ -> [Set Name] -- each set contains all the variables which must be placed+ -- before the tv corresponding to the set; they are accumulations+ -- of the fvs in the sorted tvs' kinds++ -- This list is in 1-to-1 correspondence with the sorted tyvars+ -- INVARIANT:+ -- all (\tl -> all (`isSubsetOf` head tl) (tail tl)) (tails fv_list)+ -- That is, each set in the list is a superset of all later sets.+ -> [Name] -- yet to be sorted+ -> [Name]+ go acc _fv_list [] = reverse acc+ go acc fv_list (tv:tvs)+ = go acc' fv_list' tvs+ where+ (acc', fv_list') = insert tv acc fv_list++ insert :: Name -- var to insert+ -> [Name] -- sorted list, in reverse order+ -> [Set Name] -- list of fvs, as above+ -> ([Name], [Set Name]) -- augmented lists+ insert tv [] [] = ([tv], [kindFVSet tv])+ insert tv (a:as) (fvs:fvss)+ | tv `Set.member` fvs+ , (as', fvss') <- insert tv as fvss+ = (a:as', fvs `Set.union` fv_tv : fvss')++ | otherwise+ = (tv:a:as, fvs `Set.union` fv_tv : fvs : fvss)+ where+ fv_tv = kindFVSet tv++ -- lists not in correspondence+ insert _ _ _ = error "scopedSort"++ kindFVSet n =+ maybe Set.empty (Set.fromList . freeVariables) (Map.lookup n varKindSigs)+ ascribeWithKind n =+ maybe (plainTV n) (kindedTV n) (Map.lookup n varKindSigs)++ in map ascribeWithKind $ scopedSort fvs++-- | Substitute all of the free variables in a type with fresh ones+freshenFreeVariables :: Type -> Q Type+freshenFreeVariables t =+ do let xs = [ (n, VarT <$> newName (nameBase n)) | n <- freeVariables t]+ subst <- T.sequence (Map.fromList xs)+ return (applySubstitution subst t)+++-- | Class for types that support type variable substitution.+class TypeSubstitution a where+ -- | Apply a type variable substitution.+ applySubstitution :: Map Name Type -> a -> a+ -- | Compute the free type variables+ freeVariables :: a -> [Name]++instance TypeSubstitution a => TypeSubstitution [a] where+ freeVariables = nub . concat . map freeVariables+ applySubstitution = fmap . applySubstitution++instance TypeSubstitution Type where+ applySubstitution subst = go+ where+ go (ForallT tvs context t) =+ let (subst', tvs') = substTyVarBndrs subst tvs in+ ForallT tvs'+ (applySubstitution subst' context)+ (applySubstitution subst' t)+ go (AppT f x) = AppT (go f) (go x)+ go (SigT t k) = SigT (go t) (applySubstitution subst k) -- k could be Kind+ go (VarT v) = Map.findWithDefault (VarT v) v subst+ go (InfixT l c r) = InfixT (go l) c (go r)+ go (UInfixT l c r) = UInfixT (go l) c (go r)+ go (ParensT t) = ParensT (go t)+#if MIN_VERSION_template_haskell(2,15,0)+ go (AppKindT t k) = AppKindT (go t) (go k)+ go (ImplicitParamT n t)+ = ImplicitParamT n (go t)+#endif+#if MIN_VERSION_template_haskell(2,16,0)+ go (ForallVisT tvs t) =+ let (subst', tvs') = substTyVarBndrs subst tvs in+ ForallVisT tvs'+ (applySubstitution subst' t)+#endif+#if MIN_VERSION_template_haskell(2,19,0)+ go (PromotedInfixT l c r)+ = PromotedInfixT (go l) c (go r)+ go (PromotedUInfixT l c r)+ = PromotedUInfixT (go l) c (go r)+#endif+ go t = t++ subst_tvbs :: [TyVarBndr_ flag] -> (Map Name Type -> a) -> a+ subst_tvbs tvs k = k $ foldl' (flip Map.delete) subst (map tvName tvs)++ freeVariables t =+ case t of+ ForallT tvs context t' ->+ fvs_under_forall tvs (freeVariables context `union` freeVariables t')+ AppT f x -> freeVariables f `union` freeVariables x+ SigT t' k -> freeVariables t' `union` freeVariables k+ VarT v -> [v]+ InfixT l _ r -> freeVariables l `union` freeVariables r+ UInfixT l _ r -> freeVariables l `union` freeVariables r+ ParensT t' -> freeVariables t'+#if MIN_VERSION_template_haskell(2,15,0)+ AppKindT t k -> freeVariables t `union` freeVariables k+ ImplicitParamT _ t+ -> freeVariables t+#endif+#if MIN_VERSION_template_haskell(2,16,0)+ ForallVisT tvs t'+ -> fvs_under_forall tvs (freeVariables t')+#endif+#if MIN_VERSION_template_haskell(2,19,0)+ PromotedInfixT l _ r+ -> freeVariables l `union` freeVariables r+ PromotedUInfixT l _ r+ -> freeVariables l `union` freeVariables r+#endif+ _ -> []+ where+ fvs_under_forall :: [TyVarBndr_ flag] -> [Name] -> [Name]+ fvs_under_forall tvs fvs =+ (freeVariables (map tvKind tvs) `union` fvs)+ \\ map tvName tvs++instance TypeSubstitution ConstructorInfo where+ freeVariables ci =+ (freeVariables (map tvKind (constructorVars ci))+ `union` freeVariables (constructorContext ci)+ `union` freeVariables (constructorFields ci))+ \\ (tvName <$> constructorVars ci)++ applySubstitution subst ci =+ let subst' = foldl' (flip Map.delete) subst (map tvName (constructorVars ci)) in+ ci { constructorVars = map (mapTVKind (applySubstitution subst'))+ (constructorVars ci)+ , constructorContext = applySubstitution subst' (constructorContext ci)+ , constructorFields = applySubstitution subst' (constructorFields ci)+ }++-- | Substitutes into the kinds of type variable binders. This makes an effort+-- to avoid capturing the 'TyVarBndr' names during substitution by+-- alpha-renaming names if absolutely necessary. For a version of this function+-- which does /not/ avoid capture, see 'substTyVarBndrKinds'.+substTyVarBndrs :: Map Name Type -> [TyVarBndr_ flag] -> (Map Name Type, [TyVarBndr_ flag])+substTyVarBndrs = mapAccumL substTyVarBndr++-- | The workhorse for 'substTyVarBndrs'.+substTyVarBndr :: Map Name Type -> TyVarBndr_ flag -> (Map Name Type, TyVarBndr_ flag)+substTyVarBndr subst tvb+ | tvbName `Map.member` subst+ = (Map.delete tvbName subst, mapTVKind (applySubstitution subst) tvb)+ | tvbName `Set.notMember` substRangeFVs+ = (subst, mapTVKind (applySubstitution subst) tvb)+ | otherwise+ = let tvbName' = evade tvbName in+ ( Map.insert tvbName (VarT tvbName') subst+ , mapTV (\_ -> tvbName') id (applySubstitution subst) tvb+ )+ where+ tvbName :: Name+ tvbName = tvName tvb++ substRangeFVs :: Set Name+ substRangeFVs = Set.fromList $ freeVariables $ Map.elems subst++ evade :: Name -> Name+ evade n | n `Set.member` substRangeFVs+ = evade $ bump n+ | otherwise+ = n++ -- An improvement would be to try a variety of different characters instead+ -- of prepending the same character repeatedly. Let's wait to see if+ -- someone complains about this before making this more complicated,+ -- however.+ bump :: Name -> Name+ bump n = mkName $ 'f':nameBase n++-- | Substitutes into the kinds of type variable binders. This is slightly more+-- efficient than 'substTyVarBndrs', but at the expense of not avoiding+-- capture. Only use this function in situations where you know that none of+-- the 'TyVarBndr' names are contained in the range of the substitution.+substTyVarBndrKinds :: Map Name Type -> [TyVarBndr_ flag] -> [TyVarBndr_ flag]+substTyVarBndrKinds subst = map (substTyVarBndrKind subst)++-- | The workhorse for 'substTyVarBndrKinds'.+substTyVarBndrKind :: Map Name Type -> TyVarBndr_ flag -> TyVarBndr_ flag+substTyVarBndrKind subst = mapTVKind (applySubstitution subst)++------------------------------------------------------------------------++combineSubstitutions :: Map Name Type -> Map Name Type -> Map Name Type+combineSubstitutions x y = Map.union (fmap (applySubstitution y) x) y++-- | Compute the type variable substitution that unifies a list of types,+-- or fail in 'Q'.+--+-- All infix issue should be resolved before using 'unifyTypes'+--+-- Alpha equivalent quantified types are not unified.+unifyTypes :: [Type] -> Q (Map Name Type)+unifyTypes [] = return Map.empty+unifyTypes (t:ts) =+ do t':ts' <- mapM resolveTypeSynonyms (t:ts)+ let aux sub u =+ do sub' <- unify' (applySubstitution sub t')+ (applySubstitution sub u)+ return (combineSubstitutions sub sub')++ case foldM aux Map.empty ts' of+ Right m -> return m+ Left (x,y) ->+ fail $ showString "Unable to unify types "+ . showsPrec 11 x+ . showString " and "+ . showsPrec 11 y+ $ ""++unify' :: Type -> Type -> Either (Type,Type) (Map Name Type)++unify' (VarT n) (VarT m) | n == m = pure Map.empty+unify' (VarT n) t | n `elem` freeVariables t = Left (VarT n, t)+ | otherwise = Right (Map.singleton n t)+unify' t (VarT n) | n `elem` freeVariables t = Left (VarT n, t)+ | otherwise = Right (Map.singleton n t)++unify' (AppT f1 x1) (AppT f2 x2) =+ do sub1 <- unify' f1 f2+ sub2 <- unify' (applySubstitution sub1 x1) (applySubstitution sub1 x2)+ Right (combineSubstitutions sub1 sub2)++-- Doesn't unify kind signatures+unify' (SigT t _) u = unify' t u+unify' t (SigT u _) = unify' t u++-- only non-recursive cases should remain at this point+unify' t u+ | t == u = Right Map.empty+ | otherwise = Left (t,u)+++-- | Construct an equality constraint. The implementation of 'Pred' varies+-- across versions of Template Haskell.+equalPred :: Type -> Type -> Pred+equalPred x y = AppT (AppT EqualityT x) y++-- | Construct a typeclass constraint. The implementation of 'Pred' varies+-- across versions of Template Haskell.+classPred :: Name {- ^ class -} -> [Type] {- ^ parameters -} -> Pred+classPred = foldl AppT . ConT++-- | Match a 'Pred' representing an equality constraint. Returns+-- arguments to the equality constraint if successful.+asEqualPred :: Pred -> Maybe (Type,Type)+asEqualPred (EqualityT `AppT` x `AppT` y) = Just (x,y)+asEqualPred (ConT eq `AppT` x `AppT` y) | eq == eqTypeName = Just (x,y)+asEqualPred _ = Nothing++-- | Match a 'Pred' representing a class constraint.+-- Returns the classname and parameters if successful.+asClassPred :: Pred -> Maybe (Name, [Type])+asClassPred t =+ case decomposeType t of+ ConT f :| xs | f /= eqTypeName -> Just (f,xs)+ _ -> Nothing++------------------------------------------------------------------------++-- | If we are working with a 'Dec' obtained via 'reify' (as opposed to one+-- created from, say, [d| ... |] quotes), then we need to apply more hacks than+-- we otherwise would to sanitize the 'Dec'. See #28.+type IsReifiedDec = Bool++isReified, isn'tReified :: IsReifiedDec+isReified = True+isn'tReified = False++-- On old versions of GHC, reify would not give you kind signatures for+-- GADT type variables of kind *. To work around this, we insert the kinds+-- manually on any reified type variable binders without a signature. However,+-- don't do this for quoted type variable binders (#84).++giveDIVarsStarKinds :: IsReifiedDec -> DatatypeInfo -> DatatypeInfo+giveDIVarsStarKinds isReified info =+ info { datatypeVars = map (giveTyVarBndrStarKind isReified) (datatypeVars info)+ , datatypeInstTypes = map (giveTypeStarKind isReified) (datatypeInstTypes info) }++giveCIVarsStarKinds :: IsReifiedDec -> ConstructorInfo -> ConstructorInfo+giveCIVarsStarKinds isReified info =+ info { constructorVars = map (giveTyVarBndrStarKind isReified) (constructorVars info) }++giveTyVarBndrStarKind :: IsReifiedDec -> TyVarBndrUnit -> TyVarBndrUnit+giveTyVarBndrStarKind isReified tvb+ | isReified+ = elimTV (\n -> kindedTV n starK) (\_ _ -> tvb) tvb+ | otherwise+ = tvb++giveTypeStarKind :: IsReifiedDec -> Type -> Type+giveTypeStarKind isReified t+ | isReified+ = case t of+ VarT n -> SigT t starK+ _ -> t+ | otherwise+ = t++-- | Prior to GHC 8.2.1, reify was broken for data instances and newtype+-- instances. This code attempts to detect the problem and repair it if+-- possible.+--+-- The particular problem is that the type variables used in the patterns+-- while defining a data family instance do not completely match those+-- used when defining the fields of the value constructors beyond the+-- base names. This code attempts to recover the relationship between the+-- type variables.+--+-- It is possible, however, to generate these kinds of declarations by+-- means other than reify. In these cases the name bases might not be+-- unique and the declarations might be well formed. In such a case this+-- code attempts to avoid altering the declaration.+--+-- https://ghc.haskell.org/trac/ghc/ticket/13618+repair13618 :: DatatypeInfo -> Q DatatypeInfo+repair13618 info =+ do s <- T.sequence (Map.fromList substList)+ return info { datatypeCons = applySubstitution s (datatypeCons info) }++ where+ used = freeVariables (datatypeCons info)+ bound = map tvName (datatypeVars info)+ free = used \\ bound++ substList =+ [ (u, substEntry u vs)+ | u <- free+ , let vs = [v | v <- bound, nameBase v == nameBase u]+ ]++ substEntry _ [v] = varT v+ substEntry u [] = fail ("Impossible free variable: " ++ show u)+ substEntry u _ = fail ("Ambiguous free variable: " ++ show u)++------------------------------------------------------------------------++-- | Backward compatible version of 'dataD'+dataDCompat ::+ CxtQ {- ^ context -} ->+ Name {- ^ type constructor -} ->+ [TyVarBndrVis] {- ^ type parameters -} ->+ [ConQ] {- ^ constructor definitions -} ->+ [Name] {- ^ derived class names -} ->+ DecQ+#if MIN_VERSION_template_haskell(2,12,0)+dataDCompat c n ts cs ds =+ dataD c n ts Nothing cs+ (if null ds then [] else [derivClause Nothing (map conT ds)])+#else+dataDCompat c n ts cs ds =+ dataD c n ts Nothing cs+ (return (map ConT ds))+#endif++-- | Backward compatible version of 'newtypeD'+newtypeDCompat ::+ CxtQ {- ^ context -} ->+ Name {- ^ type constructor -} ->+ [TyVarBndrVis] {- ^ type parameters -} ->+ ConQ {- ^ constructor definition -} ->+ [Name] {- ^ derived class names -} ->+ DecQ+#if MIN_VERSION_template_haskell(2,12,0)+newtypeDCompat c n ts cs ds =+ newtypeD c n ts Nothing cs+ (if null ds then [] else [derivClause Nothing (map conT ds)])+#else+newtypeDCompat c n ts cs ds =+ newtypeD c n ts Nothing cs+ (return (map ConT ds))+#endif++-- | Backward compatible version of 'tySynInstD'+tySynInstDCompat ::+ Name {- ^ type family name -} ->+ Maybe [Q TyVarBndrUnit] {- ^ type variable binders -} ->+ [TypeQ] {- ^ instance parameters -} ->+ TypeQ {- ^ instance result -} ->+ DecQ+#if MIN_VERSION_template_haskell(2,15,0)+tySynInstDCompat n mtvbs ps r = TySynInstD <$> (TySynEqn <$> mapM sequence mtvbs+ <*> foldl' appT (conT n) ps+ <*> r)+#else+tySynInstDCompat n _ ps r = TySynInstD n <$> (TySynEqn <$> sequence ps <*> r)+#endif++-- | Backward compatible version of 'pragLineD'. Returns+-- 'Nothing' if line pragmas are not suported.+pragLineDCompat ::+ Int {- ^ line number -} ->+ String {- ^ file name -} ->+ Maybe DecQ+pragLineDCompat ln fn = Just (pragLineD ln fn)++arrowKCompat :: Kind -> Kind -> Kind+arrowKCompat x y = arrowK `appK` x `appK` y++------------------------------------------------------------------------++-- | Backwards compatibility wrapper for 'Fixity' lookup.+--+-- In @template-haskell-2.11.0.0@ and later, the answer will always+-- be 'Just' of a fixity.+--+-- Before @template-haskell-2.11.0.0@ it was only possible to determine+-- fixity information for variables, class methods, and data constructors.+-- In this case for type operators the answer could be 'Nothing', which+-- indicates that the answer is unavailable.+reifyFixityCompat :: Name -> Q (Maybe Fixity)+reifyFixityCompat n = recover (return Nothing) ((`mplus` Just defaultFixity) <$> reifyFixity n) -- | Call 'reify' and return @'Just' info@ if successful or 'Nothing' if -- reification failed.
src/Language/Haskell/TH/Datatype/Internal.hs view
@@ -1,5 +1,12 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskellQuotes #-} +#if MIN_VERSION_template_haskell(2,12,0)+{-# Language Safe #-}+#else+{-# Language Trustworthy #-}+#endif+ {-| Module : Language.Haskell.TH.Datatype.Internal Description : Backwards-compatible interface to reified information about datatypes.@@ -14,15 +21,13 @@ import Language.Haskell.TH.Syntax +#if MIN_VERSION_base(4,13,0)+import Data.Type.Equality+#endif+ eqTypeName :: Name-#if MIN_VERSION_base(4,9,0) && __GLASGOW_HASKELL__ < 807- -- TODO: Replace __GLASGOW_HASKELL__ < 807 with- -- !(MIN_VERSION_base(4,13,0)) once base-4.13 exists-eqTypeName = mkNameG_tc "base" "Data.Type.Equality" "~"+#if MIN_VERSION_base(4,13,0)+eqTypeName = ''(~) #else-eqTypeName = mkNameG_tc "ghc-prim" "GHC.Types" "~"+eqTypeName = mkNameG_tc "base" "Data.Type.Equality" "~" #endif---- This is only needed for GHC 7.6-specific bug-starKindName :: Name-starKindName = mkNameG_tc "ghc-prim" "GHC.Prim" "*"
+ src/Language/Haskell/TH/Datatype/TyVarBndr.hs view
@@ -0,0 +1,467 @@+{-# Language CPP, DeriveDataTypeable, DeriveGeneric, DeriveLift, PatternSynonyms, ViewPatterns #-}++#if MIN_VERSION_template_haskell(2,12,0)+{-# Language Safe #-}+#else+{-# Language Trustworthy #-}+#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+ , TyVarBndrVis+ , Specificity(..)+#if __GLASGOW_HASKELL__ >= 907+ , BndrVis(..)+#else+ , BndrVis+ , pattern BndrReq+ , pattern BndrInvis+#endif+ , DefaultBndrFlag(..)++ -- * Constructing @TyVarBndr@s+ -- ** @flag@-polymorphic+ , plainTVFlag+ , kindedTVFlag+ -- ** @TyVarBndrUnit@+ , plainTV+ , kindedTV+ -- ** @TyVarBndrSpec@+ , plainTVInferred+ , plainTVSpecified+ , kindedTVInferred+ , kindedTVSpecified+ -- ** @TyVarBndrVis@+ , plainTVReq+ , plainTVInvis+ , kindedTVReq+ , kindedTVInvis++ -- * Constructing @Specificity@+ , inferredSpec+ , specifiedSpec++ -- * Constructing @BndrVis@+ , bndrReq+ , bndrInvis++ -- * Modifying @TyVarBndr@s+ , elimTV+ , elimTVFlag+ , mapTV+ , mapTVName+ , mapTVFlag+ , mapTVKind+ , traverseTV+ , traverseTVName+ , traverseTVFlag+ , traverseTVKind+ , mapMTV+ , mapMTVName+ , mapMTVFlag+ , mapMTVKind+ , changeTVFlags++ -- * Properties of @TyVarBndr@s+ , tvName+ , tvKind+ , tvFlag+ ) where++import Control.Applicative+import Control.Monad+import Data.Data (Data)+import GHC.Generics (Generic)+import Language.Haskell.TH.Lib+import Language.Haskell.TH.Syntax++-- | 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 (if it has one).+#if MIN_VERSION_template_haskell(2,17,0)+type TyVarBndr_ flag = TyVarBndr flag+#else+type TyVarBndr_ flag = TyVarBndr++-- | A 'TyVarBndr' without a flag. This is used for 'TyVarBndr's that do not+-- interact with visible type application and are not binders for type-level+-- declarations.+type TyVarBndrUnit = TyVarBndr++-- | A 'TyVarBndr' with a 'Specificity' flag. This is used for 'TyVarBndr's that+-- interact with visible type application.+type TyVarBndrSpec = TyVarBndr++-- | Determines how a 'TyVarBndr' interacts with visible type application.+data Specificity+ = SpecifiedSpec -- ^ @a@. Eligible for visible type application.+ | InferredSpec -- ^ @{a}@. Not eligible for visible type application.+ deriving (Show, Eq, Ord, Data, Generic, Lift)++inferredSpec :: Specificity+inferredSpec = InferredSpec++specifiedSpec :: Specificity+specifiedSpec = SpecifiedSpec+#endif++#if !MIN_VERSION_template_haskell(2,21,0)+-- | A 'TyVarBndr' with a 'BndrVis' flag. This is used for 'TyVarBndr's in+-- type-level declarations (e.g., the binders in @data D \@k (a :: k)@).+type TyVarBndrVis = TyVarBndr_ BndrVis++-- | Because pre-9.8 GHCs do not support invisible binders in type-level+-- declarations, we simply make 'BndrVis' an alias for @()@ as a compatibility+-- shim for old GHCs. This matches how type-level 'TyVarBndr's were flagged+-- prior to GHC 9.8.+type BndrVis = ()+#if __GLASGOW_HASKELL__ >= 802+{-# COMPLETE BndrReq, BndrInvis #-}+#endif++-- | Because pre-9.8 GHCs do not support invisible binders in type-level+-- declarations, we simply make 'BndrReq' a pattern synonym for @()@ as a+-- compatibility shim for old GHCs. This matches how type-level 'TyVarBndr's+-- were flagged prior to GHC 9.8.+pattern BndrReq :: BndrVis+pattern BndrReq = ()++-- | Because pre-9.8 GHCs do not support invisible binders in type-level+-- declarations, this compatibility shim is defined in a somewhat unusual way:+--+-- * As a pattern, 'BndrInvis' will never match on pre-9.8 GHCs. That way, if+-- you write pattern matches like this:+--+-- @+-- case flag of+-- 'BndrInvis' -> ...+-- 'BndrVis' -> ...+-- @+--+-- Then the first branch will never be taken on pre-9.8 GHCs.+--+-- * 'BndrInvis' is a unidirectional pattern synonym on pre-9.8 GHCs, so it+-- cannot be used as an expression on these GHC versions. This is done in an+-- effort to avoid pitfalls that could occur if 'BndrInvis' were defined like+-- so:+--+-- @+-- pattern 'BndrInvis' = ()+-- @+--+-- If this were the definition, then a user could write code involving+-- 'BndrInvis' that would construct an invisible type-level binder on GHC 9.8+-- or later, but a /visible/ type-level binder on older GHCs! This would be+-- disastrous, so we prevent the user from doing such a thing.+pattern BndrInvis :: BndrVis+pattern BndrInvis <- ((\() -> True) -> False)++bndrReq :: BndrVis+bndrReq = ()++bndrInvis :: BndrVis+bndrInvis = ()++-- | A class characterizing reasonable default values for various 'TyVarBndr'+-- @flag@ types.+class DefaultBndrFlag flag where+ defaultBndrFlag :: flag++instance DefaultBndrFlag () where+ defaultBndrFlag = ()++instance DefaultBndrFlag Specificity where+ defaultBndrFlag = SpecifiedSpec+#endif++-- | Construct a 'PlainTV' with the given @flag@.+plainTVFlag :: Name -> flag -> TyVarBndr_ flag+#if MIN_VERSION_template_haskell(2,17,0)+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 'PlainTV' with a 'BndrReq'.+plainTVReq :: Name -> TyVarBndrVis+plainTVReq n = plainTVFlag n bndrReq++-- | Construct a 'PlainTV' with a 'BndrInvis'.+plainTVInvis :: Name -> TyVarBndrVis+plainTVInvis n = plainTVFlag n bndrInvis++-- | Construct a 'KindedTV' with the given @flag@.+kindedTVFlag :: Name -> flag -> Kind -> TyVarBndr_ flag+#if MIN_VERSION_template_haskell(2,17,0)+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++-- | Construct a 'KindedTV' with a 'BndrReq'.+kindedTVReq :: Name -> Kind -> TyVarBndrVis+kindedTVReq n k = kindedTVFlag n bndrReq k++-- | Construct a 'KindedTV' with a 'BndrInvis'.+kindedTVInvis :: Name -> Kind -> TyVarBndrVis+kindedTVInvis n k = kindedTVFlag n bndrInvis k++-- | Case analysis for a 'TyVarBndr'. If the value is a @'PlainTV' n _@, apply+-- the first function to @n@; if it is @'KindedTV' n _ k@, apply the second+-- function to @n@ and @k@.+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++-- | Case analysis for a 'TyVarBndr' that includes @flag@s in the continuation+-- arguments. Note that 'TyVarBndr's did not include @flag@s prior to+-- @template-haskell-2.17.0.0@, so on older versions of @template-haskell@,+-- these @flag@s instead become @()@.+#if MIN_VERSION_template_haskell(2,17,0)+elimTVFlag :: (Name -> flag -> r) -> (Name -> flag -> Kind -> r) -> TyVarBndr_ flag -> r+elimTVFlag ptv _ktv (PlainTV n flag) = ptv n flag+elimTVFlag _ptv ktv (KindedTV n flag k) = ktv n flag k+#else+elimTVFlag :: (Name -> () -> r) -> (Name -> () -> Kind -> r) -> TyVarBndr_ flag -> r+elimTVFlag ptv _ktv (PlainTV n) = ptv n ()+elimTVFlag _ptv ktv (KindedTV n k) = ktv n () k+#endif++-- | Map over the components of a 'TyVarBndr'.+mapTV :: (Name -> Name) -> (flag -> flag') -> (Kind -> Kind)+ -> TyVarBndr_ flag -> TyVarBndr_ flag'+#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)++-- | Extract the @flag@ from a 'TyVarBndr'. Note that 'TyVarBndr's did not+-- include @flag@s prior to @template-haskell-2.17.0.0@, so on older versions of+-- @template-haskell@, this functions instead returns @()@.+#if MIN_VERSION_template_haskell(2,17,0)+tvFlag :: TyVarBndr_ flag -> flag+tvFlag = elimTVFlag (\_ flag -> flag) (\_ flag _ -> flag)+#else+tvFlag :: TyVarBndr_ flag -> ()+tvFlag _ = ()+#endif
test/Harness.hs view
@@ -16,9 +16,6 @@ ( validateDI , validateCI , equateCxt-- -- * Utilities- , varKCompat ) where import Control.Monad@@ -27,6 +24,7 @@ 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@@ -39,25 +37,34 @@ validate equate x y = either fail (\_ -> [| return () |]) (equate x y) -- | If the arguments are equal up to renaming return @'Right' ()@,--- otherwise return a string exlaining the mismatch.+-- 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 "datatypeVariant" datatypeVariant dat1 dat2- check "datatypeCons len" (length . datatypeCons) 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+ let sub = Map.fromList (zip (freeVariables (bndrParams (datatypeVars dat2)))+ (map VarT (freeVariables (bndrParams (datatypeVars dat1)))))+ check "datatypeReturnKind"+ id+ (datatypeReturnKind dat1)+ (applySubstitution sub $ datatypeReturnKind dat2)+ check "datatypeCons len" (length . datatypeCons) dat1 dat2 - let sub = Map.fromList (zip (freeVariables (datatypeVars dat2))- (map VarT (freeVariables (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)) - check "datatypeVars" id- (datatypeVars dat1)- (applySubstitution sub (datatypeVars dat2))- zipWithM_ equateCI (datatypeCons dat1) (datatypeCons dat2) -- Don't bother applying the substitution here, as@@ -69,20 +76,17 @@ check (lbl ++ " equality") asEqualPred pred1 pred2 -- | If the arguments are equal up to renaming return @'Right' ()@,--- otherwise return a string exlaining the mismatch.+-- 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 (map tvName (constructorVars con2))- (map VarT (map tvName (constructorVars con1))))- sub2 = Map.fromList (zip (freeVariables (map tvKind (constructorVars con2)))- (map VarT (freeVariables- (map tvKind (constructorVars con1)))))- sub3 = Map.fromList (zip (freeVariables 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, sub3]+ sub = Map.unions [sub1, sub2] zipWithM_ (equateCxt "constructorContext") (constructorContext con1)@@ -107,46 +111,27 @@ i@InfixConstructor{} -> i RecordConstructor fields -> RecordConstructor $ map (mkName . nameBase) fields - -- Substitutes both type variable names and kinds.- substIntoTyVarBndrs :: Map Name Type -> [TyVarBndr] -> [TyVarBndr]- substIntoTyVarBndrs subst = map go- where- go (PlainTV n) = PlainTV $ substName subst n- go (KindedTV n k) = KindedTV (substName subst n)- (applySubstitution subst k)+-- 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+ 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 "constructorStrictness" id fs1 fs2 check :: (Show b, Eq b) => String -> (a -> b) -> a -> a -> Either String () check lbl f x y | f x == f y = Right () | otherwise = Left (lbl ++ ":\n\n" ++ show (f x) ++ "\n\n" ++ show (f y))---- If on a recent-enough version of Template Haskell, construct a kind variable.--- Otherwise, default to starK.-varKCompat :: Name -> Kind-#if MIN_VERSION_template_haskell(2,8,0)-varKCompat = VarT-#else-varKCompat _ = starK-#endif
test/Main.hs view
@@ -1,13 +1,25 @@-{-# Language CPP, FlexibleContexts, TypeFamilies, KindSignatures, TemplateHaskell, GADTs #-}+{-# Language CPP, FlexibleContexts, TypeFamilies, KindSignatures, TemplateHaskell, GADTs, RankNTypes, MagicHash, ConstraintKinds, PolyKinds #-} -#if __GLASGOW_HASKELL__ >= 704-{-# LANGUAGE ConstraintKinds #-}+#if __GLASGOW_HASKELL__ < 806+{-# Language TypeInType #-} #endif -#if MIN_VERSION_template_haskell(2,8,0)-{-# Language PolyKinds #-}+#if __GLASGOW_HASKELL__ >= 807+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeApplications #-} #endif +#if MIN_VERSION_template_haskell(2,21,0)+{-# Language TypeAbstractions #-}+#endif++#if MIN_VERSION_template_haskell(2,18,0)+{-# LANGUAGE UnliftedDatatypes #-}+#endif++-- We should aim to enable -Wincomplete-uni-patterns long-term. See #121.+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ {-| Module : Main Description : Test cases for the th-abstraction package@@ -22,19 +34,24 @@ -} module Main (main) where -#if __GLASGOW_HASKELL__ >= 704-import Control.Monad (zipWithM_)-#endif--import Control.Monad (unless)+import Control.Monad (unless, when, zipWithM_) import qualified Data.Map as Map--#if MIN_VERSION_base(4,7,0)+import Data.Kind import Data.Type.Equality ((:~:)(..))++#if __GLASGOW_HASKELL__ >= 810+import GHC.Exts (Any, RuntimeRep(..), TYPE) #endif+#if __GLASGOW_HASKELL__ >= 902+import GHC.Exts (UnliftedType, Levity(..))+#endif -import Language.Haskell.TH-import Language.Haskell.TH.Datatype+import GHC.Exts (Array#)++import qualified Language.Haskell.TH as TH (Type)+import Language.Haskell.TH hiding (Type)+import Language.Haskell.TH.Datatype as Datatype+import Language.Haskell.TH.Datatype.TyVarBndr import Language.Haskell.TH.Lib (starK) import Harness@@ -53,10 +70,8 @@ voidstosTest strictDemoTest recordVanillaTest-#if MIN_VERSION_template_haskell(2,6,0) t43Test-#endif-#if MIN_VERSION_template_haskell(2,7,0)+ t58Test dataFamilyTest ghc78bugTest quotedTest@@ -66,48 +81,77 @@ famLocalDecTest2 recordFamTest t46Test-#endif+ t73Test+ t95Test 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+ t79TestA+#if MIN_VERSION_template_haskell(2,19,0)+ t79TestB #endif-#if __GLASGOW_HASKELL__ >= 800 t37Test polyKindedExTyvarTest+#if __GLASGOW_HASKELL__ >= 807+ resolveTypeSynonymsVKATest #endif regressionTest44 t63Test t70Test+ t88Test+ captureAvoidanceTest+#if MIN_VERSION_template_haskell(2,20,0)+ t100Test+#endif+#if MIN_VERSION_template_haskell(2,21,0)+ t103Test+#endif+#if __GLASGOW_HASKELL__ >= 810+ t107Test+ t108Test+#endif+#if __GLASGOW_HASKELL__ >= 804+ t110Test+#endif+#if MIN_VERSION_template_haskell(2,16,0)+ unboxedTupleTest+#endif+#if MIN_VERSION_template_haskell(2,18,0)+ unliftedGADTDecTest+#endif+ primTyConTest + adt1Test :: IO () adt1Test = $(do info <- reifyDatatype ''Adt1 - let vars@[a,b] = map (VarT . mkName) ["a","b"]- [aSig,bSig] = map (\v -> SigT v starK) vars+ 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 = [aSig, bSig]+ , datatypeVars = [aTvb,bTvb]+ , datatypeInstTypes = [aSig, bSig] , datatypeVariant = Datatype+ , datatypeReturnKind = starK , datatypeCons = [ ConstructorInfo { constructorName = 'Adtc1 , constructorContext = [] , constructorVars = []- , constructorFields = [AppT (AppT (TupleT 2) a) b]+ , constructorFields = [AppT (AppT (TupleT 2) aVar) bVar] , constructorStrictness = [notStrictAnnot] , constructorVariant = NormalConstructor } , ConstructorInfo@@ -125,19 +169,22 @@ gadt1Test = $(do info <- reifyDatatype ''Gadt1 - let a = VarT (mkName "a")+ let a = mkName "a"+ aVar = VarT a validateDI info DatatypeInfo { datatypeName = ''Gadt1 , datatypeContext = []- , datatypeVars = [SigT a starK]+ , datatypeVars = [kindedTV a starK]+ , datatypeInstTypes = [SigT aVar starK] , datatypeVariant = Datatype+ , datatypeReturnKind = starK , datatypeCons = [ ConstructorInfo { constructorName = 'Gadtc1 , constructorVars = []- , constructorContext = [equalPred a (ConT ''Int)]+ , constructorContext = [equalPred aVar (ConT ''Int)] , constructorFields = [ConT ''Int] , constructorStrictness = [notStrictAnnot] , constructorVariant = NormalConstructor }@@ -145,20 +192,20 @@ { constructorName = 'Gadtc2 , constructorVars = [] , constructorContext = []- , constructorFields = [AppT (AppT (TupleT 2) a) a]+ , constructorFields = [AppT (AppT (TupleT 2) aVar) aVar] , constructorStrictness = [notStrictAnnot] , constructorVariant = NormalConstructor } , ConstructorInfo { constructorName = '(:**:) , constructorVars = []- , constructorContext = [equalPred a (TupleT 0)]+ , constructorContext = [equalPred aVar (TupleT 0)] , constructorFields = [ConT ''Bool, ConT ''Char] , constructorStrictness = [notStrictAnnot, notStrictAnnot] , constructorVariant = InfixConstructor } , ConstructorInfo { constructorName = '(:!!:) , constructorVars = []- , constructorContext = [equalPred a (ConT ''Double)]+ , constructorContext = [equalPred aVar (ConT ''Double)] , constructorFields = [ConT ''Char, ConT ''Bool] , constructorStrictness = [notStrictAnnot, notStrictAnnot] , constructorVariant = NormalConstructor }@@ -170,15 +217,18 @@ gadtrec1Test = $(do info <- reifyDatatype ''Gadtrec1 - let con = gadtRecVanillaCI+ let a = mkName "a"+ con = gadtRecVanillaCI validateDI info DatatypeInfo- { datatypeName = ''Gadtrec1- , datatypeContext = []- , datatypeVars = [SigT (VarT (mkName "a")) starK]- , datatypeVariant = Datatype- , datatypeCons =+ { datatypeName = ''Gadtrec1+ , datatypeContext = []+ , datatypeVars = [kindedTV a starK]+ , datatypeInstTypes = [SigT (VarT a) starK]+ , datatypeVariant = Datatype+ , datatypeReturnKind = starK+ , datatypeCons = [ con, con { constructorName = 'Gadtrecc2 } ] } )@@ -187,23 +237,31 @@ equalTest = $(do info <- reifyDatatype ''Equal - let vars@[a,b,c] = map (VarT . mkName) ["a","b","c"]- [aSig,bSig,cSig] = map (\v -> SigT v starK) vars+ 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 = [aSig, bSig, cSig]- , datatypeVariant = Datatype- , datatypeCons =+ { datatypeName = ''Equal+ , datatypeContext = []+ , datatypeVars = [aTvb, bTvb, cTvb]+ , datatypeInstTypes = [aSig, bSig, cSig]+ , datatypeVariant = Datatype+ , datatypeReturnKind = starK+ , datatypeCons = [ ConstructorInfo { constructorName = 'Equalc , constructorVars = [] , constructorContext =- [equalPred a c, equalPred b c, classPred ''Read [c], classPred ''Show [c] ]+ [ equalPred aVar cVar+ , equalPred bVar cVar+ , classPred ''Read [cVar]+ , classPred ''Show [cVar]+ ] , constructorFields =- [ListT `AppT` c, ConT ''Maybe `AppT` c]+ [ListT `AppT` cVar, ConT ''Maybe `AppT` cVar] , constructorStrictness = [notStrictAnnot, notStrictAnnot] , constructorVariant = NormalConstructor }@@ -219,14 +277,16 @@ validateDI info DatatypeInfo- { datatypeName = ''Showable- , datatypeContext = []- , datatypeVars = []- , datatypeVariant = Datatype- , datatypeCons =+ { datatypeName = ''Showable+ , datatypeContext = []+ , datatypeVars = []+ , datatypeInstTypes = []+ , datatypeVariant = Datatype+ , datatypeReturnKind = starK+ , datatypeCons = [ ConstructorInfo { constructorName = 'Showable- , constructorVars = [KindedTV a starK]+ , constructorVars = [kindedTV a starK] , constructorContext = [classPred ''Show [VarT a]] , constructorFields = [VarT a] , constructorStrictness = [notStrictAnnot]@@ -240,11 +300,13 @@ $(do info <- reifyDatatype ''R validateDI info DatatypeInfo- { datatypeName = ''R- , datatypeContext = []- , datatypeVars = []- , datatypeVariant = Datatype- , datatypeCons =+ { datatypeName = ''R+ , datatypeContext = []+ , datatypeVars = []+ , datatypeInstTypes = []+ , datatypeVariant = Datatype+ , datatypeReturnKind = starK+ , datatypeCons = [ ConstructorInfo { constructorName = 'R1 , constructorVars = []@@ -259,10 +321,13 @@ gadt2Test :: IO () gadt2Test = $(do info <- reifyDatatype ''Gadt2- let vars@[a,b] = map (VarT . mkName) ["a","b"]- [aSig,bSig] = map (\v -> SigT v starK) vars- x = mkName "x"- con = ConstructorInfo+ 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 = []@@ -271,20 +336,22 @@ , constructorVariant = NormalConstructor } validateDI info DatatypeInfo- { datatypeName = ''Gadt2- , datatypeContext = []- , datatypeVars = [aSig, bSig]- , datatypeVariant = Datatype- , datatypeCons =+ { datatypeName = ''Gadt2+ , datatypeContext = []+ , datatypeVars = [aTvb, bTvb]+ , datatypeInstTypes = [aSig, bSig]+ , datatypeVariant = Datatype+ , datatypeReturnKind = starK+ , datatypeCons = [ con { constructorName = 'Gadt2c1- , constructorContext = [equalPred b (AppT ListT a)] }+ , constructorContext = [equalPred bVar (AppT ListT aVar)] } , con { constructorName = 'Gadt2c2- , constructorContext = [equalPred a (AppT ListT b)] }+ , constructorContext = [equalPred aVar (AppT ListT bVar)] } , con { constructorName = 'Gadt2c3- , constructorVars = [KindedTV x starK]+ , constructorVars = [kindedTV x starK] , constructorContext =- [equalPred a (AppT ListT (VarT x))- ,equalPred b (AppT ListT (VarT x))] } ]+ [equalPred aVar (AppT ListT (VarT x))+ ,equalPred bVar (AppT ListT (VarT x))] } ] } ) @@ -294,11 +361,13 @@ let g = mkName "g" validateDI info DatatypeInfo- { datatypeName = ''VoidStoS- , datatypeContext = []- , datatypeVars = [SigT (VarT g) (arrowKCompat starK starK)]- , datatypeVariant = Datatype- , datatypeCons = []+ { datatypeName = ''VoidStoS+ , datatypeContext = []+ , datatypeVars = [kindedTV g (arrowKCompat starK starK)]+ , datatypeInstTypes = [SigT (VarT g) (arrowKCompat starK starK)]+ , datatypeVariant = Datatype+ , datatypeReturnKind = starK+ , datatypeCons = [] } ) @@ -307,11 +376,13 @@ $(do info <- reifyDatatype ''StrictDemo validateDI info DatatypeInfo- { datatypeName = ''StrictDemo- , datatypeContext = []- , datatypeVars = []- , datatypeVariant = Datatype- , datatypeCons =+ { datatypeName = ''StrictDemo+ , datatypeContext = []+ , datatypeVars = []+ , datatypeInstTypes = []+ , datatypeVariant = Datatype+ , datatypeReturnKind = starK+ , datatypeCons = [ ConstructorInfo { constructorName = 'StrictDemo , constructorVars = []@@ -330,18 +401,19 @@ $(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 = []- , datatypeVariant = Datatype- , datatypeCons =+ { datatypeName = mkName "T43Plain"+ , datatypeContext = []+ , datatypeVars = []+ , datatypeInstTypes = []+ , datatypeVariant = Datatype+ , datatypeReturnKind = starK+ , datatypeCons = [ ConstructorInfo { constructorName = mkName "MkT43Plain" , constructorVars = []@@ -355,11 +427,13 @@ infoFam <- normalizeDec decFam validateDI infoFam DatatypeInfo- { datatypeName = mkName "T43Fam"- , datatypeContext = []- , datatypeVars = []- , datatypeVariant = DataInstance- , datatypeCons =+ { datatypeName = mkName "T43Fam"+ , datatypeContext = []+ , datatypeVars = []+ , datatypeInstTypes = []+ , datatypeVariant = DataInstance+ , datatypeReturnKind = starK+ , datatypeCons = [ ConstructorInfo { constructorName = mkName "MkT43Fam" , constructorVars = []@@ -369,20 +443,45 @@ , constructorVariant = NormalConstructor } ] } )-#endif -#if MIN_VERSION_template_haskell(2,7,0)+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+ , datatypeReturnKind = starK+ , datatypeCons =+ [ ConstructorInfo+ { constructorName = mkName "MkFoo"+ , constructorVars = [plainTV a]+ , constructorContext = []+ , constructorFields = [VarT a]+ , constructorStrictness = [notStrictAnnot]+ , constructorVariant = NormalConstructor } ]+ }+ )+ dataFamilyTest :: IO () dataFamilyTest = $(do info <- reifyDatatype 'DFMaybe let a = mkName "a" validateDI info DatatypeInfo- { datatypeName = ''DF- , datatypeContext = []- , datatypeVars = [AppT (ConT ''Maybe) (VarT a)]- , datatypeVariant = DataInstance- , datatypeCons =+ { datatypeName = ''DF+ , datatypeContext = []+ , datatypeVars = [kindedTV a starK]+ , datatypeInstTypes = [AppT (ConT ''Maybe) (VarT a)]+ , datatypeVariant = DataInstance+ , datatypeReturnKind = starK+ , datatypeCons = [ ConstructorInfo { constructorName = 'DFMaybe , constructorVars = []@@ -396,19 +495,22 @@ ghc78bugTest :: IO () ghc78bugTest = $(do info <- reifyDatatype 'DF1- let c = VarT (mkName "c")+ let c = mkName "c"+ cVar = VarT c validateDI info DatatypeInfo- { datatypeName = ''DF1- , datatypeContext = []- , datatypeVars = [SigT c starK]- , datatypeVariant = DataInstance- , datatypeCons =+ { datatypeName = ''DF1+ , datatypeContext = []+ , datatypeVars = [kindedTV c starK]+ , datatypeInstTypes = [SigT cVar starK]+ , datatypeVariant = DataInstance+ , datatypeReturnKind = starK+ , datatypeCons = [ ConstructorInfo { constructorName = 'DF1 , constructorVars = [] , constructorContext = []- , constructorFields = [c]+ , constructorFields = [cVar] , constructorStrictness = [notStrictAnnot] , constructorVariant = NormalConstructor } ] }@@ -418,19 +520,22 @@ quotedTest = $(do [dec] <- [d| data instance Quoted a = MkQuoted a |] info <- normalizeDec dec- let a = VarT (mkName "a")+ let a = mkName "a"+ aVar = VarT a validateDI info DatatypeInfo- { datatypeName = mkName "Quoted"- , datatypeContext = []- , datatypeVars = [SigT a starK]- , datatypeVariant = DataInstance- , datatypeCons =+ { datatypeName = mkName "Quoted"+ , datatypeContext = []+ , datatypeVars = [plainTV a]+ , datatypeInstTypes = [aVar]+ , datatypeVariant = DataInstance+ , datatypeReturnKind = starK+ , datatypeCons = [ ConstructorInfo { constructorName = mkName "MkQuoted" , constructorVars = [] , constructorContext = []- , constructorFields = [a]+ , constructorFields = [aVar] , constructorStrictness = [notStrictAnnot] , constructorVariant = NormalConstructor } ] }@@ -440,13 +545,16 @@ polyTest = $(do info <- reifyDatatype 'MkPoly let [a,k] = map mkName ["a","k"]+ kVar = VarT k validateDI info DatatypeInfo- { datatypeName = ''Poly- , datatypeContext = []- , datatypeVars = [SigT (VarT a) (varKCompat k)]- , datatypeVariant = DataInstance- , datatypeCons =+ { datatypeName = ''Poly+ , datatypeContext = []+ , datatypeVars = [kindedTV k starK, kindedTV a kVar]+ , datatypeInstTypes = [SigT (VarT a) kVar]+ , datatypeVariant = DataInstance+ , datatypeReturnKind = starK+ , datatypeCons = [ ConstructorInfo { constructorName = 'MkPoly , constructorVars = []@@ -460,16 +568,19 @@ gadtFamTest :: IO () gadtFamTest = $(do info <- reifyDatatype 'MkGadtFam1- let names@[c,d,e,q] = map mkName ["c","d","e","q"]- [cTy,dTy,eTy,qTy] = map VarT names- [cSig,dSig] = map (\v -> SigT v starK) [cTy,dTy]+ 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 = [cSig,dSig]- , datatypeVariant = DataInstance- , datatypeCons =+ { datatypeName = ''GadtFam+ , datatypeContext = []+ , datatypeVars = [cTvb,dTvb]+ , datatypeInstTypes = [cSig,dSig]+ , datatypeVariant = DataInstance+ , datatypeReturnKind = starK+ , datatypeCons = [ ConstructorInfo { constructorName = 'MkGadtFam1 , constructorVars = []@@ -479,7 +590,7 @@ , constructorVariant = NormalConstructor } , ConstructorInfo { constructorName = '(:&&:)- , constructorVars = [KindedTV e starK]+ , constructorVars = [kindedTV e starK] , constructorContext = [equalPred cTy (AppT ListT eTy)] , constructorFields = [eTy,dTy] , constructorStrictness = [notStrictAnnot, notStrictAnnot]@@ -505,7 +616,7 @@ , constructorVariant = NormalConstructor } , ConstructorInfo { constructorName = 'MkGadtFam5- , constructorVars = [KindedTV q starK]+ , constructorVars = [kindedTV q starK] , constructorContext = [ equalPred cTy (ConT ''Bool) , equalPred dTy (ConT ''Bool) , equalPred qTy (ConT ''Char)@@ -522,11 +633,13 @@ info <- normalizeDec dec validateDI info DatatypeInfo- { datatypeName = ''FamLocalDec1- , datatypeContext = []- , datatypeVars = [ConT ''Int]- , datatypeVariant = DataInstance- , datatypeCons =+ { datatypeName = ''FamLocalDec1+ , datatypeContext = []+ , datatypeVars = []+ , datatypeInstTypes = [ConT ''Int]+ , datatypeVariant = DataInstance+ , datatypeReturnKind = starK+ , datatypeCons = [ ConstructorInfo { constructorName = mkName "FamLocalDec1Int" , constructorVars = []@@ -541,20 +654,23 @@ famLocalDecTest2 = $(do [dec] <- [d| data instance FamLocalDec2 Int (a, b) a = FamLocalDec2Int { fm0 :: (b, a), fm1 :: Int } |] info <- normalizeDec dec- let tys@[a,b] = map (VarT . mkName) ["a", "b"]- [aSig,bSig] = map (\v -> SigT v starK) tys+ 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 = [ConT ''Int, TupleT 2 `AppT` a `AppT` b, aSig]- , datatypeVariant = DataInstance- , datatypeCons =+ { datatypeName = ''FamLocalDec2+ , datatypeContext = []+ , datatypeVars = [aTvb,bTvb]+ , datatypeInstTypes = [ConT ''Int, TupleT 2 `AppT` aVar `AppT` bVar, aVar]+ , datatypeVariant = DataInstance+ , datatypeReturnKind = starK+ , datatypeCons = [ ConstructorInfo { constructorName = mkName "FamLocalDec2Int" , constructorVars = [] , constructorContext = []- , constructorFields = [TupleT 2 `AppT` b `AppT` a, ConT ''Int]+ , constructorFields = [TupleT 2 `AppT` bVar `AppT` aVar, ConT ''Int] , constructorStrictness = [notStrictAnnot, notStrictAnnot] , constructorVariant = RecordConstructor [mkName "fm0", mkName "fm1"] }] }@@ -574,14 +690,61 @@ _ -> fail "T46 should have exactly one constructor" [| return () |]) -#endif+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+ , datatypeReturnKind = starK+ , 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+ , datatypeReturnKind = starK+ , datatypeCons =+ [ ConstructorInfo+ { constructorName = 'MkT95+ , constructorVars = []+ , constructorContext = []+ , constructorFields = [aVar]+ , constructorStrictness = [notStrictAnnot]+ , constructorVariant = NormalConstructor }]+ }+ )+ fixityLookupTest :: IO () fixityLookupTest = $(do Just (Fixity 6 InfixR) <- reifyFixityCompat '(:**:) [| return () |]) -#if __GLASGOW_HASKELL__ >= 704 resolvePredSynonymsTest :: IO () resolvePredSynonymsTest = $(do info <- reifyDatatype ''PredSynT@@ -593,18 +756,20 @@ 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 = [SigT (VarT (mkName "a")) starK]- , datatypeVariant = Datatype- , datatypeCons =+ { datatypeContext = []+ , datatypeName = ''Maybe+ , datatypeVars = [kindedTV a starK]+ , datatypeInstTypes = [SigT (VarT a) starK]+ , datatypeVariant = Datatype+ , datatypeReturnKind = starK+ , datatypeCons = [ ConstructorInfo { constructorName = 'Nothing , constructorVars = []@@ -623,41 +788,44 @@ $(do info <- reifyConstructor 'Just validateCI info justCI) -#if MIN_VERSION_base(4,7,0) importedEqualityTest :: IO () importedEqualityTest = $(do info <- reifyDatatype ''(:~:)- let [a,b] = map (VarT . mkName) ["a","b"]- k = mkName "k"- kKind = varKCompat k+ let names@[a,b] = map mkName ["a","b"]+ [aVar,bVar] = map VarT names+ k = mkName "k"+ kKind = VarT k validateDI info DatatypeInfo- { datatypeContext = []- , datatypeName = ''(:~:)- , datatypeVars = [SigT a kKind, SigT b kKind]- , datatypeVariant = Datatype- , datatypeCons =+ { datatypeContext = []+ , datatypeName = ''(:~:)+ , datatypeVars = [ kindedTV k starK+ , kindedTV a kKind+ , kindedTV b kKind+ ]+ , datatypeInstTypes = [SigT aVar kKind, SigT bVar kKind]+ , datatypeVariant = Datatype+ , datatypeReturnKind = starK+ , datatypeCons = [ ConstructorInfo { constructorName = 'Refl , constructorVars = []- , constructorContext = [equalPred a b]+ , 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 [KindedTV a (VarT k1)] [] (VarT a)+ let ty = ForallT [kindedTVSpecified a (VarT k1)] [] (VarT a) substTy = applySubstitution (Map.singleton k1 (VarT k2)) ty - checkFreeVars :: Type -> [Name] -> Q ()+ checkFreeVars :: TH.Type -> [Name] -> Q () checkFreeVars t freeVars = unless (freeVariables t == freeVars) $ fail $ "free variables of " ++ show t ++ " should be " ++ show freeVars@@ -673,11 +841,7 @@ let proxyAK = ConT (mkName "Proxy") `AppT` SigT (VarT a) (VarT k) -- Proxy (a :: k) expected = ForallT-#if __GLASGOW_HASKELL__ >= 800- [PlainTV k, KindedTV a (VarT k)]-#else- [KindedTV a (VarT k)]-#endif+ [plainTVSpecified k, kindedTVSpecified a (VarT k)] [] proxyAK actual = quantifyType proxyAK unless (expected == actual) $@@ -689,7 +853,7 @@ t61Test :: IO () t61Test =- $(do let test :: Type -> Type -> Q ()+ $(do let test :: TH.Type -> TH.Type -> Q () test orig expected = do actual <- resolveTypeSynonyms orig unless (expected == actual) $@@ -700,41 +864,128 @@ 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 [KindedTV a (idAppT StarT)]+ test (SigT (idAppT $ ConT ''Int) (idAppT starK))+ (SigT (ConT ''Int) starK)+ test (ForallT [kindedTVSpecified a (idAppT starK)] [idAppT (ConT ''Show `AppT` VarT a)] (idAppT $ VarT a))- (ForallT [KindedTV a StarT]+ (ForallT [kindedTVSpecified a starK] [ConT ''Show `AppT` VarT a] (VarT a))-#endif-#if MIN_VERSION_template_haskell(2,11,0) test (InfixT (idAppT $ ConT ''Int) ''Either (idAppT $ ConT ''Int)) (InfixT (ConT ''Int) ''Either (ConT ''Int)) test (ParensT (idAppT $ ConT ''Int)) (ConT ''Int)+#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+ , datatypeReturnKind = starK+ , 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 ()++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 () |])++#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 [k,a] = map (VarT . mkName) ["k","a"]+ 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 = [SigT k starK, SigT a k]- , datatypeVariant = Datatype- , datatypeCons =+ { datatypeContext = []+ , datatypeName = ''T37a+ , datatypeVars = [kTvb, aTvb]+ , datatypeInstTypes = [kSig, aSig]+ , datatypeVariant = Datatype+ , datatypeReturnKind = starK+ , datatypeCons = [ ConstructorInfo { constructorName = 'MkT37a , constructorVars = []- , constructorContext = [equalPred k (ConT ''Bool)]+ , constructorContext = [equalPred kVar (ConT ''Bool)] , constructorFields = [] , constructorStrictness = [] , constructorVariant = NormalConstructor } ]@@ -743,15 +994,17 @@ infoB <- reifyDatatype ''T37b validateDI infoB DatatypeInfo- { datatypeContext = []- , datatypeName = ''T37b- , datatypeVars = [SigT a k]- , datatypeVariant = Datatype- , datatypeCons =+ { datatypeContext = []+ , datatypeName = ''T37b+ , datatypeVars = [kTvb, aTvb]+ , datatypeInstTypes = [aSig]+ , datatypeVariant = Datatype+ , datatypeReturnKind = starK+ , datatypeCons = [ ConstructorInfo { constructorName = 'MkT37b , constructorVars = []- , constructorContext = [equalPred k (ConT ''Bool)]+ , constructorContext = [equalPred kVar (ConT ''Bool)] , constructorFields = [] , constructorStrictness = [] , constructorVariant = NormalConstructor } ]@@ -760,15 +1013,17 @@ infoC <- reifyDatatype ''T37c validateDI infoC DatatypeInfo- { datatypeContext = []- , datatypeName = ''T37c- , datatypeVars = [SigT a k]- , datatypeVariant = Datatype- , datatypeCons =+ { datatypeContext = []+ , datatypeName = ''T37c+ , datatypeVars = [kTvb, aTvb]+ , datatypeInstTypes = [aSig]+ , datatypeVariant = Datatype+ , datatypeReturnKind = starK+ , datatypeCons = [ ConstructorInfo { constructorName = 'MkT37c , constructorVars = []- , constructorContext = [equalPred a (ConT ''Bool)]+ , constructorContext = [equalPred aVar (ConT ''Bool)] , constructorFields = [] , constructorStrictness = [] , constructorVariant = NormalConstructor } ]@@ -779,16 +1034,19 @@ polyKindedExTyvarTest = $(do info <- reifyDatatype ''T48 let [a,x] = map mkName ["a","x"]+ aVar = VarT a validateDI info DatatypeInfo- { datatypeContext = []- , datatypeName = ''T48- , datatypeVars = [SigT (VarT a) starK]- , datatypeVariant = Datatype- , datatypeCons =+ { datatypeContext = []+ , datatypeName = ''T48+ , datatypeVars = [kindedTV a starK]+ , datatypeInstTypes = [SigT aVar starK]+ , datatypeVariant = Datatype+ , datatypeReturnKind = starK+ , datatypeCons = [ ConstructorInfo { constructorName = 'MkT48- , constructorVars = [KindedTV x (VarT a)]+ , constructorVars = [kindedTV x aVar] , constructorContext = [] , constructorFields = [ConT ''Prox `AppT` VarT x] , constructorStrictness = [notStrictAnnot]@@ -799,15 +1057,45 @@ -- 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 = [SigT (VarT a1) starK]+ DatatypeInfo { datatypeVars = [v1] , datatypeCons =- [ ConstructorInfo- { constructorVars = [KindedTV _ (VarT a2)] } ] } ->- unless (a1 == a2) $- fail $ "Two occurrences of the same variable have different names: "- ++ show [a1, a2]+ [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]+ _ -> fail $ "Unexpected DatatypeInfo for T48: "+ ++ show info [| 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 () |]+ )++#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 ()@@ -824,8 +1112,8 @@ t <- newName "T" let tauType = ArrowT `AppT` VarT a `AppT` (ArrowT `AppT` VarT b `AppT` (ConT t `AppT` VarT a))- sigmaType = ForallT [PlainTV b] [] tauType- expected = ForallT [PlainTV a, PlainTV b] [] tauType+ 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: "@@ -839,7 +1127,7 @@ $(do a <- newName "a" b <- newName "b" let [aVar, bVar] = map VarT [a, b]- [aTvb, bTvb] = map PlainTV [a, b]+ [aTvb, bTvb] = map plainTV [a, b] let fvsABExpected = [aTvb, bTvb] fvsABActual = freeVariablesWellScoped [aVar, bVar] @@ -857,3 +1145,268 @@ 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+ , datatypeReturnKind = starK+ , datatypeCons =+ [ ConstructorInfo+ { constructorName = ''MkT100+ , constructorContext = []+ , constructorVars = []+ , constructorFields = []+ , constructorStrictness = []+ , constructorVariant = NormalConstructor }+ ]+ }++ t100Info <- reifyDatatype ''T100+ validateDI t100Info expectedInfo++ mkT100Info <- reifyDatatype ''MkT100+ validateDI mkT100Info expectedInfo+ )+#endif++#if MIN_VERSION_template_haskell(2,21,0)+t103Test :: IO ()+t103Test =+ $(do [dec] <- [d| data T102 @k (a :: k) |]+ info <- normalizeDec dec+ let k = mkName "k"+ a = mkName "a"+ validateDI info+ DatatypeInfo+ { datatypeName = mkName "T102"+ , datatypeContext = []+ , datatypeVars = [plainTV k, kindedTV a (VarT k)]+ , datatypeInstTypes = [SigT (VarT a) (VarT k)]+ , datatypeVariant = Datatype+ , datatypeReturnKind = starK+ , datatypeCons = []+ }+ )+#endif++#if __GLASGOW_HASKELL__ >= 810+t107Test :: IO ()+t107Test =+ $(do info <- reifyDatatype ''T107+ let r = mkName "r"+ validateDI info+ DatatypeInfo+ { datatypeName = mkName "T107"+ , datatypeContext = []+ , datatypeVars = [kindedTV r (ConT ''RuntimeRep)]+ , datatypeInstTypes = []+ , datatypeVariant = Newtype+ , datatypeReturnKind = ConT ''TYPE `AppT` VarT r+ , datatypeCons =+ [ ConstructorInfo+ { constructorName = mkName "MkT107"+ , constructorVars = []+ , constructorContext = []+ , constructorFields = [ConT ''Any `SigT` (ConT ''TYPE `AppT` VarT r)]+ , constructorStrictness = [notStrictAnnot]+ , constructorVariant = NormalConstructor+ }+ ]+ }+ )++t108Test :: IO ()+t108Test =+ $(do [dec] <- [d| data T108 :: forall k -> k -> Type where+ MkT108 :: forall k (a :: k). T108 k a+ |]+ info <- normalizeDec dec+ let k = mkName "k"+ a = mkName "a"+ validateDI info+ DatatypeInfo+ { datatypeName = mkName "T108"+ , datatypeContext = []+ , datatypeVars = [plainTV k, kindedTV a (VarT k)]+ , datatypeInstTypes = [VarT k, SigT (VarT a) (VarT k)]+ , datatypeVariant = Datatype+ , datatypeReturnKind = starK+ , datatypeCons =+ [ ConstructorInfo+ { constructorName = mkName "MkT108"+ , constructorVars = []+ , constructorContext = []+ , constructorFields = []+ , constructorStrictness = []+ , constructorVariant = NormalConstructor+ }+ ]+ }+ )+#endif++#if __GLASGOW_HASKELL__ >= 804+t110Test :: IO ()+t110Test =+ $(do [dec] <- [d| data T110 :: forall k. k -> Type where+ MkT110 :: forall k (a :: k). T110 a+ |]+ info <- normalizeDec dec+ let k = mkName "k"+ a = mkName "a"+ validateDI info+ DatatypeInfo+ { datatypeName = mkName "T110"+ , datatypeContext = []+ , datatypeVars = [plainTV k, kindedTV a (VarT k)]+ , datatypeInstTypes = [SigT (VarT a) (VarT k)]+ , datatypeVariant = Datatype+ , datatypeReturnKind = starK+ , datatypeCons =+ [ ConstructorInfo+ { constructorName = mkName "MkT110"+ , constructorVars = []+ , constructorContext = []+ , constructorFields = []+ , constructorStrictness = []+ , constructorVariant = NormalConstructor+ }+ ]+ }+ )+#endif++#if MIN_VERSION_template_haskell(2,16,0)+unboxedTupleTest :: IO ()+unboxedTupleTest =+ $(do k0 <- newName "k0"+ k1 <- newName "k1"+ a <- newName "a"+ b <- newName "b"+ tupleInfo <- reifyDatatype (unboxedTupleTypeName 2)+ validateDI tupleInfo+ DatatypeInfo+ { datatypeContext = []+ , datatypeName = unboxedTupleTypeName 2+ , datatypeVars = [kindedTV k0 starK+ ,kindedTV a (AppT (ConT ''TYPE) (VarT k0 ))+ ,kindedTV k1 starK+ ,kindedTV b (AppT (ConT ''TYPE) (VarT k1))]+ , datatypeInstTypes = [SigT (VarT a) (AppT (ConT ''TYPE) (VarT k0))+ ,SigT (VarT b) (AppT (ConT ''TYPE) (VarT k1))]+ , datatypeVariant = Datatype+ , datatypeReturnKind =+ AppT+ (ConT ''TYPE)+ (AppT+ (PromotedT 'TupleRep)+ (AppT+ (AppT PromotedConsT (VarT k0))+ (AppT+ (AppT PromotedConsT (VarT k1))+ (SigT PromotedNilT (AppT ListT (ConT ''RuntimeRep))))))+ , datatypeCons =+ [ ConstructorInfo+ { constructorName = unboxedTupleDataName 2+ , constructorVars = []+ , constructorContext = []+ , constructorFields = [VarT a, VarT b]+ , constructorStrictness = [notStrictAnnot, notStrictAnnot]+ , constructorVariant = NormalConstructor}]+ }+ )+#endif++#if MIN_VERSION_template_haskell(2,18,0)+unliftedGADTDecTest :: IO ()+unliftedGADTDecTest =+ $(do a <- newName "a"+ s <- newName "s"+ [dec] <- [d| data UnliftedGADT a :: UnliftedType where+ UnliftedGADT :: Show s => s -> a -> UnliftedGADT a+ |]+ info <- normalizeDec dec+ validateDI info+ DatatypeInfo+ { datatypeContext = []+ , datatypeName = mkName "UnliftedGADT"+ , datatypeVars = [plainTV a]+ , datatypeInstTypes = [VarT a]+ , datatypeVariant = Datatype+ , datatypeReturnKind = ConT ''TYPE `AppT` (PromotedT 'BoxedRep `AppT` PromotedT 'Unlifted)+ , datatypeCons =+ [ConstructorInfo+ {constructorName = mkName "UnliftedGADT"+ , constructorVars = [plainTV s]+ , constructorContext = [AppT (ConT ''Show) (VarT s)]+ , constructorFields = [VarT s,VarT a]+ , constructorStrictness = [notStrictAnnot, notStrictAnnot]+ , constructorVariant = NormalConstructor}+ ]+ }+ )+#endif+++primTyConTest :: IO ()+primTyConTest =+ $(do l <- newName "l"+ a <- newName "a"+ info <- reifyDatatype ''Array#+ validateDI info+ DatatypeInfo+ { datatypeContext = []+ , datatypeName = mkName "Array#"+#if MIN_VERSION_template_haskell(2,19,0)+ , datatypeVars = [kindedTV l (ConT ''Levity)+ , kindedTV a (ConT ''TYPE `AppT` (PromotedT 'BoxedRep `AppT` VarT l))+ ]+ , datatypeInstTypes = [SigT (VarT a) (ConT ''TYPE `AppT` (PromotedT 'BoxedRep `AppT` VarT l))]+ , datatypeReturnKind = ConT ''TYPE `AppT` (PromotedT 'BoxedRep `AppT` PromotedT 'Unlifted)+#elif MIN_VERSION_template_haskell(2,18,0)+ , datatypeVars = [ kindedTV a StarT]+ , datatypeInstTypes = [SigT (VarT a) StarT]+ , datatypeReturnKind = ConT ''TYPE `AppT` (PromotedT 'BoxedRep `AppT` PromotedT 'Unlifted)+#elif MIN_VERSION_template_haskell(2,16,0)+ , datatypeVars = [kindedTV a starK]+ , datatypeInstTypes = [SigT (VarT a) starK]+ , datatypeReturnKind = ConT ''TYPE `AppT` PromotedT 'UnliftedRep+#else+ , datatypeVars = [kindedTV a starK]+ , datatypeInstTypes = [SigT (VarT a) starK]+ , datatypeReturnKind = starK+#endif+ , datatypeVariant = Datatype+ , datatypeCons = []+ }+ )
test/Types.hs view
@@ -1,17 +1,22 @@-{-# Language CPP, FlexibleContexts, TypeFamilies, KindSignatures, TemplateHaskell, GADTs, ScopedTypeVariables #-}+{-# Language CPP, FlexibleContexts, TypeFamilies, KindSignatures, TemplateHaskell, GADTs, ScopedTypeVariables, TypeOperators, ConstraintKinds, DataKinds, PolyKinds #-} -#if __GLASGOW_HASKELL__ >= 704-{-# LANGUAGE ConstraintKinds #-}+#if __GLASGOW_HASKELL__ < 806+{-# Language TypeInType #-} #endif -#if MIN_VERSION_template_haskell(2,8,0)-{-# Language PolyKinds #-}+#if __GLASGOW_HASKELL__ >= 810+{-# Language StandaloneKindSignatures #-}+{-# Language TypeApplications #-}+{-# Language UnliftedNewtypes #-} #endif -#if __GLASGOW_HASKELL__ >= 800-{-# Language TypeInType #-}+#if MIN_VERSION_template_haskell(2,20,0)+{-# Language TypeData #-} #endif +-- We should aim to enable -Wincomplete-uni-patterns long-term. See #121.+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ {-| Module : Types Description : Test cases for the th-abstraction package@@ -25,16 +30,17 @@ -} module Types where -#if __GLASGOW_HASKELL__ >= 704+import Data.Kind+ import GHC.Exts (Constraint)-#endif import Language.Haskell.TH hiding (Type) import Language.Haskell.TH.Datatype+import Language.Haskell.TH.Datatype.TyVarBndr import Language.Haskell.TH.Lib (starK) -#if __GLASGOW_HASKELL__ >= 800-import Data.Kind+#if __GLASGOW_HASKELL__ >= 810+import GHC.Exts (Any, TYPE) #endif type Gadt1Int = Gadt1 Int@@ -68,29 +74,24 @@ 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 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 :: *)@@ -108,9 +109,13 @@ data family T46 a b c data instance T46 (f (p :: *)) (f p) q = MkT46 q-#endif -#if __GLASGOW_HASKELL__ >= 704+data family T73 a b+data instance T73 Int b = MkT73 b++data family T95 :: * -> *+data instance T95 [a] = MkT95 a+ 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)@@ -120,15 +125,19 @@ PredSyn1 Int Int => MkPredSynT1 Int | PredSyn2 Int Int => MkPredSynT2 Int | PredSyn3 Int => MkPredSynT3 Int-#endif -#if __GLASGOW_HASKELL__ >= 800 data T37a (k :: Type) :: k -> Type where MkT37a :: T37a Bool a +#if __GLASGOW_HASKELL__ >= 810+type T37b :: k -> Type+#endif data T37b (a :: k) where MkT37b :: forall (a :: Bool). T37b a +#if __GLASGOW_HASKELL__ >= 810+type T37c :: k -> Type+#endif data T37c (a :: k) where MkT37c :: T37c Bool @@ -136,8 +145,20 @@ 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++#if MIN_VERSION_template_haskell(2,20,0)+type data T100 = MkT100 #endif +#if __GLASGOW_HASKELL__ >= 810+type T107 :: TYPE r+newtype T107 where+ MkT107 :: forall r. Any @(TYPE r) -> T107 @r+#endif+ -- We must define these here due to Template Haskell staging restrictions justCI :: ConstructorInfo justCI =@@ -163,9 +184,8 @@ where a = VarT (mkName "a") names@[v1,v2] = map mkName ["v1","v2"]- [v1K,v2K] = map (\n -> KindedTV n starK) names+ [v1K,v2K] = map (\n -> kindedTV n starK) names -#if MIN_VERSION_template_haskell(2,7,0) gadtRecFamCI :: ConstructorInfo gadtRecFamCI = ConstructorInfo@@ -179,4 +199,3 @@ , constructorVariant = RecordConstructor ['famRec1, 'famRec2] } where [cTy,dTy] = map (VarT . mkName) ["c", "d"]-#endif
th-abstraction.cabal view
@@ -1,5 +1,5 @@ name: th-abstraction-version: 0.2.11.0+version: 0.7.2.0 synopsis: Nicer interface for reified information about data types description: This package normalizes variations in the interface for inspecting datatype information via Template Haskell@@ -17,7 +17,7 @@ build-type: Simple extra-source-files: ChangeLog.md README.md cabal-version: >=1.10-tested-with: GHC==8.6.3, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2, GHC==7.2.2, GHC==7.0.4+tested-with: GHC==9.14.1, GHC==9.12.2, GHC==9.10.3, GHC==9.8.4, GHC==9.6.7, GHC==9.4.8, GHC==9.2.8, GHC==9.0.2, GHC==8.10.7, GHC==8.8.4, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2 source-repository head type: git@@ -25,14 +25,19 @@ 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.15,- containers >=0.4 && <0.7+ build-depends: base >=4.9 && <5,+ template-haskell >=2.11 && <2.25,+ containers >=0.4 && <0.9 hs-source-dirs: src default-language: Haskell2010 + 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@@ -41,3 +46,6 @@ 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