th-desugar 1.8 → 1.9
raw patch · 15 files changed
+1378/−596 lines, 15 filesdep ~template-haskellnew-uploader
Dependency ranges changed: template-haskell
Files
- CHANGES.md +94/−0
- Language/Haskell/TH/Desugar.hs +109/−42
- Language/Haskell/TH/Desugar/AST.hs +305/−0
- Language/Haskell/TH/Desugar/Core.hs +392/−383
- Language/Haskell/TH/Desugar/Expand.hs +112/−61
- Language/Haskell/TH/Desugar/Lift.hs +3/−3
- Language/Haskell/TH/Desugar/Match.hs +4/−3
- Language/Haskell/TH/Desugar/Reify.hs +18/−10
- Language/Haskell/TH/Desugar/Subst.hs +16/−6
- Language/Haskell/TH/Desugar/Sweeten.hs +98/−33
- Language/Haskell/TH/Desugar/Util.hs +76/−1
- Test/DsDec.hs +2/−2
- Test/Run.hs +77/−4
- Test/Splices.hs +54/−40
- th-desugar.cabal +18/−8
CHANGES.md view
@@ -1,6 +1,100 @@ `th-desugar` release notes ========================== +Version 1.9+-----------+* Suppose GHC 8.6.++* Add support for `DerivingVia`. Correspondingly, there is now a+ `DDerivStrategy` data type.++* Add support for `QuantifiedConstraints`. Correspondingly, there is now a+ `DForallPr` constructor in `DPred` to represent quantified constraint types.++* Remove the `DStarT` constructor of `DType` in favor of `DConT ''Type`.+ Two utility functions have been added to `Language.Haskell.TH.Desugar` to+ ease this transition:++ * `isTypeKindName`: returns `True` if the argument `Name` is that+ of `Type` or `★` (or `*`, to support older GHCs).+ * `typeKindName`: the name of `Type` (on GHC 8.0 or later) or `*` (on older+ GHCs).++* `th-desugar` now desugars all data types to GADT syntax. The most significant+ API-facing changes resulting from this new design are:++ * The `DDataD`, `DDataFamilyD`, and `DDataFamInstD` constructors of `DDec`+ now have `Maybe DKind` fields that either have `Just` an explicit return+ kind (e.g., the `k -> Type -> Type` in `data Foo :: k -> Type -> Type`)+ or `Nothing` (if lacking an explicit return kind).+ * The `DCon` constructor previously had a field of type `Maybe DType`, since+ there was a possibility it could be a GADT (with an explicit return type)+ or non-GADT (without an explicit return type) constructor. Since all data+ types are desugared to GADTs now, this field has been changed to be simply+ a `DType`.+ * The type signature of `dsCon` was previously:++ ```haskell+ dsCon :: DsMonad q => Con -> q [DCon]+ ```++ However, desugaring constructors now needs more information than before,+ since GADT constructors have richer type signatures. Accordingly, the type+ of `dsCon` is now:++ ```haskell+ dsCon :: DsMonad q+ => [DTyVarBndr] -- ^ The universally quantified type variables+ -- (used if desugaring a non-GADT constructor)+ -> DType -- ^ The original data declaration's type+ -- (used if desugaring a non-GADT constructor).+ -> Con -> q [DCon]+ ```++ The `instance Desugar [Con] [DCon]` has also been removed, as the previous+ implementation of `desugar` (`concatMapM dsCon`) no longer has enough+ information to work.++ Some other utility functions have also been added as part of this change:++ * A `conExistentialTvbs` function has been introduced to determine the+ existentially quantified type variables of a `DCon`. Note that this+ function is not 100% accurate—refer to the documentation for+ `conExistentialTvbs` for more information.++ * A `mkExtraDKindBinders` function has been introduced to turn a data type's+ return kind into explicit, fresh type variable binders.++ * A `toposortTyVarsOf` function, which finds the free variables of a list of+ `DType`s and returns them in a well scoped list that has been sorted in+ reverse topological order.++* `th-desugar` now desugars partial pattern matches in `do`-notation and+ list/monad comprehensions to the appropriate invocation of `fail`.+ (Previously, these were incorrectly desugared into `case` expressions with+ incomplete patterns.)++* Add a `mkDLamEFromDPats` function for constructing a `DLamE` expression using+ a list of `DPat` arguments and a `DExp` body.++* Add an `unravel` function for decomposing a function type into its `forall`'d+ type variables, its context, its argument types, and its result type.++* Export a `substTyVarBndrs` function from `Language.Haskell.TH.Desugar.Subst`,+ which substitutes over type variable binders in a capture-avoiding fashion.++* `getDataD`, `dataConNameToDataName`, and `dataConNameToCon` from+ `Language.Haskell.TH.Desugar.Reify` now look up local declarations. As a+ result, the contexts in their type signatures have been strengthened from+ `Quasi` to `DsMonad`.++* Export a `dTyVarBndrToDType` function which converts a `DTyVarBndr` to a+ `DType`, which preserves its kind.++* Previously, `th-desugar` would silently accept illegal uses of record+ construction with fields that did not belong to the constructor, such as+ `Identity { notAField = "wat" }`. This is now an error.+ Version 1.8 ----------- * Support GHC 8.4.
Language/Haskell/TH/Desugar.hs view
@@ -12,12 +12,12 @@ -- Module : Language.Haskell.TH.Desugar -- Copyright : (C) 2014 Richard Eisenberg -- License : BSD-style (see LICENSE)--- Maintainer : Richard Eisenberg (rae@cs.brynmawr.edu)+-- Maintainer : Ryan Scott -- Stability : experimental -- Portability : non-portable -- -- Desugars full Template Haskell syntax into a smaller core syntax for further--- processing. The desugared types and constructors are prefixed with a D.+-- processing. -- ---------------------------------------------------------------------------- @@ -25,7 +25,7 @@ -- * Desugared data types DExp(..), DLetDec(..), DPat(..), DType(..), DKind, DCxt, DPred(..), DTyVarBndr(..), DMatch(..), DClause(..), DDec(..),- DDerivClause(..), DerivStrategy(..), DPatSynDir(..), DPatSynType,+ DDerivClause(..), DDerivStrategy(..), DPatSynDir(..), DPatSynType, Overlap(..), PatSynArgs(..), NewOrData(..), DTypeFamilyHead(..), DFamilyResultSig(..), InjectivityAnn(..), DCon(..), DConFields(..), DDeclaredInfix, DBangType, DVarBangType,@@ -84,17 +84,20 @@ getDataD, dataConNameToDataName, dataConNameToCon, nameOccursIn, allNamesIn, flattenDValD, getRecordSelectors, mkTypeName, mkDataName, newUniqueName,- mkTupleDExp, mkTupleDPat, maybeDLetE, maybeDCaseE,+ mkTupleDExp, mkTupleDPat, maybeDLetE, maybeDCaseE, mkDLamEFromDPats, fvDType, tupleDegree_maybe, tupleNameDegree_maybe, unboxedSumDegree_maybe, unboxedSumNameDegree_maybe, unboxedTupleDegree_maybe, unboxedTupleNameDegree_maybe,- strictToBang,+ strictToBang, isTypeKindName, typeKindName,+ unravel, conExistentialTvbs, mkExtraDKindBinders,+ dTyVarBndrToDType, toposortTyVarsOf, -- ** Extracting bound names extractBoundNamesStmt, extractBoundNamesDec, extractBoundNamesPat ) where +import Language.Haskell.TH.Desugar.AST import Language.Haskell.TH.Desugar.Core import Language.Haskell.TH.Desugar.Util import Language.Haskell.TH.Desugar.Sweeten@@ -104,12 +107,9 @@ import Language.Haskell.TH.Desugar.Match import Language.Haskell.TH.Desugar.Subst +import Control.Monad import qualified Data.Map as M-import Data.Monoid import qualified Data.Set as S-#if __GLASGOW_HASKELL__ < 709-import Data.Foldable ( foldMap )-#endif import Prelude hiding ( exp ) -- | This class relates a TH type with its th-desugar type and allows@@ -140,10 +140,6 @@ desugar = dsDecs sweeten = decsToTH -instance Desugar [Con] [DCon] where- desugar = concatMapM dsCon- sweeten = map conToTH- -- | If the declaration passed in is a 'DValD', creates new, equivalent -- declarations such that the 'DPat' in all 'DValD's is just a plain -- 'DVarPa'. Other declarations are passed through unchanged.@@ -180,35 +176,6 @@ flattenDValD other_dec = return [other_dec] -fvDType :: DType -> S.Set Name-fvDType = go_ty- where- go_ty :: DType -> S.Set Name- go_ty (DForallT tvbs cxt ty) = (foldMap go_tvb tvbs <> go_ty ty <> foldMap go_pred cxt)- S.\\ foldMap dtvbName tvbs- go_ty (DAppT t1 t2) = go_ty t1 <> go_ty t2- go_ty (DSigT ty ki) = go_ty ty <> go_ty ki- go_ty (DVarT n) = S.singleton n- go_ty (DConT {}) = S.empty- go_ty DArrowT = S.empty- go_ty (DLitT {}) = S.empty- go_ty DWildCardT = S.empty- go_ty DStarT = S.empty-- go_pred :: DPred -> S.Set Name- go_pred (DAppPr pr ty) = go_pred pr <> go_ty ty- go_pred (DSigPr pr ki) = go_pred pr <> go_ty ki- go_pred (DVarPr n) = S.singleton n- go_pred _ = S.empty-- go_tvb :: DTyVarBndr -> S.Set Name- go_tvb (DPlainTV{}) = S.empty- go_tvb (DKindedTV _ k) = go_ty k--dtvbName :: DTyVarBndr -> S.Set Name-dtvbName (DPlainTV n) = S.singleton n-dtvbName (DKindedTV n _) = S.singleton n- -- | Produces 'DLetDec's representing the record selector functions from -- the provided 'DCon's. --@@ -229,9 +196,14 @@ -- @ -- -- instead of returning one binding for @X1@ and another binding for @X2@.+--+-- 'getRecordSelectors' attempts to filter out \"naughty\" record selectors+-- whose types mention existentially quantified type variables. But see the+-- documentation for 'conExistentialTvbs' for limitations to this approach. -- See https://github.com/goldfirere/singletons/issues/180 for an example where -- the latter behavior can bite you.+ getRecordSelectors :: Quasi q => DType -- ^ the type of the argument -> [DCon]@@ -319,3 +291,98 @@ | DFunD n _ <- x, Just merged_clauses <- n `M.lookup` name_clause_map = DFunD n merged_clauses:augment_clauses name_clause_map xs | otherwise = x:augment_clauses name_clause_map xs++-- | 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@.+-- 'mkExtraDKindBinders' 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.+mkExtraDKindBinders :: DsMonad q => DKind -> q [DTyVarBndr]+mkExtraDKindBinders = expandType >=> mkExtraDKindBinders'++-- | Returns all of a constructor's existentially quantified type variable+-- binders.+--+-- Detecting the presence of existentially quantified type variables in the+-- context of Template Haskell is quite involved. Here is an example that+-- we will use to explain how this works:+--+-- @+-- data family Foo a b+-- data instance Foo (Maybe a) b where+-- MkFoo :: forall x y z. x -> y -> z -> Foo (Maybe x) [z]+-- @+--+-- In @MkFoo@, @x@ is universally quantified, whereas @y@ and @z@ are+-- existentially quantified. Note that @MkFoo@ desugars (in Core) to+-- something like this:+--+-- @+-- data instance Foo (Maybe a) b where+-- MkFoo :: forall a b y z. (b ~ [z]). a -> y -> z -> Foo (Maybe a) b+-- @+--+-- Here, we can see that @a@ appears in the desugared return type (it is a+-- simple alpha-renaming of @x@), so it is universally quantified. On the other+-- hand, neither @y@ nor @z@ appear in the desugared return type, so they are+-- existentially quantified.+--+-- This analysis would not have been possible without knowing what the original+-- data declaration's type was (in this case, @Foo (Maybe a) b@), which is why+-- we require it as an argument. Our algorithm for detecting existentially+-- quantified variables is not too different from what was described above:+-- we match the constructor's return type with the original data type, forming+-- a substitution, and check which quantified variables are not part of the+-- domain of the substitution.+--+-- Be warned: this may overestimate which variables are existentially+-- quantified when kind variables are involved. For instance, consider this+-- example:+--+-- @+-- data S k (a :: k)+-- data T a where+-- MkT :: forall k (a :: k). { foo :: Proxy (a :: k), bar :: S k a } -> T a+-- @+--+-- Here, the kind variable @k@ does not appear syntactically in the return type+-- @T a@, so 'conExistentialTvbs' would mistakenly flag @k@ as existential.+--+-- There are various tricks we could employ to improve this, but ultimately,+-- making this behave correctly with respect to @PolyKinds@ 100% of the time+-- would amount to performing kind inference in Template Haskell, which is+-- quite difficult. For the sake of simplicity, we have decided to stick with+-- a dumb-but-predictable syntactic check.+conExistentialTvbs :: DsMonad q+ => DType -- ^ The type of the original data declaration+ -> DCon+ -> q [DTyVarBndr]+conExistentialTvbs data_ty (DCon tvbs _ _ _ ret_ty) =+ -- 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+ -- unifying types), so we do an alpha-renaming of the+ -- constructor-bound variables before proceeding.+ substTyVarBndrs M.empty tvbs $ \subst tvbs' -> do+ renamed_ret_ty <- substTy subst ret_ty+ data_ty' <- expandType data_ty+ ret_ty' <- expandType renamed_ret_ty+ case matchTy YesIgnore ret_ty' data_ty' of+ Nothing -> fail $ showString "Unable to match type "+ . showsPrec 11 ret_ty'+ . showString " with "+ . showsPrec 11 data_ty'+ $ ""+ Just gadtSubt -> return [ tvb+ | tvb <- tvbs'+ , M.notMember (dtvbName tvb) gadtSubt+ ]
+ Language/Haskell/TH/Desugar/AST.hs view
@@ -0,0 +1,305 @@+{- Language/Haskell/TH/Desugar/AST.hs++(c) Ryan Scott 2018++Defines the desugared Template Haskell AST. The desugared types and+constructors are prefixed with a D.+-}++{-# LANGUAGE CPP, DeriveDataTypeable, DeriveGeneric #-}++module Language.Haskell.TH.Desugar.AST where++import Data.Data hiding (Fixity)+import GHC.Generics hiding (Fixity)+import Language.Haskell.TH++-- | Corresponds to TH's @Exp@ type. Note that @DLamE@ takes names, not patterns.+data DExp = DVarE Name+ | DConE Name+ | DLitE Lit+ | DAppE DExp DExp+ | DAppTypeE DExp DType+ | DLamE [Name] DExp+ | DCaseE DExp [DMatch]+ | DLetE [DLetDec] DExp+ | DSigE DExp DType+ | DStaticE DExp+ deriving (Show, Typeable, Data, Generic)+++-- | Corresponds to TH's @Pat@ type.+data DPat = DLitPa Lit+ | DVarPa Name+ | DConPa Name [DPat]+ | DTildePa DPat+ | DBangPa DPat+ | DSigPa DPat DType+ | DWildPa+ deriving (Show, Typeable, Data, Generic)++-- | Corresponds to TH's @Type@ type, used to represent+-- types and kinds.+data DType = DForallT [DTyVarBndr] DCxt DType+ | DAppT DType DType+ | DSigT DType DKind+ | DVarT Name+ | DConT Name+ | DArrowT+ | DLitT TyLit+ | DWildCardT+ deriving (Show, Typeable, Data, Generic)++-- | Kinds are types.+type DKind = DType++-- | Corresponds to TH's @Cxt@+type DCxt = [DPred]++-- | Corresponds to TH's @Pred@+data DPred = DForallPr [DTyVarBndr] DCxt DPred+ | DAppPr DPred DType+ | DSigPr DPred DKind+ | DVarPr Name+ | DConPr Name+ | DWildCardPr+ deriving (Show, Typeable, Data, Generic)++-- | Corresponds to TH's @TyVarBndr@+data DTyVarBndr = DPlainTV Name+ | DKindedTV Name DKind+ deriving (Show, Typeable, Data, Generic)++-- | Corresponds to TH's @Match@ type.+data DMatch = DMatch DPat DExp+ deriving (Show, Typeable, Data, Generic)++-- | Corresponds to TH's @Clause@ type.+data DClause = DClause [DPat] DExp+ deriving (Show, Typeable, Data, Generic)++-- | Declarations as used in a @let@ statement.+data DLetDec = DFunD Name [DClause]+ | DValD DPat DExp+ | DSigD Name DType+ | DInfixD Fixity Name+ | DPragmaD DPragma+ deriving (Show, Typeable, Data, Generic)++-- | Is it a @newtype@ or a @data@ type?+data NewOrData = Newtype+ | Data+ deriving (Eq, Show, Typeable, Data, Generic)++-- | Corresponds to TH's @Dec@ type.+data DDec = DLetDec DLetDec+ | DDataD NewOrData DCxt Name [DTyVarBndr] (Maybe DKind) [DCon] [DDerivClause]+ | DTySynD Name [DTyVarBndr] DType+ | DClassD DCxt Name [DTyVarBndr] [FunDep] [DDec]+ | DInstanceD (Maybe Overlap) DCxt DType [DDec]+ | DForeignD DForeign+ | DOpenTypeFamilyD DTypeFamilyHead+ | DClosedTypeFamilyD DTypeFamilyHead [DTySynEqn]+ | DDataFamilyD Name [DTyVarBndr] (Maybe DKind)+ | DDataInstD NewOrData DCxt Name [DType] (Maybe DKind) [DCon] [DDerivClause]+ | DTySynInstD Name DTySynEqn+ | DRoleAnnotD Name [Role]+ | DStandaloneDerivD (Maybe DDerivStrategy) DCxt DType+ | DDefaultSigD Name DType+ | DPatSynD Name PatSynArgs DPatSynDir DPat+ | DPatSynSigD Name DPatSynType+ deriving (Show, Typeable, Data, Generic)++#if __GLASGOW_HASKELL__ < 711+data Overlap = Overlappable | Overlapping | Overlaps | Incoherent+ deriving (Eq, Ord, Show, Typeable, Data, Generic)+#endif++-- | Corresponds to TH's 'PatSynDir' type+data DPatSynDir = DUnidir -- ^ @pattern P x {<-} p@+ | DImplBidir -- ^ @pattern P x {=} p@+ | DExplBidir [DClause] -- ^ @pattern P x {<-} p where P x = e@+ deriving (Show, Typeable, Data, Generic)++-- | Corresponds to TH's 'PatSynType' type+type DPatSynType = DType++#if __GLASGOW_HASKELL__ < 801+-- | Same as @PatSynArgs@ from TH; defined here for backwards compatibility.+data PatSynArgs+ = PrefixPatSyn [Name] -- ^ @pattern P {x y z} = p@+ | InfixPatSyn Name Name -- ^ @pattern {x P y} = p@+ | RecordPatSyn [Name] -- ^ @pattern P { {x,y,z} } = p@+ deriving (Show, Typeable, Data, Generic)+#endif++-- | Corresponds to TH's 'TypeFamilyHead' type+data DTypeFamilyHead = DTypeFamilyHead Name [DTyVarBndr] DFamilyResultSig+ (Maybe InjectivityAnn)+ deriving (Show, Typeable, Data, Generic)++-- | Corresponds to TH's 'FamilyResultSig' type+data DFamilyResultSig = DNoSig+ | DKindSig DKind+ | DTyVarSig DTyVarBndr+ deriving (Show, Typeable, Data, Generic)++#if __GLASGOW_HASKELL__ <= 710+data InjectivityAnn = InjectivityAnn Name [Name]+ deriving (Eq, Ord, Show, Typeable, Data, Generic)+#endif++-- | Corresponds to TH's 'Con' type. Unlike 'Con', all 'DCon's reflect GADT+-- syntax. This is beneficial for @th-desugar@'s since it means+-- that all data type declarations can support explicit return kinds, so+-- one does not need to represent them with something like @'Maybe' 'DKind'@,+-- since Haskell98-style data declaration syntax isn't used. Accordingly,+-- there are some differences between 'DCon' and 'Con' to keep in mind:+--+-- * Unlike 'ForallC', where the meaning of the 'TyVarBndr's changes depending+-- on whether it's followed by 'GadtC'/'RecGadtC' or not, the meaning of the+-- 'DTyVarBndr's in a 'DCon' is always the same: it is the list of+-- universally /and/ existentially quantified type variables. Note that it is+-- not guaranteed that one set of type variables will appear before the+-- other.+--+-- * A 'DCon' always has an explicit return type.+data DCon = DCon [DTyVarBndr] DCxt Name DConFields+ DType -- ^ The GADT result type+ deriving (Show, Typeable, Data, Generic)++-- | A list of fields either for a standard data constructor or a record+-- data constructor.+data DConFields = DNormalC DDeclaredInfix [DBangType]+ | DRecC [DVarBangType]+ deriving (Show, Typeable, Data, Generic)++-- | 'True' if a constructor is declared infix. For normal ADTs, this means+-- that is was written in infix style. For example, both of the constructors+-- below are declared infix.+--+-- @+-- data Infix = Int `Infix` Int | Int :*: Int+-- @+--+-- Whereas neither of these constructors are declared infix:+--+-- @+-- data Prefix = Prefix Int Int | (:+:) Int Int+-- @+--+-- For GADTs, detecting whether a constructor is declared infix is a bit+-- trickier, as one cannot write a GADT constructor "infix-style" like one+-- can for normal ADT constructors. GHC considers a GADT constructor to be+-- declared infix if it meets the following three criteria:+--+-- 1. Its name uses operator syntax (e.g., @(:*:)@).+-- 2. It has exactly two fields (without record syntax).+-- 3. It has a programmer-specified fixity declaration.+--+-- For example, in the following GADT:+--+-- @+-- infixl 5 :**:, :&&:, :^^:, `ActuallyPrefix`+-- data InfixGADT a where+-- (:**:) :: Int -> b -> InfixGADT (Maybe b) -- Only this one is infix+-- ActuallyPrefix :: Char -> Bool -> InfixGADT Double+-- (:&&:) :: { infixGADT1 :: b, infixGADT2 :: Int } -> InfixGADT [b]+-- (:^^:) :: Int -> Int -> Int -> InfixGADT Int+-- (:!!:) :: Char -> Char -> InfixGADT Char+-- @+--+-- Only the @(:**:)@ constructor is declared infix. The other constructors+-- are not declared infix, because:+--+-- * @ActuallyPrefix@ does not use operator syntax (criterion 1).+-- * @(:&&:)@ uses record syntax (criterion 2).+-- * @(:^^:)@ does not have exactly two fields (criterion 2).+-- * @(:!!:)@ does not have a programmer-specified fixity declaration (criterion 3).+type DDeclaredInfix = Bool++-- | Corresponds to TH's @BangType@ type.+type DBangType = (Bang, DType)++-- | Corresponds to TH's @VarBangType@ type.+type DVarBangType = (Name, Bang, DType)++#if __GLASGOW_HASKELL__ <= 710+-- | Corresponds to TH's definition+data SourceUnpackedness = NoSourceUnpackedness+ | SourceNoUnpack+ | SourceUnpack+ deriving (Eq, Ord, Show, Typeable, Data, Generic)++-- | Corresponds to TH's definition+data SourceStrictness = NoSourceStrictness+ | SourceLazy+ | SourceStrict+ deriving (Eq, Ord, Show, Typeable, Data, Generic)++-- | Corresponds to TH's definition+data Bang = Bang SourceUnpackedness SourceStrictness+ deriving (Eq, Ord, Show, Typeable, Data, Generic)+#endif++-- | Corresponds to TH's @Foreign@ type.+data DForeign = DImportF Callconv Safety String Name DType+ | DExportF Callconv String Name DType+ deriving (Show, Typeable, Data, Generic)++-- | Corresponds to TH's @Pragma@ type.+data DPragma = DInlineP Name Inline RuleMatch Phases+ | DSpecialiseP Name DType (Maybe Inline) Phases+ | DSpecialiseInstP DType+ | DRuleP String [DRuleBndr] DExp DExp Phases+ | DAnnP AnnTarget DExp+ | DLineP Int String+ | DCompleteP [Name] (Maybe Name)+ deriving (Show, Typeable, Data, Generic)++-- | Corresponds to TH's @RuleBndr@ type.+data DRuleBndr = DRuleVar Name+ | DTypedRuleVar Name DType+ deriving (Show, Typeable, Data, Generic)++-- | Corresponds to TH's @TySynEqn@ type (to store type family equations).+data DTySynEqn = DTySynEqn [DType] DType+ deriving (Show, Typeable, Data, Generic)++#if __GLASGOW_HASKELL__ < 707+-- | Same as @Role@ from TH; defined here for GHC 7.6.3 compatibility.+data Role = NominalR | RepresentationalR | PhantomR | InferR+ deriving (Show, Typeable, Data, Generic)++-- | Same as @AnnTarget@ from TH; defined here for GHC 7.6.3 compatibility.+data AnnTarget = ModuleAnnotation+ | TypeAnnotation Name+ | ValueAnnotation Name+ deriving (Show, Typeable, Data, Generic)+#endif++-- | Corresponds to TH's @Info@ type.+data DInfo = DTyConI DDec (Maybe [DInstanceDec])+ | DVarI Name DType (Maybe Name)+ -- ^ The @Maybe Name@ stores the name of the enclosing definition+ -- (datatype, for a data constructor; class, for a method),+ -- if any+ | DTyVarI Name DKind+ | DPrimTyConI Name Int Bool+ -- ^ The @Int@ is the arity; the @Bool@ is whether this tycon+ -- is unlifted.+ | DPatSynI Name DPatSynType+ deriving (Show, Typeable, Data, Generic)++type DInstanceDec = DDec -- ^ Guaranteed to be an instance declaration++-- | Corresponds to TH's @DerivClause@ type.+data DDerivClause = DDerivClause (Maybe DDerivStrategy) DCxt+ deriving (Show, Typeable, Data, Generic)++-- | Corresponds to TH's @DerivStrategy@ type.+data DDerivStrategy = DStockStrategy -- ^ A \"standard\" derived instance+ | DAnyclassStrategy -- ^ @-XDeriveAnyClass@+ | DNewtypeStrategy -- ^ @-XGeneralizedNewtypeDeriving@+ | DViaStrategy DType -- ^ @-XDerivingVia@+ deriving (Show, Typeable, Data, Generic)
Language/Haskell/TH/Desugar/Core.hs view
@@ -7,8 +7,7 @@ processing. The desugared types and constructors are prefixed with a D. -} -{-# LANGUAGE TemplateHaskell, LambdaCase, CPP, DeriveDataTypeable,- DeriveGeneric, TupleSections #-}+{-# LANGUAGE TemplateHaskell, LambdaCase, CPP, ScopedTypeVariables, TupleSections #-} module Language.Haskell.TH.Desugar.Core where @@ -21,17 +20,23 @@ #if __GLASGOW_HASKELL__ < 709 import Control.Applicative #endif-import Control.Monad hiding (mapM)+import Control.Monad hiding (forM_, mapM) import Control.Monad.Zip-import Control.Monad.Writer hiding (mapM)+import Control.Monad.Writer hiding (forM_, mapM) import Data.Foldable hiding (notElem)+import Data.Graph+import qualified Data.Map as Map+import Data.Map (Map)+import qualified Data.Set as Set import Data.Traversable-import Data.Data hiding (Fixity) #if __GLASGOW_HASKELL__ > 710 import Data.Maybe (isJust) #endif-import GHC.Generics hiding (Fixity) +#if __GLASGOW_HASKELL__ >= 800+import qualified Control.Monad.Fail as MonadFail+#endif+ #if __GLASGOW_HASKELL__ >= 803 import GHC.OverloadedLabels ( fromLabel ) #endif@@ -39,286 +44,10 @@ import qualified Data.Set as S import GHC.Exts +import Language.Haskell.TH.Desugar.AST import Language.Haskell.TH.Desugar.Util import Language.Haskell.TH.Desugar.Reify --- | Corresponds to TH's @Exp@ type. Note that @DLamE@ takes names, not patterns.-data DExp = DVarE Name- | DConE Name- | DLitE Lit- | DAppE DExp DExp- | DAppTypeE DExp DType- | DLamE [Name] DExp- | DCaseE DExp [DMatch]- | DLetE [DLetDec] DExp- | DSigE DExp DType- | DStaticE DExp- deriving (Show, Typeable, Data, Generic)----- | Corresponds to TH's @Pat@ type.-data DPat = DLitPa Lit- | DVarPa Name- | DConPa Name [DPat]- | DTildePa DPat- | DBangPa DPat- | DSigPa DPat DType- | DWildPa- deriving (Show, Typeable, Data, Generic)---- | Corresponds to TH's @Type@ type, used to represent--- types and kinds.-data DType = DForallT [DTyVarBndr] DCxt DType- | DAppT DType DType- | DSigT DType DKind- | DVarT Name- | DConT Name- | DArrowT- | DLitT TyLit- | DWildCardT- | DStarT- deriving (Show, Typeable, Data, Generic)---- | Kinds are types.-type DKind = DType---- | Corresponds to TH's @Cxt@-type DCxt = [DPred]---- | Corresponds to TH's @Pred@-data DPred = DAppPr DPred DType- | DSigPr DPred DKind- | DVarPr Name- | DConPr Name- | DWildCardPr- deriving (Show, Typeable, Data, Generic)---- | Corresponds to TH's @TyVarBndr@-data DTyVarBndr = DPlainTV Name- | DKindedTV Name DKind- deriving (Show, Typeable, Data, Generic)---- | Corresponds to TH's @Match@ type.-data DMatch = DMatch DPat DExp- deriving (Show, Typeable, Data, Generic)---- | Corresponds to TH's @Clause@ type.-data DClause = DClause [DPat] DExp- deriving (Show, Typeable, Data, Generic)---- | Declarations as used in a @let@ statement.-data DLetDec = DFunD Name [DClause]- | DValD DPat DExp- | DSigD Name DType- | DInfixD Fixity Name- | DPragmaD DPragma- deriving (Show, Typeable, Data, Generic)---- | Is it a @newtype@ or a @data@ type?-data NewOrData = Newtype- | Data- deriving (Eq, Show, Typeable, Data, Generic)---- | Corresponds to TH's @Dec@ type.-data DDec = DLetDec DLetDec- | DDataD NewOrData DCxt Name [DTyVarBndr] [DCon] [DDerivClause]- | DTySynD Name [DTyVarBndr] DType- | DClassD DCxt Name [DTyVarBndr] [FunDep] [DDec]- | DInstanceD (Maybe Overlap) DCxt DType [DDec]- | DForeignD DForeign- | DOpenTypeFamilyD DTypeFamilyHead- | DClosedTypeFamilyD DTypeFamilyHead [DTySynEqn]- | DDataFamilyD Name [DTyVarBndr]- | DDataInstD NewOrData DCxt Name [DType] [DCon] [DDerivClause]- | DTySynInstD Name DTySynEqn- | DRoleAnnotD Name [Role]- | DStandaloneDerivD (Maybe DerivStrategy) DCxt DType- | DDefaultSigD Name DType- | DPatSynD Name PatSynArgs DPatSynDir DPat- | DPatSynSigD Name DPatSynType- deriving (Show, Typeable, Data, Generic)--#if __GLASGOW_HASKELL__ < 711-data Overlap = Overlappable | Overlapping | Overlaps | Incoherent- deriving (Eq, Ord, Show, Typeable, Data, Generic)-#endif---- | Corresponds to TH's 'PatSynDir' type-data DPatSynDir = DUnidir -- ^ @pattern P x {<-} p@- | DImplBidir -- ^ @pattern P x {=} p@- | DExplBidir [DClause] -- ^ @pattern P x {<-} p where P x = e@- deriving (Show, Typeable, Data, Generic)---- | Corresponds to TH's 'PatSynType' type-type DPatSynType = DType--#if __GLASGOW_HASKELL__ < 801--- | Same as @PatSynArgs@ from TH; defined here for backwards compatibility.-data PatSynArgs- = PrefixPatSyn [Name] -- ^ @pattern P {x y z} = p@- | InfixPatSyn Name Name -- ^ @pattern {x P y} = p@- | RecordPatSyn [Name] -- ^ @pattern P { {x,y,z} } = p@- deriving (Show, Typeable, Data, Generic)-#endif---- | Corresponds to TH's 'TypeFamilyHead' type-data DTypeFamilyHead = DTypeFamilyHead Name [DTyVarBndr] DFamilyResultSig- (Maybe InjectivityAnn)- deriving (Show, Typeable, Data, Generic)---- | Corresponds to TH's 'FamilyResultSig' type-data DFamilyResultSig = DNoSig- | DKindSig DKind- | DTyVarSig DTyVarBndr- deriving (Show, Typeable, Data, Generic)--#if __GLASGOW_HASKELL__ <= 710-data InjectivityAnn = InjectivityAnn Name [Name]- deriving (Eq, Ord, Show, Typeable, Data, Generic)-#endif---- | Corresponds to TH's @Con@ type.-data DCon = DCon [DTyVarBndr] DCxt Name DConFields- (Maybe DType) -- ^ A GADT result type, if there is one- deriving (Show, Typeable, Data, Generic)---- | A list of fields either for a standard data constructor or a record--- data constructor.-data DConFields = DNormalC DDeclaredInfix [DBangType]- | DRecC [DVarBangType]- deriving (Show, Typeable, Data, Generic)---- | 'True' if a constructor is declared infix. For normal ADTs, this means--- that is was written in infix style. For example, both of the constructors--- below are declared infix.------ @--- data Infix = Int `Infix` Int | Int :*: Int--- @------ Whereas neither of these constructors are declared infix:------ @--- data Prefix = Prefix Int Int | (:+:) Int Int--- @------ For GADTs, detecting whether a constructor is declared infix is a bit--- trickier, as one cannot write a GADT constructor "infix-style" like one--- can for normal ADT constructors. GHC considers a GADT constructor to be--- declared infix if it meets the following three criteria:------ 1. Its name uses operator syntax (e.g., @(:*:)@).--- 2. It has exactly two fields (without record syntax).--- 3. It has a programmer-specified fixity declaration.------ For example, in the following GADT:------ @--- infixl 5 :**:, :&&:, :^^:, `ActuallyPrefix`--- data InfixGADT a where--- (:**:) :: Int -> b -> InfixGADT (Maybe b) -- Only this one is infix--- ActuallyPrefix :: Char -> Bool -> InfixGADT Double--- (:&&:) :: { infixGADT1 :: b, infixGADT2 :: Int } -> InfixGADT [b]--- (:^^:) :: Int -> Int -> Int -> InfixGADT Int--- (:!!:) :: Char -> Char -> InfixGADT Char--- @------ Only the @(:**:)@ constructor is declared infix. The other constructors--- are not declared infix, because:------ * @ActuallyPrefix@ does not use operator syntax (criterion 1).--- * @(:&&:)@ uses record syntax (criterion 2).--- * @(:^^:)@ does not have exactly two fields (criterion 2).--- * @(:!!:)@ does not have a programmer-specified fixity declaration (criterion 3).-type DDeclaredInfix = Bool---- | Corresponds to TH's @BangType@ type.-type DBangType = (Bang, DType)---- | Corresponds to TH's @VarBangType@ type.-type DVarBangType = (Name, Bang, DType)--#if __GLASGOW_HASKELL__ <= 710--- | Corresponds to TH's definition-data SourceUnpackedness = NoSourceUnpackedness- | SourceNoUnpack- | SourceUnpack- deriving (Eq, Ord, Show, Typeable, Data, Generic)---- | Corresponds to TH's definition-data SourceStrictness = NoSourceStrictness- | SourceLazy- | SourceStrict- deriving (Eq, Ord, Show, Typeable, Data, Generic)---- | Corresponds to TH's definition-data Bang = Bang SourceUnpackedness SourceStrictness- deriving (Eq, Ord, Show, Typeable, Data, Generic)-#endif---- | Corresponds to TH's @Foreign@ type.-data DForeign = DImportF Callconv Safety String Name DType- | DExportF Callconv String Name DType- deriving (Show, Typeable, Data, Generic)---- | Corresponds to TH's @Pragma@ type.-data DPragma = DInlineP Name Inline RuleMatch Phases- | DSpecialiseP Name DType (Maybe Inline) Phases- | DSpecialiseInstP DType- | DRuleP String [DRuleBndr] DExp DExp Phases- | DAnnP AnnTarget DExp- | DLineP Int String- | DCompleteP [Name] (Maybe Name)- deriving (Show, Typeable, Data, Generic)---- | Corresponds to TH's @RuleBndr@ type.-data DRuleBndr = DRuleVar Name- | DTypedRuleVar Name DType- deriving (Show, Typeable, Data, Generic)---- | Corresponds to TH's @TySynEqn@ type (to store type family equations).-data DTySynEqn = DTySynEqn [DType] DType- deriving (Show, Typeable, Data, Generic)--#if __GLASGOW_HASKELL__ < 707--- | Same as @Role@ from TH; defined here for GHC 7.6.3 compatibility.-data Role = NominalR | RepresentationalR | PhantomR | InferR- deriving (Show, Typeable, Data, Generic)---- | Same as @AnnTarget@ from TH; defined here for GHC 7.6.3 compatibility.-data AnnTarget = ModuleAnnotation- | TypeAnnotation Name- | ValueAnnotation Name- deriving (Show, Typeable, Data, Generic)-#endif---- | Corresponds to TH's @Info@ type.-data DInfo = DTyConI DDec (Maybe [DInstanceDec])- | DVarI Name DType (Maybe Name)- -- ^ The @Maybe Name@ stores the name of the enclosing definition- -- (datatype, for a data constructor; class, for a method),- -- if any- | DTyVarI Name DKind- | DPrimTyConI Name Int Bool- -- ^ The @Int@ is the arity; the @Bool@ is whether this tycon- -- is unlifted.- | DPatSynI Name DPatSynType- deriving (Show, Typeable, Data, Generic)--type DInstanceDec = DDec -- ^ Guaranteed to be an instance declaration---- | Corresponds to TH's @DerivClause@ type.-data DDerivClause = DDerivClause (Maybe DerivStrategy) DCxt- deriving (Show, Typeable, Data, Generic)--#if __GLASGOW_HASKELL__ < 801--- | Same as @DerivStrategy@ from TH; defined here for backwards compatibility.-data DerivStrategy = StockStrategy -- ^ A \"standard\" derived instance- | AnyclassStrategy -- ^ @-XDeriveAnyClass@- | NewtypeStrategy -- ^ @-XGeneralizedNewtypeDeriving@- deriving (Show, Typeable, Data, Generic)-#endif- -- | Desugar an expression dsExp :: DsMonad q => Exp -> q DExp dsExp (VarE n) = return $ DVarE n@@ -395,7 +124,7 @@ RecGadtC _names fields _ret_ty -> reorder_fields fields #endif - reorder_fields fields = reorderFields fields field_exps+ reorder_fields fields = reorderFields con_name fields field_exps (repeat $ DVarE 'undefined) non_record fields | null field_exps@@ -467,7 +196,7 @@ field_var_names <- mapM (newUniqueName . nameBase) con_field_names DMatch (DConPa con_name (map DVarPa field_var_names)) <$> (foldl DAppE (DConE con_name) <$>- (reorderFields args field_exps (map DVarE field_var_names)))+ (reorderFields con_name args field_exps (map DVarE field_var_names))) con_to_dmatch :: DsMonad q => Con -> q DMatch con_to_dmatch (RecC con_name args) = rec_con_to_dmatch con_name args@@ -500,13 +229,36 @@ -- | Desugar a lambda expression, where the body has already been desugared dsLam :: DsMonad q => [Pat] -> DExp -> q DExp-dsLam pats exp- | Just names <- mapM stripVarP_maybe pats+dsLam = mkLam stripVarP_maybe dsPatsOverExp++-- | Convert a list of 'DPat' arguments and a 'DExp' body into a 'DLamE'. This+-- is needed since 'DLamE' takes a list of 'Name's for its bound variables+-- instead of 'DPat's, so some reorganization is needed.+mkDLamEFromDPats :: DsMonad q => [DPat] -> DExp -> q DExp+mkDLamEFromDPats = mkLam stripDVarPa_maybe (\pats exp -> return (pats, exp))+ where+ stripDVarPa_maybe :: DPat -> Maybe Name+ stripDVarPa_maybe (DVarPa n) = Just n+ stripDVarPa_maybe _ = Nothing++-- | Generalizes 'dsLam' and 'mkDLamEFromDPats' to work over an arbitrary+-- pattern type.+mkLam :: DsMonad q+ => (pat -> Maybe Name) -- ^ Should return @'Just' n@ if the argument is a+ -- variable pattern, and 'Nothing' otherwise.+ -> ([pat] -> DExp -> q ([DPat], DExp))+ -- ^ Should process a list of @pat@ arguments and+ -- a 'DExp' body. (This might do some internal+ -- reorganization if there are as-patterns, as+ -- in the case of 'dsPatsOverExp'.)+ -> [pat] -> DExp -> q DExp+mkLam mb_strip_var_pat process_pats_over_exp pats exp+ | Just names <- mapM mb_strip_var_pat pats = return $ DLamE names exp | otherwise = do arg_names <- replicateM (length pats) (newUniqueName "arg") let scrutinee = mkTupleDExp (map DVarE arg_names)- (pats', exp') <- dsPatsOverExp pats exp+ (pats', exp') <- process_pats_over_exp pats exp let match = DMatch (mkTupleDPat pats') exp' return $ DLamE arg_names (DCaseE scrutinee [match]) @@ -601,9 +353,8 @@ dsDoStmts [] = impossible "do-expression ended with something other than bare statement." dsDoStmts [NoBindS exp] = dsExp exp dsDoStmts (BindS pat exp : rest) = do- exp' <- dsExp exp rest' <- dsDoStmts rest- DAppE (DAppE (DVarE '(>>=)) exp') <$> dsLam [pat] rest'+ dsBindS exp pat rest' "do expression" dsDoStmts (LetS decs : rest) = DLetE <$> dsLetDecs decs <*> dsDoStmts rest dsDoStmts (NoBindS exp : rest) = do exp' <- dsExp exp@@ -616,9 +367,8 @@ dsComp [] = impossible "List/monad comprehension ended with something other than a bare statement." dsComp [NoBindS exp] = DAppE (DVarE 'return) <$> dsExp exp dsComp (BindS pat exp : rest) = do- exp' <- dsExp exp rest' <- dsComp rest- DAppE (DAppE (DVarE '(>>=)) exp') <$> dsLam [pat] rest'+ dsBindS exp pat rest' "monad comprehension" dsComp (LetS decs : rest) = DLetE <$> dsLetDecs decs <*> dsComp rest dsComp (NoBindS exp : rest) = do exp' <- dsExp exp@@ -629,6 +379,39 @@ rest' <- dsComp rest DAppE (DAppE (DVarE '(>>=)) exp) <$> dsLam [pat] rest' +-- Desugar a binding statement in a do- or list comprehension.+--+-- In the event that the pattern in the statement is partial, the desugared+-- case expression will contain a catch-all case that calls 'fail' from either+-- 'MonadFail' or 'Monad', depending on whether the @MonadFailDesugaring@+-- language extension is enabled or not. (On GHCs older than 8.0, 'fail' from+-- 'Monad' is always used.)+dsBindS :: forall q. DsMonad q => Exp -> Pat -> DExp -> String -> q DExp+dsBindS bind_arg_exp success_pat success_exp ctxt = do+ bind_arg_exp' <- dsExp bind_arg_exp+ (success_pat', success_exp') <- dsPatOverExp success_pat success_exp+ is_univ_pat <- isUniversalPattern success_pat'+ let bind_into = DAppE (DAppE (DVarE '(>>=)) bind_arg_exp')+ if is_univ_pat+ then bind_into <$> mkDLamEFromDPats [success_pat'] success_exp'+ else do arg_name <- newUniqueName "arg"+ fail_name <- mk_fail_name+ return $ bind_into $ DLamE [arg_name] $ DCaseE (DVarE arg_name)+ [ DMatch success_pat' success_exp'+ , DMatch DWildPa $+ DVarE fail_name `DAppE`+ DLitE (StringL $ "Pattern match failure in " ++ ctxt)+ ]+ where+ mk_fail_name :: q Name+#if __GLASGOW_HASKELL__ >= 800+ mk_fail_name = do+ mfd <- qIsExtEnabled MonadFailDesugaring+ return $ if mfd then 'MonadFail.fail else 'Prelude.fail+#else+ mk_fail_name = return 'Prelude.fail+#endif+ -- | Desugar the contents of a parallel comprehension. -- Returns a @Pat@ containing a tuple of all bound variables and an expression -- to produce the values for those variables@@ -715,7 +498,7 @@ RecGadtC _names fields _ret_ty -> reorder_fields_pat fields #endif - reorder_fields_pat fields = reorderFieldsPat fields field_pats+ reorder_fields_pat fields = reorderFieldsPat con_name fields field_pats non_record fields | null field_pats -- Special case: record patterns are allowed for any@@ -827,7 +610,7 @@ eqns' = map (fixBug8884ForEqn num_args) eqns frs' <- remove_arrows num_args frs return (DClosedTypeFamilyD (DTypeFamilyHead name tvbs frs' ann) eqns', num_args)-fixBug8884ForFamilies dec@(DDataFamilyD _ _)+fixBug8884ForFamilies dec@(DDataFamilyD _ _ _) = return (dec, 0) -- the num_args is ignored for data families fixBug8884ForFamilies dec = impossible $ "Reifying yielded a FamilyI with a non-family Dec: " ++ show dec@@ -872,25 +655,35 @@ dsDec d@(ValD {}) = (fmap . map) DLetDec $ dsLetDec d #if __GLASGOW_HASKELL__ > 710 dsDec (DataD cxt n tvbs mk cons derivings) = do- extra_tvbs <- mkExtraTvbs tvbs mk+ tvbs' <- mapM dsTvb tvbs+ all_tvbs <- nonFamilyDataTvbs tvbs' mk+ let data_type = nonFamilyDataReturnType n all_tvbs (:[]) <$> (DDataD Data <$> dsCxt cxt <*> pure n- <*> ((++ extra_tvbs) <$> mapM dsTvb tvbs)- <*> concatMapM dsCon cons+ <*> pure tvbs' <*> mapM dsType mk+ <*> concatMapM (dsCon tvbs' data_type) cons <*> mapM dsDerivClause derivings) dsDec (NewtypeD cxt n tvbs mk con derivings) = do- extra_tvbs <- mkExtraTvbs tvbs mk+ tvbs' <- mapM dsTvb tvbs+ all_tvbs <- nonFamilyDataTvbs tvbs' mk+ let data_type = nonFamilyDataReturnType n all_tvbs (:[]) <$> (DDataD Newtype <$> dsCxt cxt <*> pure n- <*> ((++ extra_tvbs) <$> mapM dsTvb tvbs)- <*> dsCon con+ <*> pure tvbs' <*> mapM dsType mk+ <*> dsCon tvbs' data_type con <*> mapM dsDerivClause derivings) #else-dsDec (DataD cxt n tvbs cons derivings) =+dsDec (DataD cxt n tvbs cons derivings) = do+ tvbs' <- mapM dsTvb tvbs+ let data_type = nonFamilyDataReturnType n tvbs' (:[]) <$> (DDataD Data <$> dsCxt cxt <*> pure n- <*> mapM dsTvb tvbs <*> concatMapM dsCon cons+ <*> pure tvbs' <*> pure Nothing+ <*> concatMapM (dsCon tvbs' data_type) cons <*> mapM dsDerivClause derivings)-dsDec (NewtypeD cxt n tvbs con derivings) =+dsDec (NewtypeD cxt n tvbs con derivings) = do+ tvbs' <- mapM dsTvb tvbs+ let data_type = nonFamilyDataReturnType n tvbs' (:[]) <$> (DDataD Newtype <$> dsCxt cxt <*> pure n- <*> mapM dsTvb tvbs <*> dsCon con+ <*> pure tvbs' <*> pure Nothing+ <*> dsCon tvbs' data_type con <*> mapM dsDerivClause derivings) #endif dsDec (TySynD n tvbs ty) =@@ -912,37 +705,50 @@ #if __GLASGOW_HASKELL__ > 710 dsDec (OpenTypeFamilyD tfHead) = (:[]) <$> (DOpenTypeFamilyD <$> dsTypeFamilyHead tfHead)-dsDec (DataFamilyD n tvbs m_k) = do- extra_tvbs <- mkExtraTvbs tvbs m_k- (:[]) <$> (DDataFamilyD n <$> ((++ extra_tvbs) <$> mapM dsTvb tvbs))+dsDec (DataFamilyD n tvbs m_k) =+ (:[]) <$> (DDataFamilyD n <$> mapM dsTvb tvbs <*> mapM dsType m_k) #else dsDec (FamilyD TypeFam n tvbs m_k) = do (:[]) <$> (DOpenTypeFamilyD <$> dsTypeFamilyHead n tvbs m_k)-dsDec (FamilyD DataFam n tvbs m_k) = do- extra_tvbs <- mkExtraTvbs tvbs m_k- (:[]) <$> (DDataFamilyD n <$> ((++ extra_tvbs) <$> mapM dsTvb tvbs))+dsDec (FamilyD DataFam n tvbs m_k) =+ (:[]) <$> (DDataFamilyD n <$> mapM dsTvb tvbs <*> mapM dsType m_k) #endif #if __GLASGOW_HASKELL__ > 710 dsDec (DataInstD cxt n tys mk cons derivings) = do- extra_tvbs <- map dTyVarBndrToDType <$> mkExtraTvbs [] mk+ tys' <- mapM dsType tys+ all_tys <- dataFamInstTypes tys' mk+ let tvbs = dataFamInstTvbs all_tys+ fam_inst_type = dataFamInstReturnType n all_tys (:[]) <$> (DDataInstD Data <$> dsCxt cxt <*> pure n- <*> ((++ extra_tvbs) <$> mapM dsType tys)- <*> concatMapM dsCon cons+ <*> pure tys' <*> mapM dsType mk+ <*> concatMapM (dsCon tvbs fam_inst_type) cons <*> mapM dsDerivClause derivings) dsDec (NewtypeInstD cxt n tys mk con derivings) = do- extra_tvbs <- map dTyVarBndrToDType <$> mkExtraTvbs [] mk+ tys' <- mapM dsType tys+ all_tys <- dataFamInstTypes tys' mk+ let tvbs = dataFamInstTvbs all_tys+ fam_inst_type = dataFamInstReturnType n all_tys (:[]) <$> (DDataInstD Newtype <$> dsCxt cxt <*> pure n- <*> ((++ extra_tvbs) <$> mapM dsType tys)- <*> dsCon con+ <*> pure tys' <*> mapM dsType mk+ <*> dsCon tvbs fam_inst_type con <*> mapM dsDerivClause derivings) #else dsDec (DataInstD cxt n tys cons derivings) = do- (:[]) <$> (DDataInstD Data <$> dsCxt cxt <*> pure n <*> mapM dsType tys- <*> concatMapM dsCon cons+ tys' <- mapM dsType tys+ let tvbs = dataFamInstTvbs tys'+ fam_inst_type = dataFamInstReturnType n tys'+ (:[]) <$> (DDataInstD Data <$> dsCxt cxt <*> pure n+ <*> pure tys' <*> pure Nothing+ <*> concatMapM (dsCon tvbs fam_inst_type) cons <*> mapM dsDerivClause derivings) dsDec (NewtypeInstD cxt n tys con derivings) = do- (:[]) <$> (DDataInstD Newtype <$> dsCxt cxt <*> pure n <*> mapM dsType tys- <*> dsCon con <*> mapM dsDerivClause derivings)+ tys' <- mapM dsType tys+ let tvbs = dataFamInstTvbs tys'+ fam_inst_type = dataFamInstReturnType n tys'+ (:[]) <$> (DDataInstD Newtype <$> dsCxt cxt <*> pure n+ <*> pure tys' <*> pure Nothing+ <*> dsCon tvbs fam_inst_type con+ <*> mapM dsDerivClause derivings) #endif #if __GLASGOW_HASKELL__ < 707 dsDec (TySynInstD n lhs rhs) = (:[]) <$> (DTySynInstD n <$>@@ -971,7 +777,7 @@ return [DPatSynD n args dir' pat'] dsDec (PatSynSigD n ty) = (:[]) <$> (DPatSynSigD n <$> dsType ty) dsDec (StandaloneDerivD mds cxt ty) =- (:[]) <$> (DStandaloneDerivD mds <$> dsCxt cxt <*> dsType ty)+ (:[]) <$> (DStandaloneDerivD <$> mapM dsDerivStrategy mds <*> dsCxt cxt <*> dsType ty) #else dsDec (StandaloneDerivD cxt ty) = (:[]) <$> (DStandaloneDerivD Nothing <$> dsCxt cxt <*> dsType ty)@@ -979,36 +785,16 @@ dsDec (DefaultSigD n ty) = (:[]) <$> (DDefaultSigD n <$> dsType ty) #endif -mkExtraTvbs :: DsMonad q => [TyVarBndr] -> Maybe Kind -> q [DTyVarBndr]-mkExtraTvbs _ Nothing = return []-mkExtraTvbs orig_tvbs (Just k) = do- k' <- runQ (expandSyns k) -- just in case- dk <- dsType k'- let args = split_funs [] dk- -- christiaanb: I have no idea how GHC normally picks fresh- -- tyvars, this looks like something GHC might do. Though probably in a- -- nicer/safer way.- --- -- RAE: It's actually not terribly far off from what GHC does. This is- -- terrible. But I don't see another way to do this. <shudder>- --- -- All of this is needed so that "dec test 9" passes.- orig_names = map (nameBase . tvbName) orig_tvbs- all_names =-#if __GLASGOW_HASKELL__ <= 708- map ('$':) $-#endif- take (length args + length orig_tvbs)- (map (:[]) ['a' .. 'z'] ++- concatMap (zipWith (:) ['a' .. 'z'] . repeat . show)- [(0::Int)..])- new_names = filter (`notElem` orig_names) all_names- names <- zipWithM (\n _ -> qNewName n) new_names args- return (zipWith DKindedTV names args)- where- split_funs args (DAppT (DAppT DArrowT arg) res) = split_funs (arg:args) res- split_funs args _other = reverse args+-- Like mkExtraDKindBinders, but accepts a Maybe Kind+-- argument instead of DKind.+mkExtraKindBinders :: DsMonad q => Maybe Kind -> q [DTyVarBndr]+mkExtraKindBinders =+ maybe (pure (DConT typeKindName)) (runQ . expandSyns >=> dsType) >=> mkExtraDKindBinders' +-- | Like mkExtraDKindBinders, but assumes kind synonyms have been expanded.+mkExtraDKindBinders' :: Quasi q => DKind -> q [DTyVarBndr]+mkExtraDKindBinders' = mkExtraKindBindersGeneric unravel DKindedTV+ #if __GLASGOW_HASKELL__ > 710 -- | Desugar a @FamilyResultSig@ dsFamilyResultSig :: DsMonad q => FamilyResultSig -> q DFamilyResultSig@@ -1060,24 +846,72 @@ dsLetDec _dec = impossible "Illegal declaration in let expression." -- | Desugar a single @Con@.+--+-- Because we always desugar @Con@s to GADT syntax (see the documentation for+-- 'DCon'), it is not always possible to desugar with just a 'Con' alone.+-- For instance, we must desugar:+--+-- @+-- data Foo a = forall b. MkFoo b+-- @+--+-- To this:+--+-- @+-- data Foo a :: Type where+-- MkFoo :: forall a b. b -> Foo a+-- @+--+-- If our only argument was @forall b. MkFoo b@, it would be somewhat awkward+-- to figure out (1) what the set of universally quantified type variables+-- (@[a]@) was, and (2) what the return type (@Foo a@) was. For this reason,+-- we require passing these as arguments. (If we desugar an actual GADT+-- constructor, these arguments are ignored.) dsCon :: DsMonad q- => Con -> q [DCon]-dsCon (NormalC n stys) =- (:[]) <$> (DCon [] [] n <$> (DNormalC False <$> mapM dsBangType stys) <*> pure Nothing)-dsCon (RecC n vstys) =- (:[]) <$> (DCon [] [] n <$> (DRecC <$> mapM dsVarBangType vstys) <*> pure Nothing)-dsCon (InfixC sty1 n sty2) = do+ => [DTyVarBndr] -- ^ The universally quantified type variables+ -- (used if desugaring a non-GADT constructor).+ -> DType -- ^ The original data declaration's type+ -- (used if desugaring a non-GADT constructor).+ -> Con -> q [DCon]+dsCon univ_dtvbs data_type con = do+ dcons' <- dsCon' con+ return $ flip map dcons' $ \(n, dtvbs, dcxt, fields, m_gadt_type) ->+ case m_gadt_type of+ Nothing ->+ let ex_dtvbs = dtvbs in+ DCon (univ_dtvbs ++ ex_dtvbs) dcxt n fields data_type+ Just gadt_type ->+ let univ_ex_dtvbs = dtvbs in+ DCon univ_ex_dtvbs dcxt n fields gadt_type++-- Desugar a Con in isolation. The meaning of the returned DTyVarBndrs changes+-- depending on what the returned Maybe DType value is:+--+-- * If returning Just gadt_ty, then we've encountered a GadtC or RecGadtC,+-- so the returned DTyVarBndrs are both the universally and existentially+-- quantified tyvars.+-- * If returning Nothing, we're dealing with a non-GADT constructor, so+-- the returned DTyVarBndrs are the existentials only.+dsCon' :: DsMonad q+ => Con -> q [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]+dsCon' (NormalC n stys) = do+ dtys <- mapM dsBangType stys+ return [(n, [], [], DNormalC False dtys, Nothing)]+dsCon' (RecC n vstys) = do+ vdtys <- mapM dsVarBangType vstys+ return [(n, [], [], DRecC vdtys, Nothing)]+dsCon' (InfixC sty1 n sty2) = do dty1 <- dsBangType sty1 dty2 <- dsBangType sty2- return $ [DCon [] [] n (DNormalC True [dty1, dty2]) Nothing]-dsCon (ForallC tvbs cxt con) = do+ return [(n, [], [], DNormalC True [dty1, dty2], Nothing)]+dsCon' (ForallC tvbs cxt con) = do dtvbs <- mapM dsTvb tvbs dcxt <- dsCxt cxt- dcons <- dsCon con- return $ flip map dcons $ \(DCon dtvbs' dcxt' n fields m_kind) ->- DCon (dtvbs ++ dtvbs') (dcxt ++ dcxt') n fields m_kind+ dcons' <- dsCon' con+ return $ flip map dcons' $ \(n, dtvbs', dcxt', fields, m_gadt_type) ->+ (n, dtvbs ++ dtvbs', dcxt ++ dcxt', fields, m_gadt_type) #if __GLASGOW_HASKELL__ > 710-dsCon (GadtC nms btys rty) = do+dsCon' (GadtC nms btys rty) = do dbtys <- mapM dsBangType btys drty <- dsType rty sequence $ flip map nms $ \nm -> do@@ -1089,12 +923,12 @@ || length dbtys == 2 -- 2. It has exactly two fields || isJust mbFi -- 3. It has a programmer-specified -- fixity declaration- return $ DCon [] [] nm (DNormalC decInfix dbtys) (Just drty)-dsCon (RecGadtC nms vbtys rty) = do+ return (nm, [], [], DNormalC decInfix dbtys, Just drty)+dsCon' (RecGadtC nms vbtys rty) = do dvbtys <- mapM dsVarBangType vbtys drty <- dsType rty return $ flip map nms $ \nm ->- DCon [] [] nm (DRecC dvbtys) (Just drty)+ (nm, [], [], DRecC dvbtys, Just drty) #endif #if __GLASGOW_HASKELL__ > 710@@ -1204,7 +1038,7 @@ dsType (PromotedTupleT n) = return $ DConT (tupleDataName n) dsType PromotedNilT = return $ DConT '[] dsType PromotedConsT = return $ DConT '(:)-dsType StarT = return DStarT+dsType StarT = return $ DConT typeKindName dsType ConstraintT = return $ DConT ''Constraint dsType (LitT lit) = return $ DLitT lit #if __GLASGOW_HASKELL__ >= 709@@ -1232,7 +1066,8 @@ #if __GLASGOW_HASKELL__ >= 801 -- | Desugar a @DerivClause@. dsDerivClause :: DsMonad q => DerivClause -> q DDerivClause-dsDerivClause (DerivClause mds cxt) = DDerivClause mds <$> dsCxt cxt+dsDerivClause (DerivClause mds cxt) =+ DDerivClause <$> mapM dsDerivStrategy mds <*> dsCxt cxt #elif __GLASGOW_HASKELL__ >= 711 dsDerivClause :: DsMonad q => Pred -> q DDerivClause dsDerivClause p = DDerivClause Nothing <$> dsPred p@@ -1242,6 +1077,17 @@ #endif #if __GLASGOW_HASKELL__ >= 801+-- | Desugar a @DerivStrategy@.+dsDerivStrategy :: DsMonad q => DerivStrategy -> q DDerivStrategy+dsDerivStrategy StockStrategy = pure DStockStrategy+dsDerivStrategy AnyclassStrategy = pure DAnyclassStrategy+dsDerivStrategy NewtypeStrategy = pure DNewtypeStrategy+#if __GLASGOW_HASKELL__ >= 805+dsDerivStrategy (ViaStrategy ty) = DViaStrategy <$> dsType ty+#endif+#endif++#if __GLASGOW_HASKELL__ >= 801 -- | Desugar a @PatSynDir@. (Available only with GHC 8.2+) dsPatSynDir :: DsMonad q => Name -> PatSynDir -> q DPatSynDir dsPatSynDir _ Unidir = pure DUnidir@@ -1262,7 +1108,12 @@ dsPred t | Just ts <- splitTuple_maybe t = concatMapM dsPred ts-dsPred t@(ForallT _ _ _) = impossible $ "Forall seen in constraint: " ++ show t+dsPred (ForallT tvbs cxt p) = do+ ps' <- dsPred p+ case ps' of+ [p'] -> (:[]) <$> (DForallPr <$> mapM dsTvb tvbs <*> dsCxt cxt <*> pure p')+ _ -> fail "Cannot desugar constraint tuples in the body of a quantified constraint"+ -- See Trac #15334. dsPred (AppT t1 t2) = do [p1] <- dsPred t1 -- tuples can't be applied! (:[]) <$> DAppPr p1 <$> dsType t2@@ -1313,26 +1164,37 @@ -- but with the values as given in the second argument -- if a field is missing from the second argument, use the corresponding expression -- from the third argument-reorderFields :: DsMonad q => [VarStrictType] -> [FieldExp] -> [DExp] -> q [DExp]+reorderFields :: DsMonad q => Name -> [VarStrictType] -> [FieldExp] -> [DExp] -> q [DExp] reorderFields = reorderFields' dsExp -reorderFieldsPat :: DsMonad q => [VarStrictType] -> [FieldPat] -> PatM q [DPat]-reorderFieldsPat field_decs field_pats =- reorderFields' dsPat field_decs field_pats (repeat DWildPa)+reorderFieldsPat :: DsMonad q => Name -> [VarStrictType] -> [FieldPat] -> PatM q [DPat]+reorderFieldsPat con_name field_decs field_pats =+ reorderFields' dsPat con_name field_decs field_pats (repeat DWildPa) reorderFields' :: (Applicative m, Monad m) => (a -> m da)+ -> Name -- ^ The name of the constructor (used for error reporting) -> [VarStrictType] -> [(Name, a)] -> [da] -> m [da]-reorderFields' _ [] _ _ = return []-reorderFields' ds_thing ((field_name, _, _) : rest)- field_things (deflt : rest_deflt) = do- rest' <- reorderFields' ds_thing rest field_things rest_deflt- case find (\(thing_name, _) -> thing_name == field_name) field_things of- Just (_, thing) -> (: rest') <$> ds_thing thing- Nothing -> return $ deflt : rest'-reorderFields' _ (_ : _) _ [] = error "Internal error in th-desugar."+reorderFields' ds_thing con_name field_names_types field_things deflts =+ check_valid_fields >> reorder field_names deflts+ where+ field_names = map (\(a, _, _) -> a) field_names_types + check_valid_fields =+ forM_ field_things $ \(thing_name, _) ->+ unless (thing_name `elem` field_names) $+ fail $ "Constructor ‘" ++ nameBase con_name ++ "‘ does not have field ‘"+ ++ nameBase thing_name ++ "‘"++ reorder [] _ = return []+ reorder (field_name : rest) (deflt : rest_deflt) = do+ rest' <- reorder rest rest_deflt+ case find (\(thing_name, _) -> thing_name == field_name) field_things of+ Just (_, thing) -> (: rest') <$> ds_thing thing+ Nothing -> return $ deflt : rest'+ reorder (_ : _) [] = error "Internal error in th-desugar."+ -- | Make a tuple 'DExp' from a list of 'DExp's. Avoids using a 1-tuple. mkTupleDExp :: [DExp] -> DExp mkTupleDExp [exp] = exp@@ -1394,9 +1256,10 @@ strictToBang = id #endif --- | Convert a 'DType' to a 'DPred'+-- | Convert a 'DType' to a 'DPred'. dTypeToDPred :: Monad q => DType -> q DPred-dTypeToDPred (DForallT _ _ _) = impossible "Forall-type used as constraint"+dTypeToDPred (DForallT tvbs cxt ty)+ = DForallPr tvbs cxt `liftM` dTypeToDPred ty dTypeToDPred (DAppT t1 t2) = liftM2 DAppPr (dTypeToDPred t1) (return t2) dTypeToDPred (DSigT ty ki) = liftM2 DSigPr (dTypeToDPred ty) (return ki) dTypeToDPred (DVarT n) = return $ DVarPr n@@ -1404,4 +1267,150 @@ dTypeToDPred DArrowT = impossible "Arrow used as head of constraint" dTypeToDPred (DLitT _) = impossible "Type literal used as head of constraint" dTypeToDPred DWildCardT = return DWildCardPr-dTypeToDPred DStarT = impossible "Star used as head of constraint"++-- | Convert a 'DPred' to 'DType'.+dPredToDType :: DPred -> DType+dPredToDType (DForallPr tvbs cxt p) = DForallT tvbs cxt (dPredToDType p)+dPredToDType (DAppPr p t) = DAppT (dPredToDType p) t+dPredToDType (DSigPr p k) = DSigT (dPredToDType p) k+dPredToDType (DVarPr n) = DVarT n+dPredToDType (DConPr n) = DConT n+dPredToDType DWildCardPr = DWildCardT++-- Take a data type name (which does not belong to a data family) and+-- apply it to its type variable binders to form a DType.+nonFamilyDataReturnType :: Name -> [DTyVarBndr] -> DType+nonFamilyDataReturnType con_name = applyDType (DConT con_name) . map dTyVarBndrToDType++-- Take a data family name and apply it to its argument types to form a+-- data family instance DType.+dataFamInstReturnType :: Name -> [DType] -> DType+dataFamInstReturnType fam_name = applyDType (DConT fam_name)++-- Take a data type (which does not belong to a data family) of the form+-- @Foo a :: k -> Type -> Type@ and return @Foo a (b :: k) (c :: Type)@, where+-- @b@ and @c@ are fresh type variable names.+nonFamilyDataTvbs :: DsMonad q => [DTyVarBndr] -> Maybe Kind -> q [DTyVarBndr]+nonFamilyDataTvbs tvbs mk = do+ extra_tvbs <- mkExtraKindBinders mk+ pure $ tvbs ++ extra_tvbs++-- Take a data family instance of the form @Foo a :: k -> Type -> Type@ and+-- return @Foo a (b :: k) (c :: Type)@, where @b@ and @c@ are fresh type+-- variable names.+dataFamInstTypes :: DsMonad q => [DType] -> Maybe Kind -> q [DType]+dataFamInstTypes tys mk = do+ extra_tvbs <- mkExtraKindBinders mk+ pure $ tys ++ map dTyVarBndrToDType extra_tvbs++-- Unlike vanilla data types and data family declarations, data family+-- instance declarations do not come equipped with a list of bound type+-- variables (at least not yet—see Trac #14268). This means that we have+-- to reverse engineer this information ourselves from the list of type+-- patterns. We accomplish this by taking the free variables of the types+-- and performing a reverse topological sort on them to ensure that the+-- returned list is well scoped.+dataFamInstTvbs :: [DType] -> [DTyVarBndr]+dataFamInstTvbs = toposortTyVarsOf++-- | Take a list of 'DType's, find their free variables, and sort them in+-- reverse topological order to ensure that they are well scoped.+--+-- On older GHCs, this takes measures to avoid returning explicitly bound+-- kind variables, which was not possible before @TypeInType@.+toposortTyVarsOf :: [DType] -> [DTyVarBndr]+toposortTyVarsOf tys =+ let fvs :: [Name]+ fvs = Set.toList $ foldMap fvDType tys++ varKindSigs :: Map Name DKind+ varKindSigs = foldMap go tys+ where+ go :: DType -> Map Name DKind+ go (DForallT {}) = error "`forall` type used in type family pattern"+ go (DAppT t1 t2) = go t1 `mappend` go t2+ go (DSigT t k) =+ let kSigs = go k+ in case t of+ DVarT n -> Map.insert n k kSigs+ _ -> go t `mappend` kSigs+ go (DVarT {}) = mempty+ go (DConT {}) = mempty+ go DArrowT = mempty+ go (DLitT {}) = mempty+ go DWildCardT = mempty++ (g, gLookup, _)+ = graphFromEdges [ (fv, fv, kindVars)+ | fv <- fvs+ , let kindVars =+ case Map.lookup fv varKindSigs of+ Nothing -> []+ Just ks -> Set.toList (fvDType ks)+ ]+ tg = reverse $ topSort g++ lookupVertex x =+ case gLookup x of+ (n, _, _) -> n++ ascribeWithKind n+ | Just k <- Map.lookup n varKindSigs+ = DKindedTV n k+ | otherwise+ = DPlainTV n++ -- 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 = foldMap fvDType $ Map.elems varKindSigs+#endif++ in map ascribeWithKind $+ filter (not . isKindBinderOnOldGHCs) $+ map lookupVertex tg++fvDType :: DType -> S.Set Name+fvDType = go_ty+ where+ go_ty :: DType -> S.Set Name+ go_ty (DForallT tvbs cxt ty) = foldr go_tvb (foldMap go_pred cxt <> go_ty ty) tvbs+ go_ty (DAppT t1 t2) = go_ty t1 <> go_ty t2+ go_ty (DSigT ty ki) = go_ty ty <> go_ty ki+ go_ty (DVarT n) = S.singleton n+ go_ty (DConT {}) = S.empty+ go_ty DArrowT = S.empty+ go_ty (DLitT {}) = S.empty+ go_ty DWildCardT = S.empty++ go_pred :: DPred -> S.Set Name+ go_pred (DAppPr pr ty) = go_pred pr <> go_ty ty+ go_pred (DSigPr pr ki) = go_pred pr <> go_ty ki+ go_pred (DVarPr n) = S.singleton n+ go_pred _ = S.empty++ go_tvb :: DTyVarBndr -> S.Set Name -> S.Set Name+ go_tvb (DPlainTV n) fvs = S.delete n fvs+ go_tvb (DKindedTV n k) fvs = S.delete n fvs <> go_ty k++dtvbName :: DTyVarBndr -> Name+dtvbName (DPlainTV n) = n+dtvbName (DKindedTV n _) = n++-- | Decompose a function type into its type variables, its context, its+-- argument types, and its result type.+unravel :: DType -> ([DTyVarBndr], [DPred], [DType], DType)+unravel (DForallT tvbs cxt ty) =+ let (tvbs', cxt', tys, res) = unravel ty in+ (tvbs ++ tvbs', cxt ++ cxt', tys, res)+unravel (DAppT (DAppT DArrowT t1) t2) =+ let (tvbs, cxt, tys, res) = unravel t2 in+ (tvbs, cxt, t1 : tys, res)+unravel t = ([], [], [], t)
Language/Haskell/TH/Desugar/Expand.hs view
@@ -4,14 +4,14 @@ rae@cs.brynmawr.edu -} -{-# LANGUAGE CPP, NoMonomorphismRestriction #-}+{-# LANGUAGE CPP, NoMonomorphismRestriction, ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Language.Haskell.TH.Desugar.Expand -- Copyright : (C) 2014 Richard Eisenberg -- License : BSD-style (see LICENSE)--- Maintainer : Richard Eisenberg (rae@cs.brynmawr.edu)+-- Maintainer : Ryan Scott -- Stability : experimental -- Portability : non-portable --@@ -40,6 +40,7 @@ import Data.Generics import qualified Data.Traversable as T +import Language.Haskell.TH.Desugar.AST import Language.Haskell.TH.Desugar.Core import Language.Haskell.TH.Desugar.Util import Language.Haskell.TH.Desugar.Sweeten@@ -54,11 +55,12 @@ expandType :: DsMonad q => DType -> q DType expandType = expand_type NoIgnore -expand_type :: DsMonad q => IgnoreKinds -> DType -> q DType+expand_type :: forall q. DsMonad q => IgnoreKinds -> DType -> q DType expand_type ign = go [] where+ go :: [DType] -> DType -> q DType go [] (DForallT tvbs cxt ty) =- DForallT tvbs <$> mapM (expand_ ign) cxt <*> expand_type ign ty+ DForallT tvbs <$> mapM (expand_pred ign) cxt <*> expand_type ign ty go _ (DForallT {}) = impossible "A forall type is applied to another type." go args (DAppT t1 t2) = do@@ -66,94 +68,124 @@ go (t2' : args) t1 go args (DSigT ty ki) = do ty' <- go [] ty- return $ foldl DAppT (DSigT ty' ki) args+ ki' <- go [] ki+ finish (DSigT ty' ki') args go args (DConT n) = expand_con ign n args- go args ty = return $ foldl DAppT ty args+ go args ty@(DVarT _) = finish ty args+ go args ty@DArrowT = finish ty args+ go args ty@(DLitT _) = finish ty args+ go args ty@DWildCardT = finish ty args + finish :: DType -> [DType] -> q DType+ finish ty args = return $ applyDType ty args+ -- | Expands all type synonyms in a desugared predicate.-expand_pred :: DsMonad q => IgnoreKinds -> DPred -> q DPred+expand_pred :: forall q. DsMonad q => IgnoreKinds -> DPred -> q DPred expand_pred ign = go [] where+ go :: [DType] -> DPred -> q DPred+ go [] (DForallPr tvbs cxt p) =+ DForallPr tvbs <$> mapM (go []) cxt <*> expand_pred ign p+ go _ (DForallPr {}) =+ impossible "A quantified constraint is applied to another constraint." go args (DAppPr p t) = do t' <- expand_type ign t go (t' : args) p go args (DSigPr p k) = do p' <- go [] p- return $ foldl DAppPr (DSigPr p' k) args+ k' <- expand_type ign k+ finish (DSigPr p' k') args go args (DConPr n) = do ty <- expand_con ign n args dTypeToDPred ty- go args p = return $ foldl DAppPr p args+ go args p@(DVarPr _) = finish p args+ go args p@DWildCardPr = finish p args + finish :: DPred -> [DType] -> q DPred+ finish p args = return $ foldl DAppPr p args+ -- | Expand a constructor with given arguments-expand_con :: DsMonad q+expand_con :: forall q.+ DsMonad q => IgnoreKinds -> Name -- ^ Tycon name -> [DType] -- ^ Arguments -> q DType -- ^ Expanded type expand_con ign n args = do info <- reifyWithLocals n- dinfo <- dsInfo info- args_ok <- allM no_tyvars_tyfams args- case dinfo of- DTyConI (DTySynD _n tvbs rhs) _- | length args >= length tvbs -- this should always be true!- -> do- let (syn_args, rest_args) = splitAtList tvbs args- ty <- substTy (M.fromList $ zip (map extractDTvbName tvbs) syn_args) rhs- ty' <- expand_type ign ty- return $ foldl DAppT ty' rest_args+ case info of+ TyConI (TySynD _ _ StarT)+ -- See Note [Don't expand synonyms for *]+ -> return $ applyDType (DConT typeKindName) args+ _ -> go info+ where+ go :: Info -> q DType+ go info = do+ dinfo <- dsInfo info+ args_ok <- allM no_tyvars_tyfams args+ case dinfo of+ DTyConI (DTySynD _n tvbs rhs) _+ | length args >= length tvbs -- this should always be true!+ -> do+ let (syn_args, rest_args) = splitAtList tvbs args+ ty <- substTy (M.fromList $ zip (map extractDTvbName tvbs) syn_args) rhs+ ty' <- expand_type ign ty+ return $ applyDType ty' rest_args - DTyConI (DOpenTypeFamilyD (DTypeFamilyHead _n tvbs _frs _ann)) _- | length args >= length tvbs -- this should always be true!+ DTyConI (DOpenTypeFamilyD (DTypeFamilyHead _n tvbs _frs _ann)) _+ | length args >= length tvbs -- this should always be true! #if __GLASGOW_HASKELL__ < 709- , args_ok+ , args_ok #endif- -> do- let (syn_args, rest_args) = splitAtList tvbs args- -- We need to get the correct instance. If we fail to reify anything- -- (e.g., if a type family is quasiquoted), then fall back by- -- pretending that there are no instances in scope.- insts <- qRecover (return []) $- qReifyInstances n (map typeToTH syn_args)- dinsts <- dsDecs insts- case dinsts of- [DTySynInstD _n (DTySynEqn lhs rhs)] -> do- subst <-- expectJustM "Impossible: reification returned a bogus instance" $- unionMaybeSubsts $ zipWith (matchTy ign) lhs syn_args- ty <- substTy subst rhs- ty' <- expand_type ign ty- return $ foldl DAppT ty' rest_args- _ -> return $ foldl DAppT (DConT n) args+ -> do+ let (syn_args, rest_args) = splitAtList tvbs args+ -- We need to get the correct instance. If we fail to reify anything+ -- (e.g., if a type family is quasiquoted), then fall back by+ -- pretending that there are no instances in scope.+ insts <- qRecover (return []) $+ qReifyInstances n (map typeToTH syn_args)+ dinsts <- dsDecs insts+ case dinsts of+ [DTySynInstD _n (DTySynEqn lhs rhs)]+ | Just subst <-+ unionMaybeSubsts $ zipWith (matchTy ign) lhs syn_args+ -> do ty <- substTy subst rhs+ ty' <- expand_type ign ty+ return $ applyDType ty' rest_args+ _ -> give_up - DTyConI (DClosedTypeFamilyD (DTypeFamilyHead _n tvbs _frs _ann) eqns) _- | length args >= length tvbs- , args_ok- -> do- let (syn_args, rest_args) = splitAtList tvbs args- rhss <- mapMaybeM (check_eqn syn_args) eqns- case rhss of- (rhs : _) -> do- rhs' <- expand_type ign rhs- return $ foldl DAppT rhs' rest_args- [] -> return $ foldl DAppT (DConT n) args+ DTyConI (DClosedTypeFamilyD (DTypeFamilyHead _n tvbs _frs _ann) eqns) _+ | length args >= length tvbs+ , args_ok+ -> do+ let (syn_args, rest_args) = splitAtList tvbs args+ rhss <- mapMaybeM (check_eqn syn_args) eqns+ case rhss of+ (rhs : _) -> do+ rhs' <- expand_type ign rhs+ return $ applyDType rhs' rest_args+ [] -> give_up - where- -- returns the substed rhs- check_eqn :: DsMonad q => [DType] -> DTySynEqn -> q (Maybe DType)- check_eqn arg_tys (DTySynEqn lhs rhs) = do- let m_subst = unionMaybeSubsts $ zipWith (matchTy ign) lhs arg_tys- T.mapM (flip substTy rhs) m_subst+ where+ -- returns the substed rhs+ check_eqn :: [DType] -> DTySynEqn -> q (Maybe DType)+ check_eqn arg_tys (DTySynEqn lhs rhs) = do+ let m_subst = unionMaybeSubsts $ zipWith (matchTy ign) lhs arg_tys+ T.mapM (flip substTy rhs) m_subst - _ -> return $ foldl DAppT (DConT n) args+ _ -> give_up - where- no_tyvars_tyfams :: (DsMonad q, Data a) => a -> q Bool+ -- Used when we can't proceed with type family instance expansion any more,+ -- and must conservatively return the orignal type family applied to its+ -- arguments.+ give_up :: q DType+ give_up = return $ applyDType (DConT n) args++ no_tyvars_tyfams :: Data a => a -> q Bool no_tyvars_tyfams = everything (liftM2 (&&)) (mkQ (return True) no_tyvar_tyfam) - no_tyvar_tyfam :: DsMonad q => DType -> q Bool+ no_tyvar_tyfam :: DType -> q Bool no_tyvar_tyfam (DVarT _) = return False no_tyvar_tyfam (DConT con_name) = do m_info <- dsReify con_name@@ -167,6 +199,25 @@ allM :: Monad m => (a -> m Bool) -> [a] -> m Bool allM f = foldM (\b x -> (b &&) `liftM` f x) True++{-+Note [Don't expand synonyms for *]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We deliberately avoid expanding type synonyms for * such as Type and ★.+Why? If you reify any such type synonym using Template Haskell, this is+what you'll get:++ TyConI (TySynD <type synonym name> [] StarT)++If you blindly charge ahead and recursively inspect the right-hand side of+this type synonym, you'll desugar StarT into (DConT ''Type), reify ''Type,+and get back another type synonym with StarT as its right-hand side. Then+you'll recursively inspect StarT and find yourself knee-deep in an infinite+loop.++To prevent these sorts of shenanigans, we simply stop whenever we see a type+synonym with StarT as its right-hand side and return Type.+-} -- | Extract the name from a @TyVarBndr@ extractDTvbName :: DTyVarBndr -> Name
Language/Haskell/TH/Desugar/Lift.hs view
@@ -3,7 +3,7 @@ -- Module : Language.Haskell.TH.Desugar.Lift -- Copyright : (C) 2014 Richard Eisenberg -- License : BSD-style (see LICENSE)--- Maintainer : Richard Eisenberg (rae@cs.brynmawr.edu)+-- Maintainer : Ryan Scott -- Stability : experimental -- Portability : non-portable --@@ -26,7 +26,7 @@ $(deriveLiftMany [ ''DExp, ''DPat, ''DType, ''DPred, ''DTyVarBndr , ''DMatch, ''DClause, ''DLetDec, ''DDec, ''DDerivClause, ''DCon , ''DConFields, ''DForeign, ''DPragma, ''DRuleBndr, ''DTySynEqn- , ''DPatSynDir , ''NewOrData+ , ''DPatSynDir , ''NewOrData, ''DDerivStrategy #if __GLASGOW_HASKELL__ < 707 , ''AnnTarget, ''Role #endif@@ -36,6 +36,6 @@ , ''SourceStrictness, ''Overlap #endif #if __GLASGOW_HASKELL__ < 801- , ''DerivStrategy, ''PatSynArgs+ , ''PatSynArgs #endif ])
Language/Haskell/TH/Desugar/Match.hs view
@@ -32,6 +32,7 @@ import Language.Haskell.TH.Instances () import Language.Haskell.TH.Syntax +import Language.Haskell.TH.Desugar.AST import Language.Haskell.TH.Desugar.Core import Language.Haskell.TH.Desugar.Util import Language.Haskell.TH.Desugar.Reify@@ -330,9 +331,9 @@ Just (DTyConI tycon_dec _) <- dsReify ty_name return $ S.fromList $ map get_con_name $ get_cons tycon_dec - get_cons (DDataD _ _ _ _ cons _) = cons- get_cons (DDataInstD _ _ _ _ cons _) = cons- get_cons _ = []+ get_cons (DDataD _ _ _ _ _ cons _) = cons+ get_cons (DDataInstD _ _ _ _ _ cons _) = cons+ get_cons _ = [] get_con_name (DCon _ _ n _ _) = n
Language/Haskell/TH/Desugar/Reify.hs view
@@ -44,6 +44,7 @@ import qualified Control.Monad as Fail #endif +import Language.Haskell.TH.ExpandSyns ( expandSyns ) import Language.Haskell.TH.Instances () import Language.Haskell.TH.Syntax hiding ( lift ) @@ -92,33 +93,40 @@ --------------------------------- -- | Extract the @TyVarBndr@s and constructors given the @Name@ of a type-getDataD :: Quasi q+getDataD :: DsMonad q => String -- ^ Print this out on failure -> Name -- ^ Name of the datatype (@data@ or @newtype@) of interest -> q ([TyVarBndr], [Con]) getDataD err name = do- info <- reifyWithWarning name+ info <- reifyWithLocals name dec <- case info of TyConI dec -> return dec _ -> badDeclaration case dec of #if __GLASGOW_HASKELL__ > 710- DataD _cxt _name tvbs _mk cons _derivings -> return (tvbs, cons)- NewtypeD _cxt _name tvbs _mk con _derivings -> return (tvbs, [con])+ DataD _cxt _name tvbs mk cons _derivings -> go tvbs mk cons+ NewtypeD _cxt _name tvbs mk con _derivings -> go tvbs mk [con] #else- DataD _cxt _name tvbs cons _derivings -> return (tvbs, cons)- NewtypeD _cxt _name tvbs con _derivings -> return (tvbs, [con])+ DataD _cxt _name tvbs cons _derivings -> go tvbs Nothing cons+ NewtypeD _cxt _name tvbs con _derivings -> go tvbs Nothing [con] #endif _ -> badDeclaration- where badDeclaration =+ where+ go tvbs mk cons = do+ k <- maybe (pure (ConT typeKindName)) (runQ . expandSyns) mk+ extra_tvbs <- mkExtraKindBindersGeneric unravelType KindedTV k+ let all_tvbs = tvbs ++ extra_tvbs+ return (all_tvbs, cons)++ badDeclaration = fail $ "The name (" ++ (show name) ++ ") refers to something " ++ "other than a datatype. " ++ err -- | From the name of a data constructor, retrive the datatype definition it -- is a part of.-dataConNameToDataName :: Quasi q => Name -> q Name+dataConNameToDataName :: DsMonad q => Name -> q Name dataConNameToDataName con_name = do- info <- reifyWithWarning con_name+ info <- reifyWithLocals con_name case info of #if __GLASGOW_HASKELL__ > 710 DataConI _name _type parent_name -> return parent_name@@ -129,7 +137,7 @@ "a data constructor." -- | From the name of a data constructor, retrieve its definition as a @Con@-dataConNameToCon :: Quasi q => Name -> q Con+dataConNameToCon :: DsMonad q => Name -> q Con dataConNameToCon con_name = do -- we need to get the field ordering from the constructor. We must reify -- the constructor to get the tycon, and then reify the tycon to get the `Con`s
Language/Haskell/TH/Desugar/Subst.hs view
@@ -5,7 +5,7 @@ -- Module : Language.Haskell.TH.Desugar.Subst -- Copyright : (C) 2018 Richard Eisenberg -- License : BSD-style (see LICENSE)--- Maintainer : Richard Eisenberg (rae@cs.brynmawr.edu)+-- Maintainer : Ryan Scott -- Stability : experimental -- Portability : non-portable --@@ -17,7 +17,7 @@ DSubst, -- * Capture-avoiding substitution- substTy, unionSubsts, unionMaybeSubsts,+ substTy, substTyVarBndrs, unionSubsts, unionMaybeSubsts, -- * Matching a type template against a type IgnoreKinds(..), matchTy@@ -29,6 +29,7 @@ import Data.Generics import Data.List +import Language.Haskell.TH.Desugar.AST import Language.Haskell.TH.Desugar.Core import Language.Haskell.TH.Syntax import Language.Haskell.TH.Desugar.Util@@ -56,11 +57,14 @@ = return ty | otherwise = return $ DVarT n-substTy _ ty = return ty+substTy _ ty@(DConT _) = return ty+substTy _ ty@DArrowT = return ty+substTy _ ty@(DLitT _) = return ty+substTy _ ty@DWildCardT = return ty substTyVarBndrs :: Quasi q => DSubst -> [DTyVarBndr]- -> (DSubst -> [DTyVarBndr] -> q DType)- -> q DType+ -> (DSubst -> [DTyVarBndr] -> q a)+ -> q a substTyVarBndrs vars tvbs thing = do (vars', tvbs') <- mapAccumLM substTvb vars tvbs thing vars' tvbs'@@ -76,6 +80,11 @@ return (M.insert n (DVarT new_n) vars, DKindedTV new_n k') substPred :: Quasi q => DSubst -> DPred -> q DPred+substPred vars (DForallPr tvbs cxt p) =+ substTyVarBndrs vars tvbs $ \vars' tvbs' -> do+ cxt' <- mapM (substPred vars') cxt+ p' <- substPred vars' p+ return $ DForallPr tvbs' cxt' p' substPred vars (DAppPr p t) = DAppPr <$> substPred vars p <*> substTy vars t substPred vars (DSigPr p k) = DSigPr <$> substPred vars p <*> substTy vars k substPred vars (DVarPr n)@@ -83,7 +92,8 @@ = dTypeToDPred ty | otherwise = return $ DVarPr n-substPred _ p = return p+substPred _ p@(DConPr {}) = return p+substPred _ p@DWildCardPr = return p -- | Computes the union of two substitutions. Fails if both subsitutions map -- the same variable to different types.
Language/Haskell/TH/Desugar/Sweeten.hs view
@@ -14,7 +14,7 @@ -- Module : Language.Haskell.TH.Desugar.Sweeten -- Copyright : (C) 2014 Richard Eisenberg -- License : BSD-style (see LICENSE)--- Maintainer : Richard Eisenberg (rae@cs.brynmawr.edu)+-- Maintainer : Ryan Scott -- Stability : experimental -- Portability : non-portable --@@ -39,7 +39,7 @@ import Language.Haskell.TH hiding (cxt) -import Language.Haskell.TH.Desugar.Core+import Language.Haskell.TH.Desugar.AST import Language.Haskell.TH.Desugar.Util import Data.Maybe ( maybeToList, mapMaybe )@@ -85,17 +85,17 @@ -- a one-to-one mapping between 'DDec' and @Dec@. decToTH :: DDec -> [Dec] decToTH (DLetDec d) = maybeToList (letDecToTH d)-decToTH (DDataD Data cxt n tvbs cons derivings) =+decToTH (DDataD Data cxt n tvbs _mk cons derivings) = #if __GLASGOW_HASKELL__ > 710- [DataD (cxtToTH cxt) n (map tvbToTH tvbs) Nothing (map conToTH cons)+ [DataD (cxtToTH cxt) n (map tvbToTH tvbs) (fmap typeToTH _mk) (map conToTH cons) (concatMap derivClauseToTH derivings)] #else [DataD (cxtToTH cxt) n (map tvbToTH tvbs) (map conToTH cons) (map derivingToTH derivings)] #endif-decToTH (DDataD Newtype cxt n tvbs [con] derivings) =+decToTH (DDataD Newtype cxt n tvbs _mk [con] derivings) = #if __GLASGOW_HASKELL__ > 710- [NewtypeD (cxtToTH cxt) n (map tvbToTH tvbs) Nothing (conToTH con)+ [NewtypeD (cxtToTH cxt) n (map tvbToTH tvbs) (fmap typeToTH _mk) (conToTH con) (concatMap derivClauseToTH derivings)] #else [NewtypeD (cxtToTH cxt) n (map tvbToTH tvbs) (conToTH con)@@ -119,23 +119,23 @@ decToTH (DOpenTypeFamilyD (DTypeFamilyHead n tvbs frs _ann)) = [FamilyD TypeFam n (map tvbToTH tvbs) (frsToTH frs)] #endif-decToTH (DDataFamilyD n tvbs) =+decToTH (DDataFamilyD n tvbs mk) = #if __GLASGOW_HASKELL__ > 710- [DataFamilyD n (map tvbToTH tvbs) Nothing]+ [DataFamilyD n (map tvbToTH tvbs) (fmap typeToTH mk)] #else- [FamilyD DataFam n (map tvbToTH tvbs) Nothing]+ [FamilyD DataFam n (map tvbToTH tvbs) (fmap typeToTH mk)] #endif-decToTH (DDataInstD Data cxt n tys cons derivings) =+decToTH (DDataInstD Data cxt n tys _mk cons derivings) = #if __GLASGOW_HASKELL__ > 710- [DataInstD (cxtToTH cxt) n (map typeToTH tys) Nothing (map conToTH cons)+ [DataInstD (cxtToTH cxt) n (map typeToTH tys) (fmap typeToTH _mk) (map conToTH cons) (concatMap derivClauseToTH derivings)] #else [DataInstD (cxtToTH cxt) n (map typeToTH tys) (map conToTH cons) (map derivingToTH derivings)] #endif-decToTH (DDataInstD Newtype cxt n tys [con] derivings) =+decToTH (DDataInstD Newtype cxt n tys _mk [con] derivings) = #if __GLASGOW_HASKELL__ > 710- [NewtypeInstD (cxtToTH cxt) n (map typeToTH tys) Nothing (conToTH con)+ [NewtypeInstD (cxtToTH cxt) n (map typeToTH tys) (fmap typeToTH _mk) (conToTH con) (concatMap derivClauseToTH derivings)] #else [NewtypeInstD (cxtToTH cxt) n (map typeToTH tys) (conToTH con)@@ -169,7 +169,7 @@ decToTH (DStandaloneDerivD _mds cxt ty) = [StandaloneDerivD #if __GLASGOW_HASKELL__ >= 801- _mds+ (fmap derivStrategyToTH _mds) #endif (cxtToTH cxt) (typeToTH ty)] decToTH (DDefaultSigD n ty) = [DefaultSigD n (typeToTH ty)]@@ -217,35 +217,70 @@ conToTH :: DCon -> Con #if __GLASGOW_HASKELL__ > 710-conToTH (DCon [] [] n (DNormalC _ stys) (Just rty)) =+conToTH (DCon [] [] n (DNormalC _ stys) rty) = GadtC [n] (map (second typeToTH) stys) (typeToTH rty)-conToTH (DCon [] [] n (DRecC vstys) (Just rty)) =+conToTH (DCon [] [] n (DRecC vstys) rty) = RecGadtC [n] (map (thirdOf3 typeToTH) vstys) (typeToTH rty)-#endif-conToTH (DCon [] [] n (DNormalC True [sty1, sty2]) _) =-#if __GLASGOW_HASKELL__ > 710- InfixC (second typeToTH sty1) n (second typeToTH sty2) #else+conToTH (DCon [] [] n (DNormalC True [sty1, sty2]) _) = InfixC ((bangToStrict *** typeToTH) sty1) n ((bangToStrict *** typeToTH) sty2)-#endif -- Note: it's possible that someone could pass in a DNormalC value that -- erroneously claims that it's declared infix (e.g., if has more than two -- fields), but we will fall back on NormalC in such a scenario. conToTH (DCon [] [] n (DNormalC _ stys) _) =-#if __GLASGOW_HASKELL__ > 710- NormalC n (map (second typeToTH) stys)-#else NormalC n (map (bangToStrict *** typeToTH) stys)-#endif conToTH (DCon [] [] n (DRecC vstys) _) =-#if __GLASGOW_HASKELL__ > 710- RecC n (map (thirdOf3 typeToTH) vstys)-#else RecC n (map (\(v,b,t) -> (v,bangToStrict b,typeToTH t)) vstys) #endif+#if __GLASGOW_HASKELL__ > 710+-- On GHC 8.0 or later, we sweeten every constructor to GADT syntax, so it is+-- perfectly OK to put all of the quantified type variables+-- (both universal and existential) in a ForallC. conToTH (DCon tvbs cxt n fields rty) = ForallC (map tvbToTH tvbs) (cxtToTH cxt) (conToTH $ DCon [] [] n fields rty)+#else+-- On GHCs earlier than 8.0, we must be careful, since the only time ForallC is+-- used is when there are either:+--+-- 1. Any existentially quantified type variables+-- 2. A constructor context+--+-- If neither of these conditions hold, then we needn't put a ForallC at the+-- front, since it would be completely pointless (you'd end up with things like+-- @data Foo = forall. MkFoo@!).+conToTH (DCon tvbs cxt n fields rty)+ | null ex_tvbs && null cxt+ = con'+ | otherwise+ = ForallC ex_tvbs (cxtToTH cxt) con'+ where+ -- Fortunately, on old GHCs, it's especially easy to distinguish between+ -- universally and existentially quantified type variables. When desugaring+ -- a ForallC, we just stick all of the universals (from the datatype+ -- definition) at the front of the @forall@. Therefore, it suffices to+ -- count the number of type variables in the return type and drop that many+ -- variables from the @forall@ in the ForallC, leaving only the+ -- existentials.+ ex_tvbs :: [TyVarBndr]+ ex_tvbs = map tvbToTH $ drop num_univ_tvs tvbs + num_univ_tvs :: Int+ num_univ_tvs = go rty+ where+ go :: DType -> Int+ go (DForallT {}) = error "`forall` type used in GADT return type"+ go (DAppT t1 t2) = go t1 + go t2+ go (DSigT t _) = go t+ go (DVarT {}) = 1+ go (DConT {}) = 0+ go DArrowT = 0+ go (DLitT {}) = 0+ go DWildCardT = 0++ con' :: Con+ con' = conToTH $ DCon [] [] n fields rty+#endif+ foreignToTH :: DForeign -> Foreign foreignToTH (DImportF cc safety str n ty) = ImportF cc safety str n (typeToTH ty)@@ -305,7 +340,6 @@ #else typeToTH DWildCardT = error "Wildcards supported only in GHC 8.0+" #endif-typeToTH DStarT = StarT tvbToTH :: DTyVarBndr -> TyVarBndr tvbToTH (DPlainTV n) = PlainTV n@@ -316,13 +350,26 @@ #if __GLASGOW_HASKELL__ >= 801 derivClauseToTH :: DDerivClause -> [DerivClause]-derivClauseToTH (DDerivClause mds cxt) = [DerivClause mds (cxtToTH cxt)]+derivClauseToTH (DDerivClause mds cxt) =+ [DerivClause (fmap derivStrategyToTH mds) (cxtToTH cxt)] #else derivClauseToTH :: DDerivClause -> Cxt derivClauseToTH (DDerivClause _ cxt) = cxtToTH cxt #endif #if __GLASGOW_HASKELL__ >= 801+derivStrategyToTH :: DDerivStrategy -> DerivStrategy+derivStrategyToTH DStockStrategy = StockStrategy+derivStrategyToTH DAnyclassStrategy = AnyclassStrategy+derivStrategyToTH DNewtypeStrategy = NewtypeStrategy+#if __GLASGOW_HASKELL__ >= 805+derivStrategyToTH (DViaStrategy ty) = ViaStrategy (typeToTH ty)+#else+derivStrategyToTH (DViaStrategy _) = error "DerivingVia supported only in GHC 8.6+"+#endif+#endif++#if __GLASGOW_HASKELL__ >= 801 patSynDirToTH :: DPatSynDir -> PatSynDir patSynDirToTH DUnidir = Unidir patSynDirToTH DImplBidir = ImplBidir@@ -345,6 +392,8 @@ = ClassP n acc go _ DWildCardPr = error "Wildcards supported only in GHC 8.0+"+ go _ (DForallPr {})+ = error "Quantified constraints supported only in GHC 8.6+" #else predToTH (DAppPr p t) = AppT (predToTH p) (typeToTH t) predToTH (DSigPr p k) = SigT (predToTH p) (typeToTH k)@@ -355,20 +404,36 @@ #else predToTH DWildCardPr = error "Wildcards supported only in GHC 8.0+" #endif+#if __GLASGOW_HASKELL__ >= 805+predToTH (DForallPr tvbs cxt p) =+ ForallT (map tvbToTH tvbs) (map predToTH cxt) (predToTH p)+#else+predToTH (DForallPr {}) = error "Quantified constraints supported only in GHC 8.6+" #endif+#endif tyconToTH :: Name -> Type tyconToTH n+ | n == ''(->) = ArrowT -- Work around Trac #14888 | n == ''[] = ListT #if __GLASGOW_HASKELL__ >= 709 | n == ''(~) = EqualityT #endif | n == '[] = PromotedNilT | n == '(:) = PromotedConsT- | Just deg <- tupleNameDegree_maybe n = if isDataName n- then PromotedTupleT deg- else TupleT deg+ | Just deg <- tupleNameDegree_maybe n+ = if isDataName n+#if __GLASGOW_HASKELL__ >= 805+ then PromotedTupleT deg+#else+ then PromotedT n -- Work around Trac #14843+#endif+ else TupleT deg | Just deg <- unboxedTupleNameDegree_maybe n = UnboxedTupleT deg+#if __GLASGOW_HASKELL__ == 706+ -- Work around Trac #7667+ | isTypeKindName n = StarT+#endif #if __GLASGOW_HASKELL__ >= 801 | Just deg <- unboxedSumNameDegree_maybe n = UnboxedSumT deg #endif
Language/Haskell/TH/Desugar/Util.hs view
@@ -8,6 +8,10 @@ {-# LANGUAGE CPP, TupleSections #-} +#if __GLASGOW_HASKELL__ >= 800+{-# LANGUAGE TemplateHaskellQuotes #-}+#endif+ module Language.Haskell.TH.Desugar.Util ( newUniqueName, impossible,@@ -21,7 +25,9 @@ unboxedSumDegree_maybe, unboxedSumNameDegree_maybe, tupleDegree_maybe, tupleNameDegree_maybe, unboxedTupleDegree_maybe, unboxedTupleNameDegree_maybe, splitTuple_maybe,- topEverywhereM, isInfixDataCon+ topEverywhereM, isInfixDataCon,+ isTypeKindName, typeKindName,+ mkExtraKindBindersGeneric, unravelType ) where import Prelude hiding (mapM, foldl, concatMap, any)@@ -29,12 +35,17 @@ import Language.Haskell.TH hiding ( cxt ) import Language.Haskell.TH.Syntax +import Control.Monad ( replicateM ) import qualified Data.Set as S import Data.Foldable import Data.Generics hiding ( Fixity ) import Data.Traversable import Data.Maybe +#if __GLASGOW_HASKELL__ >= 800+import qualified Data.Kind as Kind+#endif+ #if __GLASGOW_HASKELL__ < 804 import Data.Monoid #endif@@ -176,6 +187,29 @@ = Just args go _ _ = Nothing +-- | Like 'mkExtraDKindBinders', but parameterized to allow working over both+-- 'Kind'/'TyVarBndr' and 'DKind'/'DTyVarBndr'.+mkExtraKindBindersGeneric+ :: Quasi q+ => (kind -> ([tyVarBndr], [pred], [kind], kind))+ -> (Name -> kind -> tyVarBndr)+ -> kind -> q [tyVarBndr]+mkExtraKindBindersGeneric unravel mkKindedTV k = do+ let (_, _, args, _) = unravel k+ names <- replicateM (length args) (qNewName "a")+ return (zipWith mkKindedTV names args)++-- | Decompose a function 'Type' into its type variables, its context, its+-- argument types, and its result type.+unravelType :: Type -> ([TyVarBndr], [Pred], [Type], Type)+unravelType (ForallT tvbs cxt ty) =+ let (tvbs', cxt', tys, res) = unravelType ty in+ (tvbs ++ tvbs', cxt ++ cxt', tys, res)+unravelType (AppT (AppT ArrowT t1) t2) =+ let (tvbs, cxt, tys, res) = unravelType t2 in+ (tvbs, cxt, t1 : tys, res)+unravelType t = ([], [], [], t)+ ---------------------------------------- -- Free names, etc. ----------------------------------------@@ -319,3 +353,44 @@ isInfixDataCon :: String -> Bool isInfixDataCon (':':_) = True isInfixDataCon _ = False++-- | Returns 'True' if the argument 'Name' is that of 'Kind.Type'+-- (or @*@ or 'Kind.★', to support older GHCs).+isTypeKindName :: Name -> Bool+isTypeKindName n = n == typeKindName+#if __GLASGOW_HASKELL__ < 805+ || n == starKindName+ || n == uniStarKindName+#endif++-- | The 'Name' of:+--+-- 1. The kind 'Kind.Type', on GHC 8.0 or later.+-- 2. The kind @*@ on older GHCs.+typeKindName :: Name+#if __GLASGOW_HASKELL__ >= 800+typeKindName = ''Kind.Type+#else+typeKindName = starKindName+#endif++#if __GLASGOW_HASKELL__ < 805+-- | The 'Name' of the kind @*@.+starKindName :: Name+#if __GLASGOW_HASKELL__ >= 800+starKindName = ''(Kind.*)+#else+starKindName = mkNameG_tc "ghc-prim" "GHC.Prim" "*"+#endif++-- | The 'Name' of:+--+-- 1. The kind 'Kind.★', on GHC 8.0 or later.+-- 2. The kind @*@ on older GHCs.+uniStarKindName :: Name+#if __GLASGOW_HASKELL__ >= 800+uniStarKindName = ''(Kind.★)+#else+uniStarKindName = starKindName+#endif+#endif
Test/DsDec.hs view
@@ -75,7 +75,7 @@ #endif $(do decs <- S.rec_sel_test- [DDataD nd [] name [DPlainTV tvbName] cons []] <- dsDecs decs+ [DDataD nd [] name [DPlainTV tvbName] k cons []] <- dsDecs decs let arg_ty = (DConT name) `DAppT` (DVarT tvbName) recsels <- getRecordSelectors arg_ty cons let num_sels = length recsels `div` 2 -- ignore type sigs@@ -89,5 +89,5 @@ fields' = zip stricts types in DCon tvbs cxt con_name (DNormalC False fields') rty- plaindata = [DDataD nd [] name [DPlainTV tvbName] (map unrecord cons) []]+ plaindata = [DDataD nd [] name [DPlainTV tvbName] k (map unrecord cons) []] return (decsToTH plaindata ++ mapMaybe letDecToTH recsels))
Test/Run.hs view
@@ -20,6 +20,11 @@ {-# OPTIONS_GHC -Wno-partial-type-signatures -Wno-redundant-constraints #-} #endif +#if __GLASGOW_HASKELL__ >= 805+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE QuantifiedConstraints #-}+#endif+ module Main where import Prelude hiding ( exp )@@ -128,6 +133,10 @@ #if __GLASGOW_HASKELL__ >= 803 , "over_label" ~: $test46_overloaded_label @=? $(dsSplice test46_overloaded_label) #endif+ , "do_partial_match" ~: $test47_do_partial_match @=? $(dsSplice test47_do_partial_match)+#if __GLASGOW_HASKELL__ >= 805+ , "quantified_constraints" ~: $test48_quantified_constraints @=? $(dsSplice test48_quantified_constraints)+#endif ] test35a = $test35_expand@@ -201,11 +210,13 @@ dinfo@(DTyConI (DOpenTypeFamilyD (DTypeFamilyHead _name _tvbs (DKindSig resK) _ann)) (Just [DTySynInstD _name2 (DTySynEqn lhs _rhs)])) <- dsInfo info- case (resK, lhs) of+ let isTypeKind (DConT n) = isTypeKindName n+ isTypeKind _ = False+ case (isTypeKind resK, lhs) of #if __GLASGOW_HASKELL__ < 709- (DStarT, [DVarT _]) -> [| True |]+ (True, [DVarT _]) -> [| True |] #else- (DStarT, [DSigT (DVarT _) (DVarT _)]) -> [| True |]+ (True, [DSigT (DVarT _) (DVarT _)]) -> [| True |] #endif _ -> do runIO $ do@@ -249,11 +260,58 @@ (expandType orig_ty) orig_ty `eqTHSplice` exp_ty) +test_stuck_tyfam_expansion :: Bool+test_stuck_tyfam_expansion =+ $(do fam_name <- newName "F"+ x <- newName "x"+ k <- newName "k"+ let orig_ty = DConT fam_name `DAppT` DConT '() -- F '()+ exp_ty <- withLocalDeclarations+ (decsToTH [ -- type family F (x :: k) :: k+ DOpenTypeFamilyD+ (DTypeFamilyHead fam_name+ [DKindedTV x (DVarT k)]+ (DKindSig (DVarT k))+ Nothing)+ -- type instance F (x :: ()) = x+ , DTySynInstD fam_name+ (DTySynEqn [DSigT (DVarT x) (DConT ''())] (DVarT x))+ ])+ (expandType orig_ty)+ orig_ty `eqTHSplice` exp_ty)++test_t85 :: Bool+test_t85 =+ $(do let orig_ty =+ (DConT ''Constant `DAppT` DConT ''Int `DAppT` DConT 'True)+ `DSigT` (DConT ''Constant `DAppT` DConT ''Char `DAppT` DConT ''Bool)+ expected_ty = DConT 'True `DSigT` DConT ''Bool+ expanded_ty <- expandType orig_ty+ expected_ty `eqTHSplice` expanded_ty)++test_getDataD_kind_sig :: Bool+test_getDataD_kind_sig =+#if __GLASGOW_HASKELL__ >= 800+ 3 == $(do data_name <- newName "TestData"+ a <- newName "a"+ let type_kind = DConT typeKindName+ data_kind_sig = DArrowT `DAppT` type_kind `DAppT`+ (DArrowT `DAppT` type_kind `DAppT` type_kind)+ (tvbs, _) <- withLocalDeclarations+ (decToTH (DDataD Data [] data_name [DPlainTV a]+ (Just data_kind_sig) [] []))+ (getDataD "th-desugar: Impossible" data_name)+ [| $(Syn.lift (length tvbs)) |])+#else+ True -- DataD didn't have the ability to store kind signatures prior to GHC 8.0+#endif+ test_kind_substitution :: [Bool] test_kind_substitution = $(do a <- newName "a" b <- newName "b" c <- newName "c"+ k <- newName "k" let subst = M.singleton a (DVarT b) -- (Nothing :: Maybe a)@@ -262,19 +320,28 @@ ty2 = DForallT [DKindedTV c (DVarT a)] [] (DVarT c) -- forall a (c :: a). c ty3 = DForallT [DPlainTV a, DKindedTV c (DVarT a)] [] (DVarT c)+ -- forall (a :: k) k (b :: k). Proxy b -> Proxy a+ ty4 = DForallT [ DKindedTV a (DVarT k)+ , DPlainTV k+ , DKindedTV b (DVarT k)+ ] [] (DArrowT `DAppT` (DConT ''Proxy `DAppT` DVarT b)+ `DAppT` (DConT ''Proxy `DAppT` DVarT a)) substTy1 <- substTy subst ty1 substTy2 <- substTy subst ty2 substTy3 <- substTy subst ty3+ substTy4 <- substTy subst ty4 let freeVars1 = fvDType substTy1 freeVars2 = fvDType substTy2 freeVars3 = fvDType substTy3+ freeVars4 = fvDType substTy4 b1 = freeVars1 `eqTH` S.singleton b b2 = freeVars2 `eqTH` S.singleton b b3 = freeVars3 `eqTH` S.empty- [| [b1, b2, b3] |])+ b4 = freeVars4 `eqTH` S.singleton k+ [| [b1, b2, b3, b4] |]) test_lookup_value_type_names :: [Bool] test_lookup_value_type_names =@@ -394,6 +461,12 @@ it "works with deriving strategies" $ test_deriving_strategies it "doesn't expand local type families" $ test_local_tyfam_expansion++ it "doesn't crash on a stuck type family application" $ test_stuck_tyfam_expansion++ it "expands type synonyms in kinds" $ test_t85++ it "reifies data type return kinds accurately" $ test_getDataD_kind_sig -- Remove map pprints here after switch to th-orphans zipWithM (\t t' -> it ("can do Type->DType->Type of " ++ t) $ t == t')
Test/Splices.hs view
@@ -26,6 +26,11 @@ {-# OPTIONS_GHC -Wno-orphans #-} -- IsLabel is an orphan #endif +#if __GLASGOW_HASKELL__ >= 805+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE QuantifiedConstraints #-}+#endif+ {-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-type-defaults -fno-warn-name-shadowing #-} @@ -105,31 +110,9 @@ then [| True |] else [| False |] --- Note [Annotating list elements]------ Type annotations on list elements are needed to satisfy GHC 8.0-rc1, otherwise--- we get errors like:------ Test/Run.hs:63:53: error:--- • Couldn't match type ‘Maybe Integer’ with ‘forall a. Maybe a’--- Expected type: [forall a. Maybe a]--- Actual type: [Maybe Integer]--- • In the second argument of ‘(:)’, namely--- ‘(:) (Just 19) ((:) (Nothing :: Maybe Integer) [])’--- In the second argument of ‘(:)’, namely--- ‘(:) Nothing ((:) (Just 19) ((:) (Nothing :: Maybe Integer) []))’--- In the second argument of ‘map’, namely--- ‘(:)--- (Just 1)--- ((:) Nothing ((:) (Just 19) ((:) (Nothing :: Maybe Integer) [])))’------ This is probably a bug in the GHC type checker, but I haven't been able to--- reduce it yet- test1_sections = [| map ((* 3) . (4 +) . (\x -> x * x)) [10, 11, 12] |] test2_lampats = [| (\(Just x) (Left z) -> x + z) (Just 5) (Left 10) |]--- See Note [Annotating list elements]-test3_lamcase = [| foldr (-) 0 (map (\case { Just x -> x ; Nothing -> (-3) }) [Just 1, Nothing :: Maybe Integer, Just 19, Nothing :: Maybe Integer]) |]+test3_lamcase = [| foldr (-) 0 (map (\case { Just x -> x ; Nothing -> (-3) }) [Just 1, Nothing, Just 19, Nothing]) |] test4_tuples = [| (\(a, _) (# b, _ #) -> a + b) (1,2) (# 3, 4 #) |] test5_ifs = [| if (5 > 7) then "foo" else if | Nothing <- Just "bar", True -> "blargh" | otherwise -> "bum" |] test6_ifs2 = [| if | Nothing <- Nothing, False -> 3 | Just _ <- Just "foo" -> 5 |]@@ -163,8 +146,7 @@ deriving (Show, Eq) test17_infixp = [| map (\(x :+: y) -> if y then x + 1 else x - 1) [5 :+: True, 10 :+: False] |]--- See Note [Annotating list elements]-test18_tildep = [| map (\ ~() -> Nothing :: Maybe Int) [undefined :: (), ()] |]+test18_tildep = [| map (\ ~() -> Nothing :: Maybe Int) [undefined, ()] |] test19_bangp = [| map (\ !() -> 5) [()] |] test20_asp = [| map (\ a@(b :+: c) -> (if c then b + 1 else b - 1, a)) [5 :+: True, 10 :+: False] |] test21_wildp = [| zipWith (\_ _ -> 10) [1,2,3] ['a','b','c'] |]@@ -173,19 +155,16 @@ test23_sigp = [| map (\ (a :: Int) -> a + a) [5, 10] |] #endif --- See Note [Annotating list elements]-test24_fun = [| let f :: Maybe (Maybe a) -> Maybe a- f (Just x) = x+test24_fun = [| let f (Just x) = x f Nothing = Nothing in f (Just (Just 10)) |] --- See Note [Annotating list elements] test25_fun2 = [| let f (Just x) | x > 0 = x | x < 0 = x + 10 f Nothing = 0 f _ = 18 in- map f [Just (-5), Just 5, Just 10, Nothing :: Maybe Integer, Just 0] |]+ map f [Just (-5), Just 5, Just 10, Nothing, Just 0] |] test26_forall = [| let f :: Num a => a -> a f x = x + 10 in@@ -221,8 +200,8 @@ f = fst in f |] -type Const a b = b-test36_expand = [| let f :: Const Int (,) Bool Char -> Char+type Constant a b = b+test36_expand = [| let f :: Constant Int (,) Bool Char -> Char f = snd in f |] @@ -276,6 +255,15 @@ #x p - #y p |] #endif +test47_do_partial_match = [| do { Just () <- [Nothing]; return () } |]++#if __GLASGOW_HASKELL__ >= 805+test48_quantified_constraints =+ [| let f :: forall f a. (forall x. Eq x => Eq (f x), Eq a) => f a -> f a -> Bool+ f = (==)+ in f (Proxy @Int) (Proxy @Int) |]+#endif+ type family TFExpand x type instance TFExpand Int = Bool type instance TFExpand (Maybe a) = [a]@@ -338,14 +326,19 @@ dec_test_nums = [1..11] :: [Int] #endif -dectest1 = [d| data Dec1 = Foo | Bar Int |]-dectest2 = [d| data Dec2 a = forall b. (Show b, Eq a) => MkDec2 a b Bool |]-dectest3 = [d| data Dec3 a = forall b. MkDec3 { foo :: a, bar :: b }+dectest1 = [d| data Dec1 where+ Foo :: Dec1+ Bar :: Int -> Dec1 |]+dectest2 = [d| data Dec2 a where+ MkDec2 :: forall a b. (Show b, Eq a) => a -> b -> Bool -> Dec2 a |]+dectest3 = [d| data Dec3 a where+ MkDec3 :: forall a b. { foo :: a, bar :: b } -> Dec3 a #if __GLASGOW_HASKELL__ >= 707 type role Dec3 nominal #endif |]-dectest4 = [d| newtype Dec4 a = MkDec4 (a, Int) |]+dectest4 = [d| newtype Dec4 a where+ MkDec4 :: (a, Int) -> Dec4 a |] dectest5 = [d| type Dec5 a b = (a b, Maybe b) |] dectest6 = [d| class (Monad m1, Monad m2) => Dec6 (m1 :: * -> *) m2 | m1 -> m2 where lift :: forall a. m1 a -> m2 a@@ -353,16 +346,13 @@ dectest7 = [d| type family Dec7 a (b :: *) (c :: Bool) :: * -> * |] dectest8 = [d| type family Dec8 a |] dectest9 = [d| data family Dec9 a (b :: * -> *) :: * -> * |]- -- NB: dectest9 inexplicably fails when you don't recompile everything from- -- scratch. I (Richard) haven't explored why. The failure is benign (replacing the- -- decl above with one with three variables) so I'm not terribly bothered. #if __GLASGOW_HASKELL__ < 707 ds_dectest10 = DClosedTypeFamilyD (DTypeFamilyHead (mkName "Dec10") [DPlainTV (mkName "a")]- (DKindSig (DAppT (DAppT DArrowT DStarT) DStarT))+ (DKindSig (DAppT (DAppT DArrowT (DConT typeKindName)) (DConT typeKindName))) Nothing) [ DTySynEqn [DConT ''Int] (DConT ''Maybe) , DTySynEqn [DConT ''Bool] (DConT ''[]) ]@@ -421,8 +411,19 @@ type M2 Maybe = Either () |] data family Dec9 a (b :: * -> *) :: * -> *+#if __GLASGOW_HASKELL__ >= 800+imp_inst_test2 = [d| data instance Dec9 Int Maybe a where+ MkIMB :: [a] -> Dec9 Int Maybe a+ MkIMB2 :: forall a b. b a -> Dec9 Int Maybe a |]+imp_inst_test3 = [d| newtype instance Dec9 Bool m x where+ MkBMX :: m x -> Dec9 Bool m x |]+#else+-- TH-quoted data family instances with GADT syntax are horribly broken on GHC 7.10+-- and older, so we opt to use non-GADT syntax on older GHCs so we can at least+-- test *something*. imp_inst_test2 = [d| data instance Dec9 Int Maybe a = MkIMB [a] | forall b. MkIMB2 (b a) |] imp_inst_test3 = [d| newtype instance Dec9 Bool m x = MkBMX (m x) |]+#endif type family Dec8 a imp_inst_test4 = [d| type instance Dec8 Int = Bool |]@@ -511,6 +512,11 @@ r22 :: a -> a r22 = id -- test #32 + data R23 a = MkR23 { getR23 :: a }++ r23Test :: R23 a -> a+ r23Test (MkR23 { getR23 = x }) = x+ #if __GLASGOW_HASKELL__ >= 801 pattern Point :: Int -> Int -> (Int, Int) pattern Point{x, y} = (x, y)@@ -541,6 +547,14 @@ llEx :: [a] -> Int llEx LLMeth = 5+#endif++#if __GLASGOW_HASKELL__ >= 805+ newtype Id a = MkId a+ deriving stock Eq++ newtype R24 a = MkR24 [a]+ deriving Eq via (Id [a]) #endif |]
th-desugar.cabal view
@@ -1,20 +1,24 @@ name: th-desugar-version: 1.8+version: 1.9 cabal-version: >= 1.10 synopsis: Functions to desugar Template Haskell homepage: https://github.com/goldfirere/th-desugar category: Template Haskell author: Richard Eisenberg <rae@cs.brynmawr.edu>-maintainer: Richard Eisenberg <rae@cs.brynmawr.edu>, Ryan Scott <ryan.gl.scott@gmail.com>+maintainer: Ryan Scott <ryan.gl.scott@gmail.com> bug-reports: https://github.com/goldfirere/th-desugar/issues stability: experimental extra-source-files: README.md, CHANGES.md license: BSD3 license-file: LICENSE build-type: Simple-tested-with: GHC == 7.6.3, GHC == 7.8.2, GHC == 7.8.3, GHC == 7.8.4,- GHC == 7.10.1, GHC == 7.10.2, GHC == 7.10.3, GHC == 8.0.1,- GHC == 8.0.2, GHC == 8.2.1, GHC == 8.2.2, GHC == 8.4.1+tested-with: GHC == 7.6.3+ , GHC == 7.8.2, GHC == 7.8.3, GHC == 7.8.4+ , GHC == 7.10.1, GHC == 7.10.2, GHC == 7.10.3+ , GHC == 8.0.1, GHC == 8.0.2+ , GHC == 8.2.1, GHC == 8.2.2+ , GHC == 8.4.1, GHC == 8.4.2, GHC == 8.4.3+ , GHC == 8.6.1 description: This package provides the Language.Haskell.TH.Desugar module, which desugars Template Haskell's rich encoding of Haskell syntax into a simpler encoding.@@ -29,12 +33,17 @@ source-repository this type: git location: https://github.com/goldfirere/th-desugar.git- tag: v1.8+ tag: v1.9 +source-repository head+ type: git+ location: https://github.com/goldfirere/th-desugar.git+ branch: master+ library build-depends: base >= 4 && < 5,- template-haskell,+ template-haskell >= 2.8 && < 2.15, containers >= 0.5, mtl >= 2.1, syb >= 0.4,@@ -47,7 +56,8 @@ Language.Haskell.TH.Desugar.Lift, Language.Haskell.TH.Desugar.Expand, Language.Haskell.TH.Desugar.Subst- other-modules: Language.Haskell.TH.Desugar.Core,+ other-modules: Language.Haskell.TH.Desugar.AST,+ Language.Haskell.TH.Desugar.Core, Language.Haskell.TH.Desugar.Match, Language.Haskell.TH.Desugar.Util, Language.Haskell.TH.Desugar.Reify