th-desugar 1.14 → 1.19
raw patch · 23 files changed
Files
- CHANGES.md +232/−0
- Language/Haskell/TH/Desugar.hs +41/−17
- Language/Haskell/TH/Desugar/AST.hs +238/−38
- Language/Haskell/TH/Desugar/Core.hs +2434/−1963
- Language/Haskell/TH/Desugar/FV.hs +11/−8
- Language/Haskell/TH/Desugar/Lift.hs +4/−28
- Language/Haskell/TH/Desugar/Match.hs +158/−92
- Language/Haskell/TH/Desugar/Reify.hs +541/−117
- Language/Haskell/TH/Desugar/Subst.hs +34/−14
- Language/Haskell/TH/Desugar/Subst/Capturing.hs +77/−0
- Language/Haskell/TH/Desugar/Sweeten.hs +132/−7
- Language/Haskell/TH/Desugar/Util.hs +750/−41
- README.md +305/−0
- Test/Dec.hs +15/−0
- Test/DsDec.hs +20/−3
- Test/FakeSums.hs +14/−0
- Test/FakeTuples.hs +21/−0
- Test/ReifyTypeCUSKs.hs +3/−0
- Test/Run.hs +455/−11
- Test/Splices.hs +214/−14
- Test/T158Exp.hs +1/−0
- Test/T183.hs +32/−0
- th-desugar.cabal +19/−11
CHANGES.md view
@@ -1,6 +1,238 @@ `th-desugar` release notes ========================== +Version 1.19 [2026.01.10]+-------------------------+* Support GHC 9.14.+* Support specialising expressions in `SPECIALISE` pragmas. As part of these+ changes, a `DSpecialiseEP` data constructor has been added to `DPragma`, and+ the existing `DSpecialiseP` data constructor has been converted to a pattern+ synonym defined in terms of `DSpecialiseEP`.+* Add `mkTupleDType :: [DType] -> DType`, which offers functionality similar to+ the existing `mkTupleD{Exp,Pat}` functions, but for types instead of+ expressions or patterns.++Version 1.18 [2024.12.11]+-------------------------+* Support GHC 9.12.+* Add further support for embedded types in terms. The `DExp` type now has a+ `DForallE` data constructor (mirroring `ForallE` and `ForallVisE` in+ `template-haskell`) and a `DConstrainedE` data constructor (mirroring+ `ConstrainedE` in `template-haskell`).+* The `DLamE` and `DCaseE` data constructors (as well as the related+ `mkDLamEFromDPats` function) are now deprecated in favor of the new+ `DLamCasesE` data constructor. `DLamE`, `DCaseE`, and `mkDLamEFromDPats` will+ be removed in a future release of `th-desugar`, so users are encouraged to+ migrate. For more details on how to migrate your code, see [this+ document](https://github.com/goldfirere/th-desugar/blob/master/docs/LambdaCaseMigration.md).+* The type of the `dsMatches` function has changed:++ ```diff+ -dsMatches :: DsMonad q => Name -> [Match] -> q [DMatch]+ +dsMatches :: DsMonad q => MatchContext -> [Match] -> q [DMatch]+ ```++ In particular:++ * `dsMatches` function no longer includes a `Name` argument for the+ variable being scrutinized, as the new approach that `th-desugar` uses to+ desugar `Match`es no longer requires this.+ * `dsMatches` now requires a `MatchContext` argument, which+ determines what kind of "`Non-exhaustive patterns in ...`" error it raises+ when reaching a fallthrough case for non-exhaustive matches.+* Add a `maybeDCasesE :: MatchContext -> [DExp] -> [DClause] -> DExp` function.+ `maybeDCasesE` is similar to `maybeDCaseE` except that it matches on multiple+ expressions (using `\\cases`) instead of matching on a single expression.+* Add support for desugaring higher-order uses of embedded type patterns (e.g.,+ `\(type a) (x :: a) -> x :: a`) and invisible type patterns (e.g.,+ `\ @a (x :: a) -> x :: a`).+* Add a `Quote` instance for `DsM`.+* Add `mapDTVName` and `mapDTVKind` functions, which allow mapping over the+ `Name` and `DKind` of a `DTyVarBndr`, respectively.+* Export `substTyVarBndr` from `Language.Haskell.TH.Desugar.Subst`.+* Add a `Language.Haskell.TH.Desugar.Subst.Capturing` module. This exposes+ mostly the same API as `Language.Haskell.TH.Desugar.Subst`, except that the+ substitution functions in `Language.Haskell.TH.Desugar.Subst.Capturing` do+ not avoid capture when subtituting into a @forall@ type. As a result, these+ substitution functions are pure rather than monadic.+* Add `dMatchUpSAKWithDecl`, a function that matches up type variable binders+ from a standalone kind signature to the corresponding type variable binders+ in the type-level declaration's header:++ * The type signature for `dMatchUpSAKWithDecl` returns+ `[DTyVarBndr ForAllTyFlag]`, where `ForAllTyFlag` is a new data type that+ generalizes both `Specificity` and `BndrVis`.+ * Add `dtvbForAllTyFlagsToSpecs` and `dtvbForAllTyFlagsToBndrVis` functions,+ which allow converting the results of calling `dMatchUpSAKWithDecl` to+ `[DTyVarBndrSpec]` or `[DTyVarBndrVis]`, respectively.+ * Also add `matchUpSAKWithDecl`, `tvbForAllTyFlagsToSpecs`, and+ `tvbForAllTyFlagsToBndrVis` functions, which work over `TyVarBndr` instead+ of `DTyVarBndr`.+* Locally reifying the type of a data constructor or class method now yields+ type signatures with more precise type variable information, as `th-desugar`+ now incorporates information from the standalone kind signature (if any) for+ the parent data type or class, respectively. For instance, consider the+ following data type declaration:++ ```hs+ type P :: forall {k}. k -> Type+ data P (a :: k) = MkP+ ```++ In previous versions of `th-desugar`, locally reifying `MkP` would yield the+ following type:++ ```hs+ MkP :: forall k (a :: k). P a+ ```++ This was subtly wrong, as `k` is marked as specified (i.e., eligible for+ visible type application), not inferred. In `th-desugar-1.18`, however, the+ locally reified type will mark `k` as inferred, as expected:++ ```hs+ MkP :: forall {k} (a :: k). P a+ ```++ Similarly, desugaring `MkP` from Template Haskell to `th-desugar` results+ in a data constructor with the expected type above.+ * As a result of these changes, the type of `dsCon` has changed slightly:++ ```diff+ -dsCon :: DsMonad q => [DTyVarBndrUnit] -> DType -> Con -> q [DCon]+ +dsCon :: DsMonad q => [DTyVarBndrSpec] -> DType -> Con -> q [DCon]+ ```++Version 1.17 [2024.05.12]+-------------------------+* Support GHC 9.10.+* Add support namespace identifiers in fixity declarations. As part of these+ changes, the `DInfixD` data constructor now has a `NamespaceSpecifier` field.+* Add support for `SCC` declarations via the new `DSCCP` data constructor for+ the `DPragma` data type.+* Add partial support for embedded types in expressions (via the new `DTypeE`+ data constructor) and in patterns (via the new `DTypeP` data constructor).+ This is only partial support because the use of `DTypeP` is supported in the+ clauses of function declarations, but not in lambda expressions, `\case`+ expressions, or `\cases` expressions. See the "Known limitations" section of+ the `th-desugar` `README` for full details.+* Add partial support for invisible type patterns via the new `DInvisP` data+ constructor. Just like with `DTypeP`, `th-desugar` only supports the use of+ `DInvisP` in the clauses of function declarations. See the "Known limitations"+ section of the `th-desugar` `README` for full details.+* `extractBoundNamesDPat` no longer extracts type variables from constructor+ patterns. That this function ever did extract type variables was a mistake,+ and the new behavior of `extractBoundNamesDPat` brings it in line with the+ behavior `extractBoundNamesPat`.+* The `unboxedTupleNameDegree_maybe` function now returns:+ * `Just 0` when the argument is `''Unit#`+ * `Just 1` when the argument is `''Solo#`+ * `Just <N>` when the argument is `''Tuple<N>#`+ This is primarily motivated by the fact that with GHC 9.10 or later, `''(##)`+ is syntactic sugar for `''Unit#`, `''(#,#)` is syntactic sugar for `Tuple2#`,+ and so on.+* The `unboxedSumNameDegree_maybe` function now returns `Just n` when the+ argument is `Sum<N>#`. This is primarily motivated by the fact that with GHC+ 9.10 or later, `''(#|#)` is syntactic sugar for `Sum2#`, `''(#||#)` is+ syntactic sugar for `Sum3#`, and so on.+* Add `Foldable` and `Traversable` instances for `DTyVarBndrSpec`.++Version 1.16 [2023.10.13]+-------------------------+* Support GHC 9.8.+* Require `th-abstraction-0.6` or later.+* Add support for invisible binders in type-level declarations. As part of this+ change:++ * `Language.Haskell.TH.Desugar` now exports a `DTyVarBndrVis` type synonym,+ which is the `th-desugar` counterpart to `TyVarBndrVis`. It also exports a+ `dsTvbVis` function, which is the `DTyVarBndrVis` counterpart to `dsTvbSpec`+ and `dsTvbUnit`.+ * `Language.Haskell.TH.Desugar` now re-exports `BndrVis` from+ `template-haskell`.+ * The `DDataD`, `DTySynD`, `DClassD`, `DDataFamilyD`, and `DTypeFamilyHead`+ parts of the `th-desugar` AST now use `DTyVarBndrVis` instead of+ `DTyVarBndrUnit`.+ * The `mkExtraDKindBinders`, `dsCon`, and `dsDataDec` functions now use+ `DTyVarBndrVis` instead of `DTyVarBndrUnit`.+ * The `getDataD` function now uses `TyVarBndrVis` instead of `TyVarBndrUnit`.++ It is possible that you will need to convert between `TyVarBndrUnit` and+ `TyVarBndrVis` to adapt your existing `th-desugar` code. (Note that `TyVarBndr+ flag` is an instance of `Functor`, so this can be accomplished with `fmap`.)+* `Language.Haskell.TH.Desugar` now exports a family of functions for converting+ type variable binders into type arguments while preserving their visibility:++ * The `tyVarBndrVisToTypeArg` and `tyVarBndrVisToTypeArgWithSig` functions+ convert a `TyVarBndrVis` to a `TypeArg`. `tyVarBndrVisToTypeArg` omits kind+ signatures when converting `KindedTV`s, while `tyVarBndrVisToTypeArgWithSig`+ preserves kind signatures.+ * The `dTyVarBndrVisToDTypeArg` and `dTyVarBndrVisToDTypeArgWithSig` functions+ convert a `DTyVarBndrVis` to a `DTypeArg`. `dTyVarBndrVisToDTypeArg` omits+ kind signatures when converting `DKindedTV`s, while+ `dTyVarBndrVisToDTypeArgWithSig` preserves kind signatures.+* `th-desugar` now supports generating typed Template Haskell quotes and splices+ via the new `DTypedBracketE` and `DTypedSpliceE` constructors of `DExp`,+ respectively.+* The `lookupValueNameWithLocals` function will no longer reify field selectors+ when the `NoFieldSelectors` language extension is set, mirroring the behavior+ of the `lookupValueName` function in `template-haskell`. Note that this will+ only happen when using GHC 9.8 or later, as previous versions of GHC do not+ equip Template Haskell with enough information to conclude whether a value is+ a record field or not.+* The `tupleNameDegree_maybe` function now returns:+ * `Just 0` when the argument is `''Unit`+ * `Just 1` when the argument is `''Solo` or `'MkSolo`+ * `Just <N>` when the argument is `''Tuple<N>`+ This is primarily motivated by the fact that with GHC 9.8 or later, `''()` is+ syntactic sugar for `''Unit`, `''(,)` is syntactic sugar for `Tuple2`, and so+ on. We also include cases for `''Solo` and `'MkSolo` for the sake of+ completeness, even though they do not have any special syntactic sugar.+* The `tupleDegree_maybe`, `unboxedSumDegree_maybe`, and+ `unboxedTupleDegree_maybe` functions have been removed. Their only use sites+ were in the `tupleNameDegree_maybe`, `unboxedSumNameDegree_maybe`, and+ `unboxedTupleNameDegree_maybe` functions, respectively. Moreover,+ `tupleDegree_maybe`'s semantics were questionable, considering that it could+ potentially return `Just <N>` for a custom data type named `Tuple<N>`, even+ if the custom data type has no relation to the `Tuple<N>` types defined in+ `GHC.Tuple`.+* The `matchTy` function now looks through visible kind applications (i.e.,+ `DAppKindT`s) whenever `YesIgnoreKinds` is given.+* Fix a bug in which infix data family declaration would mistakenly be rejected+ when reified locally.+* Fix a bug in which data types that use visible dependent quantification would+ produce ill-scoped code when desugared.++Version 1.15 [2023.03.12]+-------------------------+* Support GHC 9.6.+* The `NewOrData` data type has been renamed to `DataFlavor` and extended to+ support `type data` declarations:++ ```diff+ -data NewOrData = NewType | Data+ +data DataFlavor = NewType | Data | TypeData+ ```++ Desugaring upholds the following properties regarding `TypeData`:++ * A `DDataD` with a `DataFlavor` of `TypeData` cannot have any deriving+ clauses or datatype contexts, and the `DConFields` in each `DCon` will be a+ `NormalC` where each `Bang` is equal to+ `Bang NoSourceUnpackedness NoSourceStrictness`.+ * A `DDataInstD` can have a `DataFlavor` of `NewType` or `Data`, but not+ `TypeData`.+* The type of `getDataD` has been changed to also include a `DataFlavor`:++ ```diff+ -getDataD :: DsMonad q => String -> Name -> q ([TyVarBndrUnit], [Con])+ +getDataD :: DsMonad q => String -> Name -> q (DataFlavor, [TyVarBndrUnit], [Con])+ ```+* Local reification can now reify the types of pattern synonym record+ selectors.+* Fix a bug in which the types of locally reified GADT record selectors would+ sometimes have type variables quantified in the wrong order.+ Version 1.14 [2022.08.23] ------------------------- * Support GHC 9.4.
Language/Haskell/TH/Desugar.hs view
@@ -6,7 +6,7 @@ {-# LANGUAGE CPP, MultiParamTypeClasses, FunctionalDependencies, TypeSynonymInstances, FlexibleInstances, LambdaCase,- ScopedTypeVariables #-}+ ScopedTypeVariables, PatternSynonyms #-} ----------------------------------------------------------------------------- -- |@@ -24,17 +24,26 @@ module Language.Haskell.TH.Desugar ( -- * Desugared data types- DExp(..), DLetDec(..), DPat(..),+ DExp(..), pattern DLamE, pattern DCaseE,+ DLetDec(..), NamespaceSpecifier(..), DPat(..), DType(..), DForallTelescope(..), DKind, DCxt, DPred, DTyVarBndr(..), DTyVarBndrSpec, DTyVarBndrUnit, Specificity(..),+ DTyVarBndrVis,+#if __GLASGOW_HASKELL__ >= 907+ BndrVis(..),+#else+ BndrVis,+ pattern BndrReq,+ pattern BndrInvis,+#endif DMatch(..), DClause(..), DDec(..), DDerivClause(..), DDerivStrategy(..), DPatSynDir(..), DPatSynType,- Overlap(..), PatSynArgs(..), NewOrData(..),+ Overlap(..), PatSynArgs(..), DataFlavor(..), DTypeFamilyHead(..), DFamilyResultSig(..), InjectivityAnn(..), DCon(..), DConFields(..), DDeclaredInfix, DBangType, DVarBangType, Bang(..), SourceUnpackedness(..), SourceStrictness(..), DForeign(..),- DPragma(..), DRuleBndr(..), DTySynEqn(..), DInfo(..), DInstanceDec,+ DPragma(DSpecialiseP, ..), DRuleBndr(..), DTySynEqn(..), DInfo(..), DInstanceDec, Role(..), AnnTarget(..), -- * The 'Desugar' class@@ -43,12 +52,13 @@ -- * Main desugaring functions dsExp, dsDecs, dsType, dsInfo, dsPatOverExp, dsPatsOverExp, dsPatX,- dsLetDecs, dsTvb, dsTvbSpec, dsTvbUnit, dsCxt,+ dsLetDecs, dsTvb, dsTvbSpec, dsTvbUnit, dsTvbVis, dsCxt, dsCon, dsForeign, dsPragma, dsRuleBndr, -- ** Secondary desugaring functions PatM, dsPred, dsPat, dsDec, dsDataDec, dsDataInstDec, DerivingClause, dsDerivClause, dsLetDec,+ MatchContext(..), LamCaseVariant(..), dsMatches, dsBody, dsGuards, dsDoStmts, dsComp, dsClauses, dsBangType, dsVarBangType, dsTypeFamilyHead, dsFamilyResultSig,@@ -91,12 +101,18 @@ getDataD, dataConNameToDataName, dataConNameToCon, nameOccursIn, allNamesIn, flattenDValD, getRecordSelectors, mkTypeName, mkDataName, newUniqueName,- mkTupleDExp, mkTupleDPat, maybeDLetE, maybeDCaseE, mkDLamEFromDPats,- tupleDegree_maybe, tupleNameDegree_maybe,- unboxedSumDegree_maybe, unboxedSumNameDegree_maybe,- unboxedTupleDegree_maybe, unboxedTupleNameDegree_maybe,+ mkTupleDExp, mkTupleDPat, mkTupleDType,+ maybeDLetE, maybeDCaseE, maybeDCasesE,+ dCaseE, dCasesE, dLamE, dLamCaseE, mkDLamEFromDPats,+ tupleNameDegree_maybe,+ unboxedSumNameDegree_maybe, unboxedTupleNameDegree_maybe, isTypeKindName, typeKindName, bindIP,- mkExtraDKindBinders, dTyVarBndrToDType, changeDTVFlags, toposortTyVarsOf,+ mkExtraDKindBinders, dTyVarBndrToDType, changeDTVFlags,+ mapDTVName, mapDTVKind,+ toposortTyVarsOf, toposortKindVarsOfTvbs,+ ForAllTyFlag(..),+ tvbForAllTyFlagsToSpecs, tvbForAllTyFlagsToBndrVis, matchUpSAKWithDecl,+ dtvbForAllTyFlagsToSpecs, dtvbForAllTyFlagsToBndrVis, dMatchUpSAKWithDecl, -- ** 'FunArgs' and 'VisFunArg' FunArgs(..), ForallTelescope(..), VisFunArg(..),@@ -107,10 +123,14 @@ filterDVisFunArgs, ravelDType, unravelDType, -- ** 'TypeArg'- TypeArg(..), applyType, filterTANormals, unfoldType,+ TypeArg(..), applyType, filterTANormals,+ tyVarBndrVisToTypeArg, tyVarBndrVisToTypeArgWithSig,+ unfoldType, -- ** 'DTypeArg'- DTypeArg(..), applyDType, filterDTANormals, unfoldDType,+ DTypeArg(..), applyDType, filterDTANormals,+ dTyVarBndrVisToDTypeArg, dTyVarBndrVisToDTypeArgWithSig,+ unfoldDType, -- ** Extracting bound names extractBoundNamesStmt, extractBoundNamesDec, extractBoundNamesPat@@ -221,7 +241,7 @@ y <- newUniqueName "y" let pat' = wildify name y pat match = DMatch pat' (DVarE y)- cas = DCaseE (DVarE x) [match]+ cas = dCaseE (DVarE x) [match] return $ DValD (DVarP name) cas wildify name y p =@@ -235,6 +255,8 @@ DBangP pa -> DBangP (wildify name y pa) DSigP pa ty -> DSigP (wildify name y pa) ty DWildP -> DWildP+ DTypeP ty -> DTypeP ty+ DInvisP ty -> DInvisP ty flattenDValD other_dec = return [other_dec] @@ -372,16 +394,18 @@ -- are fresh type variable names. -- -- This expands kind synonyms if necessary.-mkExtraDKindBinders :: forall q. DsMonad q => DKind -> q [DTyVarBndrUnit]+mkExtraDKindBinders :: forall q. DsMonad q => DKind -> q [DTyVarBndrVis] mkExtraDKindBinders k = do k' <- expandType k let (fun_args, _) = unravelDType k' vis_fun_args = filterDVisFunArgs fun_args mapM mk_tvb vis_fun_args where- mk_tvb :: DVisFunArg -> q DTyVarBndrUnit- mk_tvb (DVisFADep tvb) = return tvb- mk_tvb (DVisFAAnon ki) = DKindedTV <$> qNewName "a" <*> return () <*> return ki+ mk_tvb :: DVisFunArg -> q (DTyVarBndrVis)+ mk_tvb (DVisFADep tvb) = return (BndrReq <$ tvb)+ mk_tvb (DVisFAAnon ki) = do+ name <- qNewName "a"+ pure $ DKindedTV name BndrReq ki {- $localReification
Language/Haskell/TH/Desugar/AST.hs view
@@ -6,31 +6,165 @@ constructors are prefixed with a D. -} -{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveGeneric #-}+{-# LANGUAGE CPP, DeriveDataTypeable, DeriveTraversable, DeriveGeneric, DeriveLift, PatternSynonyms, ViewPatterns #-} module Language.Haskell.TH.Desugar.AST where import Data.Data hiding (Fixity) import GHC.Generics hiding (Fixity) import Language.Haskell.TH+import Language.Haskell.TH.Instances ()+import Language.Haskell.TH.Syntax (Lift) #if __GLASGOW_HASKELL__ < 900-import Language.Haskell.TH.Datatype.TyVarBndr (Specificity)+import Language.Haskell.TH.Datatype.TyVarBndr (Specificity(..)) #endif+#if __GLASGOW_HASKELL__ < 907+import Language.Haskell.TH.Datatype.TyVarBndr (BndrVis)+#endif +import Language.Haskell.TH.Desugar.Util (DataFlavor)+ -- | 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]+ -- | A @\\cases@ expression. In the spirit of making 'DExp' minimal,+ -- @th-desugar@ will desugar lambda expressions, @case@ expressions,+ -- @\\case@ expressions, and @\\cases@ expressions to 'DLamCasesE'.+ -- (See also the 'dLamE', 'dCaseE', and 'dLamCaseE' functions for+ -- constructing these expressions in terms of 'DLamCasesE'.)+ --+ -- A 'DLamCasesE' value should obey the following invariants:+ --+ -- * Each 'DClause' should have exactly the same number of visible+ -- arguments in its list of 'DPat's.+ --+ -- * If the list of 'DClause's is empty, then the overall expression+ -- should have exactly one argument. Note that this is a+ -- difference in behavior from how @\\cases@ expressions work, as+ -- @\\cases@ is required to have at least one clause. For this+ -- reason, @th-desugar@ will sweeten @DLamCasesE []@ to+ -- @\\case{}@.+ | DLamCasesE [DClause] | DLetE [DLetDec] DExp | DSigE DExp DType | DStaticE DExp- deriving (Eq, Show, Data, Generic)+ | DTypedBracketE DExp+ | DTypedSpliceE DExp+ | DTypeE DType+ | DForallE DForallTelescope DExp+ | DConstrainedE [DExp] DExp+ deriving (Eq, Show, Data, Generic, Lift) +-- | A 'DLamCasesE' value with exactly one 'DClause' where all 'DPat's are+-- 'DVarP's. This pattern synonym is provided for backwards compatibility with+-- older versions of @th-desugar@ in which 'DLamE' was a data constructor of+-- 'DExp'. This pattern synonym is deprecated and will be removed in a future+-- release of @th-desugar@.+pattern DLamE :: [Name] -> DExp -> DExp+pattern DLamE vars rhs <- (dLamE_maybe -> Just (vars, rhs))+ where+ DLamE vars rhs = DLamCasesE [DClause (map DVarP vars) rhs]+{-# DEPRECATED DLamE "Use `dLamE` or `DLamCasesE` instead." #-} +-- | Return @'Just' (pats, rhs)@ if the supplied 'DExp' is a 'DLamCasesE' value+-- with exactly one 'DClause' where all 'DPat's are 'DVarP's, where @pats@ is+-- the list of 'DVarP' 'Name's and @rhs@ is the expression on the right-hand+-- side of the 'DClause'. Otherwise, return 'Nothing'.+dLamE_maybe :: DExp -> Maybe ([Name], DExp)+dLamE_maybe (DLamCasesE [DClause pats rhs]) = do+ vars <- traverse dVarP_maybe pats+ Just (vars, rhs)+dLamE_maybe _ = Nothing++-- | Return @'Just' var@ if the supplied 'DPat' is a 'DVarP' value, where @var@+-- is the 'DVarP' 'Name'. Otherwise, return 'Nothing'.+dVarP_maybe :: DPat -> Maybe Name+dVarP_maybe (DVarP n) = Just n+dVarP_maybe _ = Nothing++-- | An application of a 'DLamCasesE' to some argument, where each 'DClause' in+-- the 'DLamCasesE' value has exactly one 'DPat'. This pattern synonym is+-- provided for backwards compatibility with older versions of @th-desugar@ in+-- which 'DCaseE' was a data constructor of 'DExp'. This pattern synonym is+-- deprecated and will be removed in a future release of @th-desugar@.+pattern DCaseE :: DExp -> [DMatch] -> DExp+pattern DCaseE scrut matches <- (dCaseE_maybe -> Just (scrut, matches))+ where+ DCaseE scrut matches = DAppE (dLamCaseE matches) scrut+{-# DEPRECATED DCaseE "Use `dCaseE` or `DLamCasesE` instead." #-}++-- | Return @'Just' (scrut, matches)@ if the supplied 'DExp' is a 'DLamCasesE'+-- value applied to some argument, where each 'DClause' in the 'DLamCasesE'+-- value has exactly one 'DPat'. Otherwise, return 'Nothing'.+dCaseE_maybe :: DExp -> Maybe (DExp, [DMatch])+dCaseE_maybe (DAppE (DLamCasesE clauses) scrut) = do+ matches <- traverse dMatch_maybe clauses+ Just (scrut, matches)+dCaseE_maybe _ = Nothing++-- | Construct a 'DExp' value that is equivalent to writing a @case@ expression.+-- Under the hood, this uses @\\cases@ ('DLamCasesE'). For instance, given this+-- code:+--+-- @+-- case scrut of+-- pat_1 -> rhs_1+-- ...+-- pat_n -> rhs_n+-- @+--+-- The following @\\cases@ expression will be created under the hood:+--+-- @+-- (\\cases+-- pat_1 -> rhs_1+-- ...+-- pat_n -> rhs_n) scrut+-- @+dCaseE :: DExp -> [DMatch] -> DExp+dCaseE scrut matches = DAppE (dLamCaseE matches) scrut++-- | Construct a 'DExp' value that is equivalent to writing a lambda expression.+-- Under the hood, this uses @\\cases@ ('DLamCasesE'). For instance, given this+-- code:+--+-- @+-- \\var_1 ... var_n -> rhs+-- @+--+-- The following @\\cases@ expression will be created under the hood:+--+-- @+-- \\cases var_1 ... var_n -> rhs+-- @+dLamE :: [DPat] -> DExp -> DExp+dLamE pats rhs = DLamCasesE [DClause pats rhs]++-- | Construct a 'DExp' value that is equivalent to writing a @\\case@+-- expression. Under the hood, this uses @\\cases@ ('DLamCasesE'). For instance,+-- given this code:+--+-- @+-- \\case+-- pat_1 -> rhs_1+-- ...+-- pat_n -> rhs_n+-- @+--+-- The following @\\cases@ expression will be created under the hood:+--+-- @+-- \\cases+-- pat_1 -> rhs_1+-- ...+-- pat_n -> rhs_n+-- @+dLamCaseE :: [DMatch] -> DExp+dLamCaseE = DLamCasesE . map dMatchToDClause+ -- | Corresponds to TH's @Pat@ type. data DPat = DLitP Lit | DVarP Name@@ -39,7 +173,9 @@ | DBangP DPat | DSigP DPat DType | DWildP- deriving (Eq, Show, Data, Generic)+ | DTypeP DType+ | DInvisP DType+ deriving (Eq, Show, Data, Generic, Lift) -- | Corresponds to TH's @Type@ type, used to represent -- types and kinds.@@ -53,7 +189,7 @@ | DArrowT | DLitT TyLit | DWildCardT- deriving (Eq, Show, Data, Generic)+ deriving (Eq, Show, Data, Generic, Lift) -- | The type variable binders in a @forall@. data DForallTelescope@@ -64,7 +200,7 @@ | DForallInvis [DTyVarBndrSpec] -- ^ An invisible @forall@ (e.g., @forall a {b} c -> {...}@), -- where each binder has a 'Specificity'.- deriving (Eq, Show, Data, Generic)+ deriving (Eq, Show, Data, Generic, Lift) -- | Kinds are types. Corresponds to TH's @Kind@ type DKind = DType@@ -79,7 +215,7 @@ data DTyVarBndr flag = DPlainTV Name flag | DKindedTV Name flag DKind- deriving (Eq, Show, Data, Generic, Functor)+ deriving (Eq, Show, Data, Generic, Functor, Foldable, Traversable, Lift) -- | Corresponds to TH's @TyVarBndrSpec@ type DTyVarBndrSpec = DTyVarBndr Specificity@@ -87,32 +223,80 @@ -- | Corresponds to TH's @TyVarBndrUnit@ type DTyVarBndrUnit = DTyVarBndr () +-- | Corresponds to TH's @TyVarBndrVis@+type DTyVarBndrVis = DTyVarBndr BndrVis+ -- | Corresponds to TH's @Match@ type.+--+-- Note that while @Match@ appears in the TH AST, 'DMatch' does not appear+-- directly in the @th-desugar@ AST. This is because TH's 'Match' is used in+-- lambda (@LamE@) and @case@ (@CaseE@) expressions, but @th-desugar@ does not+-- have counterparts to @LamE@ and @CaseE@ in the 'DExp' data type. Instead,+-- 'DExp' only has a @\\cases@ ('DLamCasesE') construct, which uses 'DClause'+-- instead of 'DMatch'.+--+-- As such, 'DMatch' only plays a \"vestigial\" role in @th-desugar@ for+-- constructing 'DLamCasesE' values that look like lambda or @case@ expressions.+-- For example, 'DMatch' appears in the type signatures for 'dLamE' and+-- 'dCaseE', which convert the supplied 'DMatch'es to 'DClause's under the hood. data DMatch = DMatch DPat DExp- deriving (Eq, Show, Data, Generic)+ deriving (Eq, Show, Data, Generic, Lift) -- | Corresponds to TH's @Clause@ type. data DClause = DClause [DPat] DExp- deriving (Eq, Show, Data, Generic)+ deriving (Eq, Show, Data, Generic, Lift) +-- | Convert a 'DMatch' to a 'DClause', where the 'DClause' contains a single+-- pattern taken from the 'DMatch'.+dMatchToDClause :: DMatch -> DClause+dMatchToDClause (DMatch pat rhs) = DClause [pat] rhs++-- | Return @'Just' match@ if the supplied 'DClause' has exactly one 'DPat',+-- where @match@ matches on that 'DPat'. Otherwise, return 'Nothing'.+dMatch_maybe :: DClause -> Maybe DMatch+dMatch_maybe (DClause pats rhs) =+ case pats of+ [pat] -> Just (DMatch pat rhs)+ _ -> Nothing+ -- | Declarations as used in a @let@ statement. data DLetDec = DFunD Name [DClause] | DValD DPat DExp | DSigD Name DType- | DInfixD Fixity Name+ | DInfixD Fixity NamespaceSpecifier Name | DPragmaD DPragma- deriving (Eq, Show, Data, Generic)+ deriving (Eq, Show, Data, Generic, Lift) --- | Is it a @newtype@ or a @data@ type?-data NewOrData = Newtype- | Data- deriving (Eq, Show, Data, Generic)+#if __GLASGOW_HASKELL__ < 909+-- | Same as @NamespaceSpecifier@ from TH; defined here for backwards+-- compatibility.+data NamespaceSpecifier+ = NoNamespaceSpecifier -- ^ Name may be everything; If there are two+ -- names in different namespaces, then consider both+ | TypeNamespaceSpecifier -- ^ Name should be a type-level entity, such as a+ -- data type, type alias, type family, type class,+ -- or type variable+ | DataNamespaceSpecifier -- ^ Name should be a term-level entity, such as a+ -- function, data constructor, or pattern synonym+ deriving (Eq, Ord, Show, Data, Generic, Lift)+#endif -- | Corresponds to TH's @Dec@ type. data DDec = DLetDec DLetDec- | DDataD NewOrData DCxt Name [DTyVarBndrUnit] (Maybe DKind) [DCon] [DDerivClause]- | DTySynD Name [DTyVarBndrUnit] DType- | DClassD DCxt Name [DTyVarBndrUnit] [FunDep] [DDec]+ -- | An ordinary (i.e., non-data family) data type declaration. Note+ -- that desugaring upholds the following properties regarding the+ -- 'DataFlavor' field:+ --+ -- * If the 'DataFlavor' is 'NewType', then there will be exactly+ -- one 'DCon'.+ --+ -- * If the 'DataFlavor' is 'TypeData', then there will be no+ -- 'DDerivClause's, the 'DCxt' will be empty, and the 'DConFields'+ -- in each 'DCon' will be a 'NormalC' where each 'Bang' is equal+ -- to @Bang 'NoSourceUnpackedness' 'NoSourceStrictness'@.+ | DDataD DataFlavor DCxt Name [DTyVarBndrVis] (Maybe DKind) [DCon] [DDerivClause]+ | DTySynD Name [DTyVarBndrVis] DType+ | DClassD DCxt Name [DTyVarBndrVis] [FunDep] [DDec] -- | Note that the @Maybe [DTyVarBndrUnit]@ field is dropped -- entirely when sweetened, so it is only useful for functions -- that directly consume @DDec@s.@@ -120,8 +304,17 @@ | DForeignD DForeign | DOpenTypeFamilyD DTypeFamilyHead | DClosedTypeFamilyD DTypeFamilyHead [DTySynEqn]- | DDataFamilyD Name [DTyVarBndrUnit] (Maybe DKind)- | DDataInstD NewOrData DCxt (Maybe [DTyVarBndrUnit]) DType (Maybe DKind)+ | DDataFamilyD Name [DTyVarBndrVis] (Maybe DKind)+ -- | A data family instance declaration. Note that desugaring+ -- upholds the following properties regarding the 'DataFlavor'+ -- field:+ --+ -- * If the 'DataFlavor' is 'NewType', then there will be exactly+ -- one 'DCon'.+ --+ -- * The 'DataFlavor' will never be 'TypeData', as GHC does not+ -- permit combining data families with @type data@.+ | DDataInstD DataFlavor DCxt (Maybe [DTyVarBndrUnit]) DType (Maybe DKind) [DCon] [DDerivClause] | DTySynInstD DTySynEqn | DRoleAnnotD Name [Role]@@ -136,13 +329,13 @@ -- DKiSigD is part of DDec, not DLetDec, because standalone kind -- signatures can only appear on the top level. | DDefaultD [DType]- deriving (Eq, Show, Data, Generic)+ deriving (Eq, Show, Data, Generic, Lift) -- | 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 (Eq, Show, Data, Generic)+ deriving (Eq, Show, Data, Generic, Lift) -- | Corresponds to TH's 'PatSynType' type type DPatSynType = DType@@ -153,19 +346,19 @@ = 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 (Eq, Show, Data, Generic)+ deriving (Eq, Show, Data, Generic, Lift) #endif -- | Corresponds to TH's 'TypeFamilyHead' type-data DTypeFamilyHead = DTypeFamilyHead Name [DTyVarBndrUnit] DFamilyResultSig+data DTypeFamilyHead = DTypeFamilyHead Name [DTyVarBndrVis] DFamilyResultSig (Maybe InjectivityAnn)- deriving (Eq, Show, Data, Generic)+ deriving (Eq, Show, Data, Generic, Lift) -- | Corresponds to TH's 'FamilyResultSig' type data DFamilyResultSig = DNoSig | DKindSig DKind | DTyVarSig DTyVarBndrUnit- deriving (Eq, Show, Data, Generic)+ deriving (Eq, Show, Data, Generic, Lift) -- | Corresponds to TH's 'Con' type. Unlike 'Con', all 'DCon's reflect GADT -- syntax. This is beneficial for @th-desugar@'s since it means@@ -184,13 +377,13 @@ -- * A 'DCon' always has an explicit return type. data DCon = DCon [DTyVarBndrSpec] DCxt Name DConFields DType -- ^ The GADT result type- deriving (Eq, Show, Data, Generic)+ deriving (Eq, Show, Data, Generic, Lift) -- | A list of fields either for a standard data constructor or a record -- data constructor. data DConFields = DNormalC DDeclaredInfix [DBangType] | DRecC [DVarBangType]- deriving (Eq, Show, Data, Generic)+ deriving (Eq, Show, Data, Generic, Lift) -- | '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@@ -245,27 +438,34 @@ -- | Corresponds to TH's @Foreign@ type. data DForeign = DImportF Callconv Safety String Name DType | DExportF Callconv String Name DType- deriving (Eq, Show, Data, Generic)+ deriving (Eq, Show, Data, Generic, Lift) -- | Corresponds to TH's @Pragma@ type. data DPragma = DInlineP Name Inline RuleMatch Phases- | DSpecialiseP Name DType (Maybe Inline) Phases+ | DSpecialiseEP (Maybe [DTyVarBndr ()]) [DRuleBndr] DExp (Maybe Inline) Phases | DSpecialiseInstP DType | DRuleP String (Maybe [DTyVarBndrUnit]) [DRuleBndr] DExp DExp Phases | DAnnP AnnTarget DExp | DLineP Int String | DCompleteP [Name] (Maybe Name) | DOpaqueP Name- deriving (Eq, Show, Data, Generic)+ | DSCCP Name (Maybe String)+ deriving (Eq, Show, Data, Generic, Lift) +-- | Old-form specialise pragma @{ {\-\# SPECIALISE [INLINE] [phases] (var :: ty) #-} }@.+--+-- Subsumed by the more general 'DSpecialiseEP' constructor.+pattern DSpecialiseP :: Name -> DType -> Maybe Inline -> Phases -> DPragma+pattern DSpecialiseP nm ty inl phases = DSpecialiseEP Nothing [] (DSigE (DVarE nm) ty) inl phases+ -- | Corresponds to TH's @RuleBndr@ type. data DRuleBndr = DRuleVar Name | DTypedRuleVar Name DType- deriving (Eq, Show, Data, Generic)+ deriving (Eq, Show, Data, Generic, Lift) -- | Corresponds to TH's @TySynEqn@ type (to store type family equations). data DTySynEqn = DTySynEqn (Maybe [DTyVarBndrUnit]) DType DType- deriving (Eq, Show, Data, Generic)+ deriving (Eq, Show, Data, Generic, Lift) -- | Corresponds to TH's @Info@ type. data DInfo = DTyConI DDec (Maybe [DInstanceDec])@@ -278,17 +478,17 @@ -- ^ The @Int@ is the arity; the @Bool@ is whether this tycon -- is unlifted. | DPatSynI Name DPatSynType- deriving (Eq, Show, Data, Generic)+ deriving (Eq, Show, Data, Generic, Lift) type DInstanceDec = DDec -- ^ Guaranteed to be an instance declaration -- | Corresponds to TH's @DerivClause@ type. data DDerivClause = DDerivClause (Maybe DDerivStrategy) DCxt- deriving (Eq, Show, Data, Generic)+ deriving (Eq, Show, Data, Generic, Lift) -- | Corresponds to TH's @DerivStrategy@ type. data DDerivStrategy = DStockStrategy -- ^ A \"standard\" derived instance | DAnyclassStrategy -- ^ @-XDeriveAnyClass@ | DNewtypeStrategy -- ^ @-XGeneralizedNewtypeDeriving@ | DViaStrategy DType -- ^ @-XDerivingVia@- deriving (Eq, Show, Data, Generic)+ deriving (Eq, Show, Data, Generic, Lift)
Language/Haskell/TH/Desugar/Core.hs view
@@ -14,1967 +14,2438 @@ import Prelude hiding (mapM, foldl, foldr, all, elem, exp, concatMap, and) -import Language.Haskell.TH hiding (match, clause, cxt)-import Language.Haskell.TH.Datatype.TyVarBndr-import Language.Haskell.TH.Syntax hiding (lift)--import Control.Monad hiding (forM_, mapM)-import qualified Control.Monad.Fail as Fail-import Control.Monad.Trans (MonadTrans(..))-import Control.Monad.Writer (MonadWriter(..), WriterT(..))-import Control.Monad.Zip-import Data.Data (Data)-import Data.Either (lefts)-import Data.Foldable as F hiding (concat, notElem)-import qualified Data.Map as M-import Data.Map (Map)-import Data.Maybe (isJust, mapMaybe)-import Data.Monoid (All(..))-import qualified Data.Set as S-import Data.Set (Set)-import Data.Traversable--#if __GLASGOW_HASKELL__ >= 803-import GHC.OverloadedLabels ( fromLabel )-#endif--#if __GLASGOW_HASKELL__ >= 807-import GHC.Classes (IP(..))-#endif--#if __GLASGOW_HASKELL__ >= 902-import Data.List.NonEmpty (NonEmpty(..))-import GHC.Records (HasField(..))-#endif--import GHC.Exts-import GHC.Generics (Generic)--import Language.Haskell.TH.Desugar.AST-import Language.Haskell.TH.Desugar.FV-import qualified Language.Haskell.TH.Desugar.OSet as OS-import Language.Haskell.TH.Desugar.OSet (OSet)-import Language.Haskell.TH.Desugar.Util-import Language.Haskell.TH.Desugar.Reify---- | Desugar an expression-dsExp :: DsMonad q => Exp -> q DExp-dsExp (VarE n) = return $ DVarE n-dsExp (ConE n) = return $ DConE n-dsExp (LitE lit) = return $ DLitE lit-dsExp (AppE e1 e2) = DAppE <$> dsExp e1 <*> dsExp e2-dsExp (InfixE Nothing op Nothing) = dsExp op-dsExp (InfixE (Just lhs) op Nothing) = DAppE <$> (dsExp op) <*> (dsExp lhs)-dsExp (InfixE Nothing op (Just rhs)) = do- lhsName <- newUniqueName "lhs"- op' <- dsExp op- rhs' <- dsExp rhs- return $ DLamE [lhsName] (foldl DAppE op' [DVarE lhsName, rhs'])-dsExp (InfixE (Just lhs) op (Just rhs)) =- DAppE <$> (DAppE <$> dsExp op <*> dsExp lhs) <*> dsExp rhs-dsExp (UInfixE _ _ _) =- fail "Cannot desugar unresolved infix operators."-dsExp (ParensE exp) = dsExp exp-dsExp (LamE pats exp) = do- exp' <- dsExp exp- (pats', exp'') <- dsPatsOverExp pats exp'- mkDLamEFromDPats pats' exp''-dsExp (LamCaseE matches) = do- x <- newUniqueName "x"- matches' <- dsMatches x matches- return $ DLamE [x] (DCaseE (DVarE x) matches')-dsExp (TupE exps) = dsTup tupleDataName exps-dsExp (UnboxedTupE exps) = dsTup unboxedTupleDataName exps-dsExp (CondE e1 e2 e3) =- dsExp (CaseE e1 [mkBoolMatch 'True e2, mkBoolMatch 'False e3])- where- mkBoolMatch :: Name -> Exp -> Match- mkBoolMatch boolDataCon rhs =- Match (ConP boolDataCon-#if __GLASGOW_HASKELL__ >= 901- []-#endif- []) (NormalB rhs) []-dsExp (MultiIfE guarded_exps) =- let failure = mkErrorMatchExpr MultiWayIfAlt in- dsGuards guarded_exps failure-dsExp (LetE decs exp) = do- (decs', ip_binder) <- dsLetDecs decs- exp' <- dsExp exp- return $ DLetE decs' $ ip_binder exp'- -- the following special case avoids creating a new "let" when it's not- -- necessary. See #34.-dsExp (CaseE (VarE scrutinee) matches) = do- matches' <- dsMatches scrutinee matches- return $ DCaseE (DVarE scrutinee) matches'-dsExp (CaseE exp matches) = do- scrutinee <- newUniqueName "scrutinee"- exp' <- dsExp exp- matches' <- dsMatches scrutinee matches- return $ DLetE [DValD (DVarP scrutinee) exp'] $- DCaseE (DVarE scrutinee) matches'-#if __GLASGOW_HASKELL__ >= 900-dsExp (DoE mb_mod stmts) = dsDoStmts mb_mod stmts-#else-dsExp (DoE stmts) = dsDoStmts Nothing stmts-#endif-dsExp (CompE stmts) = dsComp stmts-dsExp (ArithSeqE (FromR exp)) = DAppE (DVarE 'enumFrom) <$> dsExp exp-dsExp (ArithSeqE (FromThenR exp1 exp2)) =- DAppE <$> (DAppE (DVarE 'enumFromThen) <$> dsExp exp1) <*> dsExp exp2-dsExp (ArithSeqE (FromToR exp1 exp2)) =- DAppE <$> (DAppE (DVarE 'enumFromTo) <$> dsExp exp1) <*> dsExp exp2-dsExp (ArithSeqE (FromThenToR e1 e2 e3)) =- DAppE <$> (DAppE <$> (DAppE (DVarE 'enumFromThenTo) <$> dsExp e1) <*>- dsExp e2) <*>- dsExp e3-dsExp (ListE exps) = go exps- where go [] = return $ DConE '[]- go (h : t) = DAppE <$> (DAppE (DConE '(:)) <$> dsExp h) <*> go t-dsExp (SigE exp ty) = DSigE <$> dsExp exp <*> dsType ty-dsExp (RecConE con_name field_exps) = do- con <- dataConNameToCon con_name- reordered <- reorder con- return $ foldl DAppE (DConE con_name) reordered- where- reorder con = case con of- NormalC _name fields -> non_record fields- InfixC field1 _name field2 -> non_record [field1, field2]- RecC _name fields -> reorder_fields fields- ForallC _ _ c -> reorder c- GadtC _names fields _ret_ty -> non_record fields- RecGadtC _names fields _ret_ty -> reorder_fields fields-- reorder_fields fields = reorderFields con_name fields field_exps- (repeat $ DVarE 'undefined)-- non_record fields | null field_exps- -- Special case: record construction is allowed for any- -- constructor, regardless of whether the constructor- -- actually was declared with records, provided that no- -- records are given in the expression itself. (See #59).- --- -- Con{} desugars down to Con undefined ... undefined.- = return $ replicate (length fields) $ DVarE 'undefined-- | otherwise =- impossible $ "Record syntax used with non-record constructor "- ++ (show con_name) ++ "."--dsExp (RecUpdE exp field_exps) = do- -- here, we need to use one of the field names to find the tycon, somewhat dodgily- first_name <- case field_exps of- ((name, _) : _) -> return name- _ -> impossible "Record update with no fields listed."- info <- reifyWithLocals first_name- applied_type <- case info of- VarI _name ty _m_dec -> extract_first_arg ty- _ -> impossible "Record update with an invalid field name."- type_name <- extract_type_name applied_type- (_, cons) <- getDataD "This seems to be an error in GHC." type_name- let filtered_cons = filter_cons_with_names cons (map fst field_exps)- exp' <- dsExp exp- matches <- mapM con_to_dmatch filtered_cons- let all_matches- | length filtered_cons == length cons = matches- | otherwise = matches ++ [error_match]- return $ DCaseE exp' all_matches- where- extract_first_arg :: DsMonad q => Type -> q Type- extract_first_arg (AppT (AppT ArrowT arg) _) = return arg- extract_first_arg (ForallT _ _ t) = extract_first_arg t- extract_first_arg (SigT t _) = extract_first_arg t- extract_first_arg _ = impossible "Record selector not a function."-- extract_type_name :: DsMonad q => Type -> q Name- extract_type_name (AppT t1 _) = extract_type_name t1- extract_type_name (SigT t _) = extract_type_name t- extract_type_name (ConT n) = return n- extract_type_name _ = impossible "Record selector domain not a datatype."-- filter_cons_with_names cons field_names =- filter has_names cons- where- args_contain_names args =- let con_field_names = map fst_of_3 args in- all (`elem` con_field_names) field_names-- has_names (RecC _con_name args) =- args_contain_names args- has_names (RecGadtC _con_name args _ret_ty) =- args_contain_names args- has_names (ForallC _ _ c) = has_names c- has_names _ = False-- rec_con_to_dmatch con_name args = do- let con_field_names = map fst_of_3 args- field_var_names <- mapM (newUniqueName . nameBase) con_field_names- DMatch (DConP con_name [] (map DVarP field_var_names)) <$>- (foldl DAppE (DConE con_name) <$>- (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- -- We're assuming the GADT constructor has only one Name here, but since- -- this constructor was reified, this assumption should always hold true.- con_to_dmatch (RecGadtC [con_name] args _ret_ty) = rec_con_to_dmatch con_name args- con_to_dmatch (ForallC _ _ c) = con_to_dmatch c- con_to_dmatch _ = impossible "Internal error within th-desugar."-- error_match = DMatch DWildP (mkErrorMatchExpr RecUpd)-- fst_of_3 (x, _, _) = x-dsExp (StaticE exp) = DStaticE <$> dsExp exp-dsExp (UnboundVarE n) = return (DVarE n)-#if __GLASGOW_HASKELL__ >= 801-dsExp (AppTypeE exp ty) = DAppTypeE <$> dsExp exp <*> dsType ty-dsExp (UnboxedSumE exp alt arity) =- DAppE (DConE $ unboxedSumDataName alt arity) <$> dsExp exp-#endif-#if __GLASGOW_HASKELL__ >= 803-dsExp (LabelE str) = return $ DVarE 'fromLabel `DAppTypeE` DLitT (StrTyLit str)-#endif-#if __GLASGOW_HASKELL__ >= 807-dsExp (ImplicitParamVarE n) = return $ DVarE 'ip `DAppTypeE` DLitT (StrTyLit n)-dsExp (MDoE {}) = fail "th-desugar currently does not support RecursiveDo"-#endif-#if __GLASGOW_HASKELL__ >= 902-dsExp (GetFieldE arg field) = DAppE (mkGetFieldProj field) <$> dsExp arg-dsExp (ProjectionE fields) =- case fields of- f :| fs -> return $ foldl' comp (mkGetFieldProj f) fs- where- comp :: DExp -> String -> DExp- comp acc f = DVarE '(.) `DAppE` mkGetFieldProj f `DAppE` acc-#endif-#if __GLASGOW_HASKELL__ >= 903-dsExp (LamCasesE clauses) = do- clauses' <- dsClauses CaseAlt clauses- numArgs <-- case clauses' of- (DClause pats _:_) -> return $ length pats- [] -> fail "\\cases expression must have at least one alternative"- args <- replicateM numArgs (newUniqueName "x")- return $ DLamE args $ DCaseE (mkUnboxedTupleDExp (map DVarE args))- (map dClauseToUnboxedTupleMatch clauses')-#endif---- | Convert a 'DClause' to a 'DMatch' by bundling all of the clause's patterns--- into a match on a single unboxed tuple pattern. That is, convert this:------ @--- f x y z = rhs--- @------ To this:------ @--- f (# x, y, z #) = rhs--- @------ This is used to desugar @\\cases@ expressions into lambda expressions.-dClauseToUnboxedTupleMatch :: DClause -> DMatch-dClauseToUnboxedTupleMatch (DClause pats rhs) =- DMatch (mkUnboxedTupleDPat pats) rhs--#if __GLASGOW_HASKELL__ >= 809-dsTup :: DsMonad q => (Int -> Name) -> [Maybe Exp] -> q DExp-dsTup = ds_tup-#else-dsTup :: DsMonad q => (Int -> Name) -> [Exp] -> q DExp-dsTup tuple_data_name = ds_tup tuple_data_name . map Just-#endif---- | Desugar a tuple (or tuple section) expression.-ds_tup :: forall q. DsMonad q- => (Int -> Name) -- ^ Compute the 'Name' of a tuple (boxed or unboxed)- -- data constructor from its arity.- -> [Maybe Exp] -- ^ The tuple's subexpressions. 'Nothing' entries- -- denote empty fields in a tuple section.- -> q DExp-ds_tup tuple_data_name mb_exps = do- section_exps <- mapM ds_section_exp mb_exps- let section_vars = lefts section_exps- tup_body = mk_tup_body section_exps- if null section_vars- then return tup_body -- If this isn't a tuple section,- -- don't create a lambda.- else mkDLamEFromDPats (map DVarP section_vars) tup_body- where- -- If dealing with an empty field in a tuple section (Nothing), create a- -- unique name and return Left. These names will be used to construct the- -- lambda expression that it desugars to.- -- (For example, `(,5)` desugars to `\ts -> (,) ts 5`.)- --- -- If dealing with a tuple subexpression (Just), desugar it and return- -- Right.- ds_section_exp :: Maybe Exp -> q (Either Name DExp)- ds_section_exp = maybe (Left <$> qNewName "ts") (fmap Right . dsExp)-- mk_tup_body :: [Either Name DExp] -> DExp- mk_tup_body section_exps =- foldl' apply_tup_body (DConE $ tuple_data_name (length section_exps))- section_exps-- apply_tup_body :: DExp -> Either Name DExp -> DExp- apply_tup_body f (Left n) = f `DAppE` DVarE n- apply_tup_body f (Right e) = f `DAppE` e---- | 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 :: Quasi q => [DPat] -> DExp -> q DExp-mkDLamEFromDPats pats exp- | Just names <- mapM stripDVarP_maybe pats- = return $ DLamE names exp- | otherwise- = do arg_names <- replicateM (length pats) (newUniqueName "arg")- let scrutinee = mkUnboxedTupleDExp (map DVarE arg_names)- match = DMatch (mkUnboxedTupleDPat pats) exp- return $ DLamE arg_names (DCaseE scrutinee [match])- where- stripDVarP_maybe :: DPat -> Maybe Name- stripDVarP_maybe (DVarP n) = Just n- stripDVarP_maybe _ = Nothing--#if __GLASGOW_HASKELL__ >= 902-mkGetFieldProj :: String -> DExp-mkGetFieldProj field = DVarE 'getField `DAppTypeE` DLitT (StrTyLit field)-#endif---- | Desugar a list of matches for a @case@ statement-dsMatches :: DsMonad q- => Name -- ^ Name of the scrutinee, which must be a bare var- -> [Match] -- ^ Matches of the @case@ statement- -> q [DMatch]-dsMatches scr = go- where- go :: DsMonad q => [Match] -> q [DMatch]- go [] = return []- go (Match pat body where_decs : rest) = do- rest' <- go rest- let failure = maybeDCaseE CaseAlt (DVarE scr) rest'- exp' <- dsBody body where_decs failure- (pat', exp'') <- dsPatOverExp pat exp'- uni_pattern <- isUniversalPattern pat' -- incomplete attempt at #6- if uni_pattern- then return [DMatch pat' exp'']- else return (DMatch pat' exp'' : rest')---- | Desugar a @Body@-dsBody :: DsMonad q- => Body -- ^ body to desugar- -> [Dec] -- ^ "where" declarations- -> DExp -- ^ what to do if the guards don't match- -> q DExp-dsBody (NormalB exp) decs _ = do- (decs', ip_binder) <- dsLetDecs decs- exp' <- dsExp exp- return $ maybeDLetE decs' $ ip_binder exp'-dsBody (GuardedB guarded_exps) decs failure = do- (decs', ip_binder) <- dsLetDecs decs- guarded_exp' <- dsGuards guarded_exps failure- return $ maybeDLetE decs' $ ip_binder guarded_exp'---- | If decs is non-empty, delcare them in a let:-maybeDLetE :: [DLetDec] -> DExp -> DExp-maybeDLetE [] exp = exp-maybeDLetE decs exp = DLetE decs exp---- | If matches is non-empty, make a case statement; otherwise make an error statement-maybeDCaseE :: MatchContext -> DExp -> [DMatch] -> DExp-maybeDCaseE mc _ [] = mkErrorMatchExpr mc-maybeDCaseE _ scrut matches = DCaseE scrut matches---- | Desugar guarded expressions-dsGuards :: DsMonad q- => [(Guard, Exp)] -- ^ Guarded expressions- -> DExp -- ^ What to do if none of the guards match- -> q DExp-dsGuards [] thing_inside = return thing_inside-dsGuards ((NormalG gd, exp) : rest) thing_inside =- dsGuards ((PatG [NoBindS gd], exp) : rest) thing_inside-dsGuards ((PatG stmts, exp) : rest) thing_inside = do- success <- dsExp exp- failure <- dsGuards rest thing_inside- dsGuardStmts stmts success failure---- | Desugar the @Stmt@s in a guard-dsGuardStmts :: DsMonad q- => [Stmt] -- ^ The @Stmt@s to desugar- -> DExp -- ^ What to do if the @Stmt@s yield success- -> DExp -- ^ What to do if the @Stmt@s yield failure- -> q DExp-dsGuardStmts [] success _failure = return success-dsGuardStmts (BindS pat exp : rest) success failure = do- success' <- dsGuardStmts rest success failure- (pat', success'') <- dsPatOverExp pat success'- exp' <- dsExp exp- return $ DCaseE exp' [DMatch pat' success'', DMatch DWildP failure]-dsGuardStmts (LetS decs : rest) success failure = do- (decs', ip_binder) <- dsLetDecs decs- success' <- dsGuardStmts rest success failure- return $ DLetE decs' $ ip_binder success'- -- special-case a final pattern containing "otherwise" or "True"- -- note that GHC does this special-casing, too, in DsGRHSs.isTrueLHsExpr-dsGuardStmts [NoBindS exp] success _failure- | VarE name <- exp- , name == 'otherwise- = return success-- | ConE name <- exp- , name == 'True- = return success-dsGuardStmts (NoBindS exp : rest) success failure = do- exp' <- dsExp exp- success' <- dsGuardStmts rest success failure- return $ DCaseE exp' [ DMatch (DConP 'True [] []) success'- , DMatch (DConP 'False [] []) failure ]-dsGuardStmts (ParS _ : _) _ _ = impossible "Parallel comprehension in a pattern guard."-#if __GLASGOW_HASKELL__ >= 807-dsGuardStmts (RecS {} : _) _ _ = fail "th-desugar currently does not support RecursiveDo"-#endif---- | Desugar the @Stmt@s in a @do@ expression-dsDoStmts :: forall q. DsMonad q => Maybe ModName -> [Stmt] -> q DExp-dsDoStmts mb_mod = go- where- go :: [Stmt] -> q DExp- go [] = impossible "do-expression ended with something other than bare statement."- go [NoBindS exp] = dsExp exp- go (BindS pat exp : rest) = do- rest' <- go rest- dsBindS mb_mod exp pat rest' "do expression"- go (LetS decs : rest) = do- (decs', ip_binder) <- dsLetDecs decs- rest' <- go rest- return $ DLetE decs' $ ip_binder rest'- go (NoBindS exp : rest) = do- exp' <- dsExp exp- rest' <- go rest- let sequence_name = mk_qual_do_name mb_mod '(>>)- return $ DAppE (DAppE (DVarE sequence_name) exp') rest'- go (ParS _ : _) = impossible "Parallel comprehension in a do-statement."-#if __GLASGOW_HASKELL__ >= 807- go (RecS {} : _) = fail "th-desugar currently does not support RecursiveDo"-#endif---- | Desugar the @Stmt@s in a list or monad comprehension-dsComp :: DsMonad q => [Stmt] -> q DExp-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- rest' <- dsComp rest- dsBindS Nothing exp pat rest' "monad comprehension"-dsComp (LetS decs : rest) = do- (decs', ip_binder) <- dsLetDecs decs- rest' <- dsComp rest- return $ DLetE decs' $ ip_binder rest'-dsComp (NoBindS exp : rest) = do- exp' <- dsExp exp- rest' <- dsComp rest- return $ DAppE (DAppE (DVarE '(>>)) (DAppE (DVarE 'guard) exp')) rest'-dsComp (ParS stmtss : rest) = do- (pat, exp) <- dsParComp stmtss- rest' <- dsComp rest- DAppE (DAppE (DVarE '(>>=)) exp) <$> mkDLamEFromDPats [pat] rest'-#if __GLASGOW_HASKELL__ >= 807-dsComp (RecS {} : _) = fail "th-desugar currently does not support RecursiveDo"-#endif---- 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- => Maybe ModName -> Exp -> Pat -> DExp -> String -> q DExp-dsBindS mb_mod 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_name) 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 DWildP $- DVarE fail_name `DAppE`- DLitE (StringL $ "Pattern match failure in " ++ ctxt)- ]- where- bind_name = mk_qual_do_name mb_mod '(>>=)-- mk_fail_name :: q Name-#if __GLASGOW_HASKELL__ >= 807- -- GHC 8.8 deprecates the MonadFailDesugaring extension since its effects- -- are always enabled. Furthermore, MonadFailDesugaring is no longer- -- enabled by default, so simply use MonadFail.fail. (That happens to- -- be the same as Prelude.fail in 8.8+.)- mk_fail_name = return fail_MonadFail_name-#else- mk_fail_name = do- mfd <- qIsExtEnabled MonadFailDesugaring- return $ if mfd then fail_MonadFail_name else fail_Prelude_name-#endif-- fail_MonadFail_name = mk_qual_do_name mb_mod 'Fail.fail--#if __GLASGOW_HASKELL__ < 807- fail_Prelude_name = mk_qual_do_name mb_mod '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-dsParComp :: DsMonad q => [[Stmt]] -> q (DPat, DExp)-dsParComp [] = impossible "Empty list of parallel comprehension statements."-dsParComp [r] = do- let rv = foldMap extractBoundNamesStmt r- dsR <- dsComp (r ++ [mk_tuple_stmt rv])- return (mk_tuple_dpat rv, dsR)-dsParComp (q : rest) = do- let qv = foldMap extractBoundNamesStmt q- (rest_pat, rest_exp) <- dsParComp rest- dsQ <- dsComp (q ++ [mk_tuple_stmt qv])- let zipped = DAppE (DAppE (DVarE 'mzip) dsQ) rest_exp- return (DConP (tupleDataName 2) [] [mk_tuple_dpat qv, rest_pat], zipped)---- helper function for dsParComp-mk_tuple_stmt :: OSet Name -> Stmt-mk_tuple_stmt name_set =- NoBindS (mkTupleExp (F.foldr ((:) . VarE) [] name_set))---- helper function for dsParComp-mk_tuple_dpat :: OSet Name -> DPat-mk_tuple_dpat name_set =- mkTupleDPat (F.foldr ((:) . DVarP) [] name_set)---- | Desugar a pattern, along with processing a (desugared) expression that--- is the entire scope of the variables bound in the pattern.-dsPatOverExp :: DsMonad q => Pat -> DExp -> q (DPat, DExp)-dsPatOverExp pat exp = do- (pat', vars) <- runWriterT $ dsPat pat- let name_decs = map (uncurry (DValD . DVarP)) vars- return (pat', maybeDLetE name_decs exp)---- | Desugar multiple patterns. Like 'dsPatOverExp'.-dsPatsOverExp :: DsMonad q => [Pat] -> DExp -> q ([DPat], DExp)-dsPatsOverExp pats exp = do- (pats', vars) <- runWriterT $ mapM dsPat pats- let name_decs = map (uncurry (DValD . DVarP)) vars- return (pats', maybeDLetE name_decs exp)---- | Desugar a pattern, returning a list of (Name, DExp) pairs of extra--- variables that must be bound within the scope of the pattern-dsPatX :: DsMonad q => Pat -> q (DPat, [(Name, DExp)])-dsPatX = runWriterT . dsPat---- | Desugaring a pattern also returns the list of variables bound in as-patterns--- and the values they should be bound to. This variables must be brought into--- scope in the "body" of the pattern.-type PatM q = WriterT [(Name, DExp)] q---- | Desugar a pattern.-dsPat :: DsMonad q => Pat -> PatM q DPat-dsPat (LitP lit) = return $ DLitP lit-dsPat (VarP n) = return $ DVarP n-dsPat (TupP pats) = DConP (tupleDataName (length pats)) [] <$> mapM dsPat pats-dsPat (UnboxedTupP pats) = DConP (unboxedTupleDataName (length pats)) [] <$>- mapM dsPat pats-#if __GLASGOW_HASKELL__ >= 901-dsPat (ConP name tys pats) = DConP name <$> mapM dsType tys <*> mapM dsPat pats-#else-dsPat (ConP name pats) = DConP name [] <$> mapM dsPat pats-#endif-dsPat (InfixP p1 name p2) = DConP name [] <$> mapM dsPat [p1, p2]-dsPat (UInfixP _ _ _) =- fail "Cannot desugar unresolved infix operators."-dsPat (ParensP pat) = dsPat pat-dsPat (TildeP pat) = DTildeP <$> dsPat pat-dsPat (BangP pat) = DBangP <$> dsPat pat-dsPat (AsP name pat) = do- pat' <- dsPat pat- pat'' <- lift $ removeWilds pat'- tell [(name, dPatToDExp pat'')]- return pat''-dsPat WildP = return DWildP-dsPat (RecP con_name field_pats) = do- con <- lift $ dataConNameToCon con_name- reordered <- reorder con- return $ DConP con_name [] reordered- where- reorder con = case con of- NormalC _name fields -> non_record fields- InfixC field1 _name field2 -> non_record [field1, field2]- RecC _name fields -> reorder_fields_pat fields- ForallC _ _ c -> reorder c- GadtC _names fields _ret_ty -> non_record fields- RecGadtC _names fields _ret_ty -> reorder_fields_pat fields-- reorder_fields_pat fields = reorderFieldsPat con_name fields field_pats-- non_record fields | null field_pats- -- Special case: record patterns are allowed for any- -- constructor, regardless of whether the constructor- -- actually was declared with records, provided that- -- no records are given in the pattern itself. (See #59).- --- -- Con{} desugars down to Con _ ... _.- = return $ replicate (length fields) DWildP- | otherwise = lift $ impossible- $ "Record syntax used with non-record constructor "- ++ (show con_name) ++ "."--dsPat (ListP pats) = go pats- where go [] = return $ DConP '[] [] []- go (h : t) = do- h' <- dsPat h- t' <- go t- return $ DConP '(:) [] [h', t']-dsPat (SigP pat ty) = DSigP <$> dsPat pat <*> dsType ty-#if __GLASGOW_HASKELL__ >= 801-dsPat (UnboxedSumP pat alt arity) =- DConP (unboxedSumDataName alt arity) [] <$> ((:[]) <$> dsPat pat)-#endif-dsPat (ViewP _ _) =- fail "View patterns are not supported in th-desugar. Use pattern guards instead."---- | Convert a 'DPat' to a 'DExp'. Fails on 'DWildP'.-dPatToDExp :: DPat -> DExp-dPatToDExp (DLitP lit) = DLitE lit-dPatToDExp (DVarP name) = DVarE name-dPatToDExp (DConP name tys pats) = foldl DAppE (foldl DAppTypeE (DConE name) tys) (map dPatToDExp pats)-dPatToDExp (DTildeP pat) = dPatToDExp pat-dPatToDExp (DBangP pat) = dPatToDExp pat-dPatToDExp (DSigP pat ty) = DSigE (dPatToDExp pat) ty-dPatToDExp DWildP = error "Internal error in th-desugar: wildcard in rhs of as-pattern"---- | Remove all wildcards from a pattern, replacing any wildcard with a fresh--- variable-removeWilds :: DsMonad q => DPat -> q DPat-removeWilds p@(DLitP _) = return p-removeWilds p@(DVarP _) = return p-removeWilds (DConP con_name tys pats) = DConP con_name tys <$> mapM removeWilds pats-removeWilds (DTildeP pat) = DTildeP <$> removeWilds pat-removeWilds (DBangP pat) = DBangP <$> removeWilds pat-removeWilds (DSigP pat ty) = DSigP <$> removeWilds pat <*> pure ty-removeWilds DWildP = DVarP <$> newUniqueName "wild"---- | Desugar @Info@-dsInfo :: DsMonad q => Info -> q DInfo-dsInfo (ClassI dec instances) = do- [ddec] <- dsDec dec- dinstances <- dsDecs instances- return $ DTyConI ddec (Just dinstances)-dsInfo (ClassOpI name ty parent) =- DVarI name <$> dsType ty <*> pure (Just parent)-dsInfo (TyConI dec) = do- [ddec] <- dsDec dec- return $ DTyConI ddec Nothing-dsInfo (FamilyI dec instances) = do- [ddec] <- dsDec dec- dinstances <- dsDecs instances- return $ DTyConI ddec (Just dinstances)-dsInfo (PrimTyConI name arity unlifted) =- return $ DPrimTyConI name arity unlifted-dsInfo (DataConI name ty parent) =- DVarI name <$> dsType ty <*> pure (Just parent)-dsInfo (VarI name ty Nothing) =- DVarI name <$> dsType ty <*> pure Nothing-dsInfo (VarI name _ (Just _)) =- impossible $ "Declaration supplied with variable: " ++ show name-dsInfo (TyVarI name ty) = DTyVarI name <$> dsType ty-#if __GLASGOW_HASKELL__ >= 801-dsInfo (PatSynI name ty) = DPatSynI name <$> dsType ty-#endif---- | Desugar arbitrary @Dec@s-dsDecs :: DsMonad q => [Dec] -> q [DDec]-dsDecs = concatMapM dsDec---- | Desugar a single @Dec@, perhaps producing multiple 'DDec's-dsDec :: DsMonad q => Dec -> q [DDec]-dsDec d@(FunD {}) = dsTopLevelLetDec d-dsDec d@(ValD {}) = dsTopLevelLetDec d-dsDec (DataD cxt n tvbs mk cons derivings) =- dsDataDec Data cxt n tvbs mk cons derivings-dsDec (NewtypeD cxt n tvbs mk con derivings) =- dsDataDec Newtype cxt n tvbs mk [con] derivings-dsDec (TySynD n tvbs ty) =- (:[]) <$> (DTySynD n <$> mapM dsTvbUnit tvbs <*> dsType ty)-dsDec (ClassD cxt n tvbs fds decs) =- (:[]) <$> (DClassD <$> dsCxt cxt <*> pure n <*> mapM dsTvbUnit tvbs- <*> pure fds <*> dsDecs decs)-dsDec (InstanceD over cxt ty decs) =- (:[]) <$> (DInstanceD over Nothing <$> dsCxt cxt <*> dsType ty <*> dsDecs decs)-dsDec d@(SigD {}) = dsTopLevelLetDec d-dsDec (ForeignD f) = (:[]) <$> (DForeignD <$> dsForeign f)-dsDec d@(InfixD {}) = dsTopLevelLetDec d-dsDec d@(PragmaD {}) = dsTopLevelLetDec d-dsDec (OpenTypeFamilyD tfHead) =- (:[]) <$> (DOpenTypeFamilyD <$> dsTypeFamilyHead tfHead)-dsDec (DataFamilyD n tvbs m_k) =- (:[]) <$> (DDataFamilyD n <$> mapM dsTvbUnit tvbs <*> mapM dsType m_k)-#if __GLASGOW_HASKELL__ >= 807-dsDec (DataInstD cxt mtvbs lhs mk cons derivings) =- case unfoldType lhs of- (ConT n, tys) -> dsDataInstDec Data cxt n mtvbs tys mk cons derivings- (_, _) -> fail $ "Unexpected data instance LHS: " ++ pprint lhs-dsDec (NewtypeInstD cxt mtvbs lhs mk con derivings) =- case unfoldType lhs of- (ConT n, tys) -> dsDataInstDec Newtype cxt n mtvbs tys mk [con] derivings- (_, _) -> fail $ "Unexpected newtype instance LHS: " ++ pprint lhs-#else-dsDec (DataInstD cxt n tys mk cons derivings) =- dsDataInstDec Data cxt n Nothing (map TANormal tys) mk cons derivings-dsDec (NewtypeInstD cxt n tys mk con derivings) =- dsDataInstDec Newtype cxt n Nothing (map TANormal tys) mk [con] derivings-#endif-#if __GLASGOW_HASKELL__ >= 807-dsDec (TySynInstD eqn) = (:[]) <$> (DTySynInstD <$> dsTySynEqn unusedArgument eqn)-#else-dsDec (TySynInstD n eqn) = (:[]) <$> (DTySynInstD <$> dsTySynEqn n eqn)-#endif-dsDec (ClosedTypeFamilyD tfHead eqns) =- (:[]) <$> (DClosedTypeFamilyD <$> dsTypeFamilyHead tfHead- <*> mapM (dsTySynEqn (typeFamilyHeadName tfHead)) eqns)-dsDec (RoleAnnotD n roles) = return [DRoleAnnotD n roles]-#if __GLASGOW_HASKELL__ >= 801-dsDec (PatSynD n args dir pat) = do- dir' <- dsPatSynDir n dir- (pat', vars) <- dsPatX pat- unless (null vars) $- fail $ "Pattern synonym definition cannot contain as-patterns (@)."- return [DPatSynD n args dir' pat']-dsDec (PatSynSigD n ty) = (:[]) <$> (DPatSynSigD n <$> dsType ty)-dsDec (StandaloneDerivD mds cxt ty) =- (:[]) <$> (DStandaloneDerivD <$> mapM dsDerivStrategy mds- <*> pure Nothing <*> dsCxt cxt <*> dsType ty)-#else-dsDec (StandaloneDerivD cxt ty) =- (:[]) <$> (DStandaloneDerivD Nothing Nothing <$> dsCxt cxt <*> dsType ty)-#endif-dsDec (DefaultSigD n ty) = (:[]) <$> (DDefaultSigD n <$> dsType ty)-#if __GLASGOW_HASKELL__ >= 807-dsDec (ImplicitParamBindD {}) = impossible "Non-`let`-bound implicit param binding"-#endif-#if __GLASGOW_HASKELL__ >= 809-dsDec (KiSigD n ki) = (:[]) <$> (DKiSigD n <$> dsType ki)-#endif-#if __GLASGOW_HASKELL__ >= 903-dsDec (DefaultD tys) = (:[]) <$> (DDefaultD <$> mapM dsType tys)-#endif---- | Desugar a 'DataD' or 'NewtypeD'.-dsDataDec :: DsMonad q- => NewOrData -> Cxt -> Name -> [TyVarBndrUnit]- -> Maybe Kind -> [Con] -> [DerivingClause] -> q [DDec]-dsDataDec nd cxt n tvbs mk cons derivings = do- tvbs' <- mapM dsTvbUnit tvbs- let h98_tvbs = case mk of- -- If there's an explicit return kind, we're dealing with a- -- GADT, so this argument goes unused in dsCon.- Just {} -> unusedArgument- Nothing -> tvbs'- h98_return_type = nonFamilyDataReturnType n tvbs'- (:[]) <$> (DDataD nd <$> dsCxt cxt <*> pure n- <*> pure tvbs' <*> mapM dsType mk- <*> concatMapM (dsCon h98_tvbs h98_return_type) cons- <*> mapM dsDerivClause derivings)---- | Desugar a 'DataInstD' or a 'NewtypeInstD'.-dsDataInstDec :: DsMonad q- => NewOrData -> Cxt -> Name -> Maybe [TyVarBndrUnit] -> [TypeArg]- -> Maybe Kind -> [Con] -> [DerivingClause] -> q [DDec]-dsDataInstDec nd cxt n mtvbs tys mk cons derivings = do- mtvbs' <- mapM (mapM dsTvbUnit) mtvbs- tys' <- mapM dsTypeArg tys- let lhs' = applyDType (DConT n) tys'- h98_tvbs =- case (mk, mtvbs') of- -- If there's an explicit return kind, we're dealing with a- -- GADT, so this argument goes unused in dsCon.- (Just {}, _) -> unusedArgument- -- H98, and there is an explicit `forall` in front. Just reuse the- -- type variable binders from the `forall`.- (Nothing, Just tvbs') -> tvbs'- -- H98, and no explicit `forall`. Compute the bound variables- -- manually.- (Nothing, Nothing) -> dataFamInstTvbs tys'- h98_fam_inst_type = dataFamInstReturnType n tys'- (:[]) <$> (DDataInstD nd <$> dsCxt cxt <*> pure mtvbs'- <*> pure lhs' <*> mapM dsType mk- <*> concatMapM (dsCon h98_tvbs h98_fam_inst_type) cons- <*> mapM dsDerivClause derivings)---- | Desugar a @FamilyResultSig@-dsFamilyResultSig :: DsMonad q => FamilyResultSig -> q DFamilyResultSig-dsFamilyResultSig NoSig = return DNoSig-dsFamilyResultSig (KindSig k) = DKindSig <$> dsType k-dsFamilyResultSig (TyVarSig tvb) = DTyVarSig <$> dsTvbUnit tvb---- | Desugar a @TypeFamilyHead@-dsTypeFamilyHead :: DsMonad q => TypeFamilyHead -> q DTypeFamilyHead-dsTypeFamilyHead (TypeFamilyHead n tvbs result inj)- = DTypeFamilyHead n <$> mapM dsTvbUnit tvbs- <*> dsFamilyResultSig result- <*> pure inj--typeFamilyHeadName :: TypeFamilyHead -> Name-typeFamilyHeadName (TypeFamilyHead n _ _ _) = n---- | Desugar @Dec@s that can appear in a @let@ expression. See the--- documentation for 'dsLetDec' for an explanation of what the return type--- represents.-dsLetDecs :: DsMonad q => [Dec] -> q ([DLetDec], DExp -> DExp)-dsLetDecs decs = do- (let_decss, ip_binders) <- mapAndUnzipM dsLetDec decs- let let_decs :: [DLetDec]- let_decs = concat let_decss-- ip_binder :: DExp -> DExp- ip_binder = foldr (.) id ip_binders- return (let_decs, ip_binder)---- | Desugar a single 'Dec' that can appear in a @let@ expression.--- This produces the following output:------ * One or more 'DLetDec's (a single 'Dec' can produce multiple 'DLetDec's--- in the event of a value declaration that binds multiple things by way--- of pattern matching.------ * A function of type @'DExp' -> 'DExp'@, which should be applied to the--- expression immediately following the 'DLetDec's. This function prepends--- binding forms for any implicit params that were bound in the argument--- 'Dec'. (If no implicit params are bound, this is simply the 'id'--- function.)------ For instance, if the argument to 'dsLetDec' is the @?x = 42@ part of this--- expression:------ @--- let { ?x = 42 } in ?x--- @------ Then the output is:------ * @let new_x_val = 42@------ * @\\z -> 'bindIP' \@\"x\" new_x_val z@------ This way, the expression--- @let { new_x_val = 42 } in 'bindIP' \@"x" new_x_val ('ip' \@\"x\")@ can be--- formed. The implicit param binders always come after all the other--- 'DLetDec's to support parallel assignment of implicit params.-dsLetDec :: DsMonad q => Dec -> q ([DLetDec], DExp -> DExp)-dsLetDec (FunD name clauses) = do- clauses' <- dsClauses (FunRhs name) clauses- return ([DFunD name clauses'], id)-dsLetDec (ValD pat body where_decs) = do- (pat', vars) <- dsPatX pat- body' <- dsBody body where_decs error_exp- let extras = uncurry (zipWith (DValD . DVarP)) $ unzip vars- return (DValD pat' body' : extras, id)- where- error_exp = mkErrorMatchExpr (LetDecRhs pat)-dsLetDec (SigD name ty) = do- ty' <- dsType ty- return ([DSigD name ty'], id)-dsLetDec (InfixD fixity name) = return ([DInfixD fixity name], id)-dsLetDec (PragmaD prag) = do- prag' <- dsPragma prag- return ([DPragmaD prag'], id)-#if __GLASGOW_HASKELL__ >= 807-dsLetDec (ImplicitParamBindD n e) = do- new_n_name <- qNewName $ "new_" ++ n ++ "_val"- e' <- dsExp e- let let_dec :: DLetDec- let_dec = DValD (DVarP new_n_name) e'-- ip_binder :: DExp -> DExp- ip_binder = (DVarE 'bindIP `DAppTypeE`- DLitT (StrTyLit n) `DAppE`- DVarE new_n_name `DAppE`)- return ([let_dec], ip_binder)-#endif-dsLetDec _dec = impossible "Illegal declaration in let expression."---- | Desugar a single 'Dec' corresponding to something that could appear after--- the @let@ in a @let@ expression, but occurring at the top level. Because the--- 'Dec' occurs at the top level, there is nothing that would correspond to the--- @in ...@ part of the @let@ expression. As a consequence, this function does--- not return a @'DExp' -> 'DExp'@ function corresonding to implicit param--- binders (these cannot occur at the top level).-dsTopLevelLetDec :: DsMonad q => Dec -> q [DDec]-dsTopLevelLetDec = fmap (map DLetDec . fst) . dsLetDec- -- Note the use of fst above: we're silently throwing away any implicit param- -- binders that dsLetDec returns, since there is invariant that there will be- -- no implicit params in the first place.---- | 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- => [DTyVarBndrUnit] -- ^ 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- expl_dtvbs = changeDTVFlags SpecifiedSpec univ_dtvbs ++- ex_dtvbs- impl_dtvbs = changeDTVFlags SpecifiedSpec $- toposortTyVarsOf $ mapMaybe extractTvbKind expl_dtvbs in- DCon (impl_dtvbs ++ expl_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, [DTyVarBndrSpec], 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 [(n, [], [], DNormalC True [dty1, dty2], Nothing)]-dsCon' (ForallC tvbs cxt con) = do- dtvbs <- mapM dsTvbSpec tvbs- dcxt <- dsCxt cxt- dcons' <- dsCon' con- return $ flip map dcons' $ \(n, dtvbs', dcxt', fields, m_gadt_type) ->- (n, dtvbs ++ dtvbs', dcxt ++ dcxt', fields, m_gadt_type)-dsCon' (GadtC nms btys rty) = do- dbtys <- mapM dsBangType btys- drty <- dsType rty- sequence $ flip map nms $ \nm -> do- mbFi <- reifyFixityWithLocals nm- -- A GADT data constructor is declared infix when these three- -- properties hold:- let decInfix = isInfixDataCon (nameBase nm) -- 1. Its name uses operator syntax- -- (e.g., (:*:))- && length dbtys == 2 -- 2. It has exactly two fields- && isJust mbFi -- 3. It has a programmer-specified- -- fixity declaration- 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 ->- (nm, [], [], DRecC dvbtys, Just drty)---- | Desugar a @BangType@.-dsBangType :: DsMonad q => BangType -> q DBangType-dsBangType (b, ty) = (b, ) <$> dsType ty---- | Desugar a @VarBangType@.-dsVarBangType :: DsMonad q => VarBangType -> q DVarBangType-dsVarBangType (n, b, ty) = (n, b, ) <$> dsType ty---- | Desugar a @Foreign@.-dsForeign :: DsMonad q => Foreign -> q DForeign-dsForeign (ImportF cc safety str n ty) = DImportF cc safety str n <$> dsType ty-dsForeign (ExportF cc str n ty) = DExportF cc str n <$> dsType ty---- | Desugar a @Pragma@.-dsPragma :: DsMonad q => Pragma -> q DPragma-dsPragma (InlineP n inl rm phases) = return $ DInlineP n inl rm phases-dsPragma (SpecialiseP n ty m_inl phases) = DSpecialiseP n <$> dsType ty- <*> pure m_inl- <*> pure phases-dsPragma (SpecialiseInstP ty) = DSpecialiseInstP <$> dsType ty-#if __GLASGOW_HASKELL__ >= 807-dsPragma (RuleP str mtvbs rbs lhs rhs phases)- = DRuleP str <$> mapM (mapM dsTvbUnit) mtvbs- <*> mapM dsRuleBndr rbs- <*> dsExp lhs- <*> dsExp rhs- <*> pure phases-#else-dsPragma (RuleP str rbs lhs rhs phases) = DRuleP str Nothing- <$> mapM dsRuleBndr rbs- <*> dsExp lhs- <*> dsExp rhs- <*> pure phases-#endif-dsPragma (AnnP target exp) = DAnnP target <$> dsExp exp-dsPragma (LineP n str) = return $ DLineP n str-#if __GLASGOW_HASKELL__ >= 801-dsPragma (CompleteP cls mty) = return $ DCompleteP cls mty-#endif-#if __GLASGOW_HASKELL__ >= 903-dsPragma (OpaqueP n) = return $ DOpaqueP n-#endif---- | Desugar a @RuleBndr@.-dsRuleBndr :: DsMonad q => RuleBndr -> q DRuleBndr-dsRuleBndr (RuleVar n) = return $ DRuleVar n-dsRuleBndr (TypedRuleVar n ty) = DTypedRuleVar n <$> dsType ty--#if __GLASGOW_HASKELL__ >= 807--- | Desugar a @TySynEqn@. (Available only with GHC 7.8+)------ This requires a 'Name' as an argument since 'TySynEqn's did not have--- this information prior to GHC 8.8.-dsTySynEqn :: DsMonad q => Name -> TySynEqn -> q DTySynEqn-dsTySynEqn _ (TySynEqn mtvbs lhs rhs) =- DTySynEqn <$> mapM (mapM dsTvbUnit) mtvbs <*> dsType lhs <*> dsType rhs-#else--- | Desugar a @TySynEqn@. (Available only with GHC 7.8+)-dsTySynEqn :: DsMonad q => Name -> TySynEqn -> q DTySynEqn-dsTySynEqn n (TySynEqn lhss rhs) = do- lhss' <- mapM dsType lhss- let lhs' = applyDType (DConT n) $ map DTANormal lhss'- DTySynEqn Nothing lhs' <$> dsType rhs-#endif---- | Desugar clauses to a function definition-dsClauses :: DsMonad q- => MatchContext -- ^ The context in which the clauses arise- -> [Clause] -- ^ Clauses to desugar- -> q [DClause]-dsClauses _ [] = return []-dsClauses mc (Clause pats (NormalB exp) where_decs : rest) = do- -- this case is necessary to maintain the roundtrip property.- rest' <- dsClauses mc rest- exp' <- dsExp exp- (where_decs', ip_binder) <- dsLetDecs where_decs- let exp_with_wheres = maybeDLetE where_decs' (ip_binder exp')- (pats', exp'') <- dsPatsOverExp pats exp_with_wheres- return $ DClause pats' exp'' : rest'-dsClauses mc clauses@(Clause outer_pats _ _ : _) = do- arg_names <- replicateM (length outer_pats) (newUniqueName "arg")- let scrutinee = mkUnboxedTupleDExp (map DVarE arg_names)- clause <- DClause (map DVarP arg_names) <$>- (DCaseE scrutinee <$> foldrM (clause_to_dmatch scrutinee) [] clauses)- return [clause]- where- clause_to_dmatch :: DsMonad q => DExp -> Clause -> [DMatch] -> q [DMatch]- clause_to_dmatch scrutinee (Clause pats body where_decs) failure_matches = do- let failure_exp = maybeDCaseE mc scrutinee failure_matches- exp <- dsBody body where_decs failure_exp- (pats', exp') <- dsPatsOverExp pats exp- uni_pats <- fmap getAll $ concatMapM (fmap All . isUniversalPattern) pats'- let match = DMatch (mkUnboxedTupleDPat pats') exp'- if uni_pats- then return [match]- else return (match : failure_matches)---- | The context of a pattern match. This is used to produce--- @Non-exhaustive patterns in...@ messages that are tailored to specific--- situations. Compare this to GHC's @HsMatchContext@ data type--- (https://gitlab.haskell.org/ghc/ghc/-/blob/81cf52bb301592ff3d043d03eb9a0d547891a3e1/compiler/Language/Haskell/Syntax/Expr.hs#L1662-1695),--- from which the @MatchContext@ data type takes inspiration.-data MatchContext- = FunRhs Name- -- ^ A pattern matching on an argument of a function binding- | LetDecRhs Pat- -- ^ A pattern in a @let@ declaration- | RecUpd- -- ^ A record update- | MultiWayIfAlt- -- ^ Guards in a multi-way if alternative- | CaseAlt- -- ^ Patterns and guards in a case alternative---- | Construct an expression that throws an error when encountering a pattern--- at runtime that is not covered by pattern matching.-mkErrorMatchExpr :: MatchContext -> DExp-mkErrorMatchExpr mc =- DAppE (DVarE 'error) (DLitE (StringL ("Non-exhaustive patterns in " ++ pp_context)))- where- pp_context =- case mc of- FunRhs n -> show n- LetDecRhs pat -> pprint pat- RecUpd -> "record update"- MultiWayIfAlt -> "multi-way if"- CaseAlt -> "case"---- | Desugar a type-dsType :: DsMonad q => Type -> q DType-#if __GLASGOW_HASKELL__ >= 900--- See Note [Gracefully handling linear types]-dsType (MulArrowT `AppT` _) = return DArrowT-dsType MulArrowT = fail "Cannot desugar exotic uses of linear types."-#endif-dsType (ForallT tvbs preds ty) =- mkDForallConstrainedT <$> (DForallInvis <$> mapM dsTvbSpec tvbs)- <*> dsCxt preds <*> dsType ty-dsType (AppT t1 t2) = DAppT <$> dsType t1 <*> dsType t2-dsType (SigT ty ki) = DSigT <$> dsType ty <*> dsType ki-dsType (VarT name) = return $ DVarT name-dsType (ConT name) = return $ DConT name--- The PromotedT case is identical to the ConT case above.--- See Note [Desugaring promoted types].-dsType (PromotedT name) = return $ DConT name-dsType (TupleT n) = return $ DConT (tupleTypeName n)-dsType (UnboxedTupleT n) = return $ DConT (unboxedTupleTypeName n)-dsType ArrowT = return DArrowT-dsType ListT = return $ DConT ''[]-dsType (PromotedTupleT n) = return $ DConT (tupleDataName n)-dsType PromotedNilT = return $ DConT '[]-dsType PromotedConsT = return $ DConT '(:)-dsType StarT = return $ DConT typeKindName-dsType ConstraintT = return $ DConT ''Constraint-dsType (LitT lit) = return $ DLitT lit-dsType EqualityT = return $ DConT ''(~)-dsType (InfixT t1 n t2) = dsInfixT t1 n t2-dsType (UInfixT{}) = dsUInfixT-dsType (ParensT t) = dsType t-dsType WildCardT = return DWildCardT-#if __GLASGOW_HASKELL__ >= 801-dsType (UnboxedSumT arity) = return $ DConT (unboxedSumTypeName arity)-#endif-#if __GLASGOW_HASKELL__ >= 807-dsType (AppKindT t k) = DAppKindT <$> dsType t <*> dsType k-dsType (ImplicitParamT n t) = do- t' <- dsType t- return $ DConT ''IP `DAppT` DLitT (StrTyLit n) `DAppT` t'-#endif-#if __GLASGOW_HASKELL__ >= 809-dsType (ForallVisT tvbs ty) =- DForallT <$> (DForallVis <$> mapM dsTvbUnit tvbs) <*> dsType ty-#endif-#if __GLASGOW_HASKELL__ >= 903--- The PromotedInfixT case is identical to the InfixT case above.--- See Note [Desugaring promoted types].-dsType (PromotedInfixT t1 n t2) = dsInfixT t1 n t2-dsType PromotedUInfixT{} = dsUInfixT-#endif--#if __GLASGOW_HASKELL__ >= 900--- | Desugar a 'TyVarBndr'.-dsTvb :: DsMonad q => TyVarBndr_ flag -> q (DTyVarBndr flag)-dsTvb (PlainTV n flag) = return $ DPlainTV n flag-dsTvb (KindedTV n flag k) = DKindedTV n flag <$> dsType k-#else--- | Desugar a 'TyVarBndr' with a particular @flag@.-dsTvb :: DsMonad q => flag -> TyVarBndr -> q (DTyVarBndr flag)-dsTvb flag (PlainTV n) = return $ DPlainTV n flag-dsTvb flag (KindedTV n k) = DKindedTV n flag <$> dsType k-#endif--{--Note [Gracefully handling linear types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Per the README, th-desugar does not currently support linear types.-Unfortunately, we cannot simply reject all occurrences of-multiplicity-polymorphic function arrows (i.e., MulArrowT), as it is possible-for "non-linear" code to contain them when reified. For example, the type of a-Haskell98 data constructor such as `Just` will be reified as-- a #-> Maybe a--In terms of the TH AST, that is:-- MulArrowT `AppT` PromotedConT 'One `AppT` VarT a `AppT` (ConT ''Maybe `AppT` VarT a)--Therefore, in order to desugar these sorts of types, we have to do *something*-with MulArrowT. The approach that th-desugar takes is to pretend that all-multiplicity-polymorphic function arrows are actually ordinary function arrows-(->) when desugaring types. In other words, whenever th-desugar sees-(MulArrowT `AppT` m), for any particular value of `m`, it will turn it into-DArrowT.--This approach is enough to gracefully handle most uses of MulArrowT, as TH-reification always generates MulArrowT applied to some particular multiplicity-(as of GHC 9.0, at least). It's conceivable that some wily user could manually-construct a TH AST containing MulArrowT in a different position, but since this-situation is rare, we simply throw an error in such cases.--We adopt a similar stance in L.H.TH.Desugar.Reify when locally reifying the-types of data constructors: since th-desugar doesn't currently support linear-types, we pretend as if MulArrowT does not exist. As a result, the type of-`Just` would be locally reified as `a -> Maybe a`, not `a #-> Maybe a`.--Note [Desugaring promoted types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-ConT and PromotedT both contain Names as a payload, the only difference being-that PromotedT is intended to refer exclusively to promoted data constructor-Names, while ConT can refer to both type and data constructor Names alike.--When desugaring a PromotedT, we make the assumption that the TH quoting-mechanism produced the correct Name and wrap the name in a DConT. In other-words, we desugar ConT and PromotedT identically. This assumption about-PromotedT may not always be correct, however. Consider this example:-- data a :+: b = Inl a | Inr b- data Exp a = ... | Exp :+: Exp--How should `PromotedT (mkName ":+:")` be desugared? Morally, it ought to be-desugared to a DConT that contains (:+:) the data constructor, not (:+:) the-type constructor. Deciding between the two is not always straightforward,-however. We could use the `lookupDataName` function to try and distinguish-between the two Names, but this may not necessarily work. This is because the-Name passed to `lookupDataName` could have its original module attached, which-may not be in scope.--Long story short: we make things simple (albeit slightly wrong) by desugaring-ConT and PromotedT identically. We'll wait for someone to complain about the-wrongness of this approach before researching a more accurate solution.--Note that the same considerations also apply to InfixT and PromotedInfixT,-which are also desugared identically.--}---- | Desugar an infix 'Type'.-dsInfixT :: DsMonad q => Type -> Name -> Type -> q DType-dsInfixT t1 n t2 = DAppT <$> (DAppT (DConT n) <$> dsType t1) <*> dsType t2---- | We cannot desugar unresolved infix operators, so fail if we encounter one.-dsUInfixT :: Fail.MonadFail m => m a-dsUInfixT = fail "Cannot desugar unresolved infix operators."---- | Desugar a 'TyVarBndrSpec'.-dsTvbSpec :: DsMonad q => TyVarBndrSpec -> q DTyVarBndrSpec-#if __GLASGOW_HASKELL__ >= 900-dsTvbSpec = dsTvb-#else-dsTvbSpec = dsTvb SpecifiedSpec-#endif---- | Desugar a 'TyVarBndrUnit'.-dsTvbUnit :: DsMonad q => TyVarBndrUnit -> q DTyVarBndrUnit-#if __GLASGOW_HASKELL__ >= 900-dsTvbUnit = dsTvb-#else-dsTvbUnit = dsTvb ()-#endif---- | Desugar a @Cxt@-dsCxt :: DsMonad q => Cxt -> q DCxt-dsCxt = concatMapM dsPred--#if __GLASGOW_HASKELL__ >= 801--- | A backwards-compatible type synonym for the thing representing a single--- derived class in a @deriving@ clause. (This is a @DerivClause@, @Pred@, or--- @Name@ depending on the GHC version.)-type DerivingClause = DerivClause---- | Desugar a @DerivingClause@.-dsDerivClause :: DsMonad q => DerivingClause -> q DDerivClause-dsDerivClause (DerivClause mds cxt) =- DDerivClause <$> mapM dsDerivStrategy mds <*> dsCxt cxt-#else-type DerivingClause = Pred--dsDerivClause :: DsMonad q => DerivingClause -> q DDerivClause-dsDerivClause p = DDerivClause Nothing <$> dsPred p-#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-dsPatSynDir _ ImplBidir = pure DImplBidir-dsPatSynDir n (ExplBidir clauses) = DExplBidir <$> dsClauses (FunRhs n) clauses-#endif---- | Desugar a @Pred@, flattening any internal tuples-dsPred :: DsMonad q => Pred -> q DCxt-dsPred t- | Just ts <- splitTuple_maybe t- = concatMapM dsPred ts-dsPred (ForallT tvbs cxt p) = dsForallPred tvbs cxt p-dsPred (AppT t1 t2) = do- [p1] <- dsPred t1 -- tuples can't be applied!- (:[]) <$> DAppT p1 <$> dsType t2-dsPred (SigT ty ki) = do- preds <- dsPred ty- case preds of- [p] -> (:[]) <$> DSigT p <$> dsType ki- other -> return other -- just drop the kind signature on a tuple.-dsPred (VarT n) = return [DVarT n]-dsPred (ConT n) = return [DConT n]-dsPred t@(PromotedT _) =- impossible $ "Promoted type seen as head of constraint: " ++ show t-dsPred (TupleT 0) = return [DConT (tupleTypeName 0)]-dsPred (TupleT _) =- impossible "Internal error in th-desugar in detecting tuple constraints."-dsPred t@(UnboxedTupleT _) =- impossible $ "Unboxed tuple seen as head of constraint: " ++ show t-dsPred ArrowT = impossible "Arrow seen as head of constraint."-dsPred ListT = impossible "List seen as head of constraint."-dsPred (PromotedTupleT _) =- impossible "Promoted tuple seen as head of constraint."-dsPred PromotedNilT = impossible "Promoted nil seen as head of constraint."-dsPred PromotedConsT = impossible "Promoted cons seen as head of constraint."-dsPred StarT = impossible "* seen as head of constraint."-dsPred ConstraintT =- impossible "The kind `Constraint' seen as head of constraint."-dsPred t@(LitT _) =- impossible $ "Type literal seen as head of constraint: " ++ show t-dsPred EqualityT = return [DConT ''(~)]-dsPred (InfixT t1 n t2) = (:[]) <$> dsInfixT t1 n t2-dsPred (UInfixT{}) = dsUInfixT-dsPred (ParensT t) = dsPred t-dsPred WildCardT = return [DWildCardT]-#if __GLASGOW_HASKELL__ >= 801-dsPred t@(UnboxedSumT {}) =- impossible $ "Unboxed sum seen as head of constraint: " ++ show t-#endif-#if __GLASGOW_HASKELL__ >= 807-dsPred (AppKindT t k) = do- [p] <- dsPred t- (:[]) <$> (DAppKindT p <$> dsType k)-dsPred (ImplicitParamT n t) = do- t' <- dsType t- return [DConT ''IP `DAppT` DLitT (StrTyLit n) `DAppT` t']-#endif-#if __GLASGOW_HASKELL__ >= 809-dsPred t@(ForallVisT {}) =- impossible $ "Visible dependent quantifier seen as head of constraint: " ++ show t-#endif-#if __GLASGOW_HASKELL__ >= 900-dsPred MulArrowT = impossible "Linear arrow seen as head of constraint."-#endif-#if __GLASGOW_HASKELL__ >= 903-dsPred t@PromotedInfixT{} =- impossible $ "Promoted infix type seen as head of constraint: " ++ show t-dsPred PromotedUInfixT{} = dsUInfixT-#endif---- | Desugar a quantified constraint.-dsForallPred :: DsMonad q => [TyVarBndrSpec] -> Cxt -> Pred -> q DCxt-dsForallPred tvbs cxt p = do- ps' <- dsPred p- case ps' of- [p'] -> (:[]) <$> (mkDForallConstrainedT <$>- (DForallInvis <$> mapM dsTvbSpec tvbs) <*> dsCxt cxt <*> pure p')- _ -> fail "Cannot desugar constraint tuples in the body of a quantified constraint"- -- See GHC #15334.---- | Like 'reify', but safer and desugared. Uses local declarations where--- available.-dsReify :: DsMonad q => Name -> q (Maybe DInfo)-dsReify = traverse dsInfo <=< reifyWithLocals_maybe---- | Like 'reifyType', but safer and desugared. Uses local declarations where--- available.-dsReifyType :: DsMonad q => Name -> q (Maybe DType)-dsReifyType = traverse dsType <=< reifyTypeWithLocals_maybe---- Given a list of `forall`ed type variable binders and a context, construct--- a DType using DForallT and DConstrainedT as appropriate. The phrase--- "as appropriate" is used because DConstrainedT will not be used if the--- context is empty, per Note [Desugaring and sweetening ForallT].-mkDForallConstrainedT :: DForallTelescope -> DCxt -> DType -> DType-mkDForallConstrainedT tele ctxt ty =- DForallT tele $ if null ctxt then ty else DConstrainedT ctxt ty---- create a list of expressions in the same order as the fields in the first argument--- 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 => Name -> [VarStrictType] -> [FieldExp] -> [DExp] -> q [DExp]-reorderFields = reorderFields' dsExp--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 DWildP)--reorderFields' :: (Applicative m, Fail.MonadFail m)- => (a -> m da)- -> Name -- ^ The name of the constructor (used for error reporting)- -> [VarStrictType] -> [(Name, a)]- -> [da] -> m [da]-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."---- mkTupleDExp, mkUnboxedTupleDExp, and friends construct tuples, avoiding the--- use of 1-tuples. These are used to create auxiliary tuple values when--- desugaring pattern-matching constructs to simpler forms.--- See Note [Auxiliary tuples in pattern matching].---- | Make a tuple 'DExp' from a list of 'DExp's. Avoids using a 1-tuple.-mkTupleDExp :: [DExp] -> DExp-mkTupleDExp [exp] = exp-mkTupleDExp exps = foldl DAppE (DConE $ tupleDataName (length exps)) exps---- | Make an unboxed tuple 'DExp' from a list of 'DExp's. Avoids using a 1-tuple.-mkUnboxedTupleDExp :: [DExp] -> DExp-mkUnboxedTupleDExp [exp] = exp-mkUnboxedTupleDExp exps = foldl DAppE (DConE $ unboxedTupleDataName (length exps)) exps---- | Make a tuple 'Exp' from a list of 'Exp's. Avoids using a 1-tuple.-mkTupleExp :: [Exp] -> Exp-mkTupleExp [exp] = exp-mkTupleExp exps = foldl AppE (ConE $ tupleDataName (length exps)) exps---- | Make an unboxed tuple 'Exp' from a list of 'Exp's. Avoids using a 1-tuple.-mkUnboxedTupleExp :: [Exp] -> Exp-mkUnboxedTupleExp [exp] = exp-mkUnboxedTupleExp exps = foldl AppE (ConE $ unboxedTupleDataName (length exps)) exps---- | Make a tuple 'DPat' from a list of 'DPat's. Avoids using a 1-tuple.-mkTupleDPat :: [DPat] -> DPat-mkTupleDPat [pat] = pat-mkTupleDPat pats = DConP (tupleDataName (length pats)) [] pats---- | Make an unboxed tuple 'DPat' from a list of 'DPat's. Avoids using a 1-tuple.-mkUnboxedTupleDPat :: [DPat] -> DPat-mkUnboxedTupleDPat [pat] = pat-mkUnboxedTupleDPat pats = DConP (unboxedTupleDataName (length pats)) [] pats---- | Is this pattern guaranteed to match?-isUniversalPattern :: DsMonad q => DPat -> q Bool-isUniversalPattern (DLitP {}) = return False-isUniversalPattern (DVarP {}) = return True-isUniversalPattern (DConP con_name _ pats) = do- data_name <- dataConNameToDataName con_name- (_tvbs, cons) <- getDataD "Internal error." data_name- if length cons == 1- then fmap and $ mapM isUniversalPattern pats- else return False-isUniversalPattern (DTildeP {}) = return True-isUniversalPattern (DBangP pat) = isUniversalPattern pat-isUniversalPattern (DSigP pat _) = isUniversalPattern pat-isUniversalPattern DWildP = return True---- | Apply one 'DExp' to a list of arguments-applyDExp :: DExp -> [DExp] -> DExp-applyDExp = foldl DAppE---- | Apply one 'DType' to a list of arguments-applyDType :: DType -> [DTypeArg] -> DType-applyDType = foldl apply- where- apply :: DType -> DTypeArg -> DType- apply f (DTANormal x) = f `DAppT` x- apply f (DTyArg x) = f `DAppKindT` x---- | An argument to a type, either a normal type ('DTANormal') or a visible--- kind application ('DTyArg').------ 'DTypeArg' does not appear directly in the @th-desugar@ AST, but it is--- useful when decomposing an application of a 'DType' to its arguments.-data DTypeArg- = DTANormal DType- | DTyArg DKind- deriving (Eq, Show, Data, Generic)---- | Desugar a 'TypeArg'.-dsTypeArg :: DsMonad q => TypeArg -> q DTypeArg-dsTypeArg (TANormal t) = DTANormal <$> dsType t-dsTypeArg (TyArg k) = DTyArg <$> dsType k---- | Filter the normal type arguments from a list of 'DTypeArg's.-filterDTANormals :: [DTypeArg] -> [DType]-filterDTANormals = mapMaybe getDTANormal- where- getDTANormal :: DTypeArg -> Maybe DType- getDTANormal (DTANormal t) = Just t- getDTANormal (DTyArg {}) = Nothing---- | Convert a 'DTyVarBndr' into a 'DType'-dTyVarBndrToDType :: DTyVarBndr flag -> DType-dTyVarBndrToDType (DPlainTV a _) = DVarT a-dTyVarBndrToDType (DKindedTV a _ k) = DVarT a `DSigT` k---- | Extract the underlying 'DType' or 'DKind' from a 'DTypeArg'. This forgets--- information about whether a type is a normal argument or not, so use with--- caution.-probablyWrongUnDTypeArg :: DTypeArg -> DType-probablyWrongUnDTypeArg (DTANormal t) = t-probablyWrongUnDTypeArg (DTyArg k) = k---- 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 -> [DTyVarBndrUnit] -> DType-nonFamilyDataReturnType con_name =- applyDType (DConT con_name) . map (DTANormal . dTyVarBndrToDType)---- Take a data family name and apply it to its argument types to form a--- data family instance DType.-dataFamInstReturnType :: Name -> [DTypeArg] -> DType-dataFamInstReturnType fam_name = applyDType (DConT fam_name)---- Data family instance declarations did not come equipped with a list of bound--- type variables until GHC 8.8 (and even then, it's optional whether the user--- provides them or not). This means that there are situations where we must--- reverse engineer this information ourselves from the list of type--- arguments. 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 :: [DTypeArg] -> [DTyVarBndrUnit]-dataFamInstTvbs = toposortTyVarsOf . map probablyWrongUnDTypeArg---- | Take a list of 'DType's, find their free variables, and sort them in--- reverse topological order to ensure that they are well scoped. In other--- words, the free variables are ordered such that:------ 1. Whenever an explicit kind signature of the form @(A :: K)@ is--- encountered, the free variables of @K@ will always appear to the left of--- the free variables of @A@ in the returned result.------ 2. The constraint in (1) notwithstanding, free variables will appear in--- left-to-right order of their original appearance.------ On older GHCs, this takes measures to avoid returning explicitly bound--- kind variables, which was not possible before @TypeInType@.-toposortTyVarsOf :: [DType] -> [DTyVarBndrUnit]-toposortTyVarsOf tys =- let freeVars :: [Name]- freeVars = F.toList $ foldMap fvDType tys-- varKindSigs :: Map Name DKind- varKindSigs = foldMap go_ty tys- where- go_ty :: DType -> Map Name DKind- go_ty (DForallT tele t) = go_tele tele (go_ty t)- go_ty (DConstrainedT ctxt t) = foldMap go_ty ctxt `mappend` go_ty t- go_ty (DAppT t1 t2) = go_ty t1 `mappend` go_ty t2- go_ty (DAppKindT t k) = go_ty t `mappend` go_ty k- go_ty (DSigT t k) =- let kSigs = go_ty k- in case t of- DVarT n -> M.insert n k kSigs- _ -> go_ty t `mappend` kSigs- go_ty (DVarT {}) = mempty- go_ty (DConT {}) = mempty- go_ty DArrowT = mempty- go_ty (DLitT {}) = mempty- go_ty DWildCardT = mempty-- go_tele :: DForallTelescope -> Map Name DKind -> Map Name DKind- go_tele (DForallVis tvbs) = go_tvbs tvbs- go_tele (DForallInvis tvbs) = go_tvbs tvbs-- go_tvbs :: [DTyVarBndr flag] -> Map Name DKind -> Map Name DKind- go_tvbs tvbs m = foldr go_tvb m tvbs-- go_tvb :: DTyVarBndr flag -> Map Name DKind -> Map Name DKind- go_tvb (DPlainTV n _) m = M.delete n m- go_tvb (DKindedTV n _ k) m = M.delete n m `mappend` go_ty k-- -- | Do a topological sort on a list of tyvars,- -- so that binders occur before occurrences- -- E.g. given [ a::k, k::*, b::k ]- -- it'll return a well-scoped list [ k::*, a::k, b::k ]- --- -- This is a deterministic sorting operation- -- (that is, doesn't depend on Uniques).- --- -- It is also meant to be stable: that is, variables should not- -- be reordered unnecessarily.- scopedSort :: [Name] -> [Name]- scopedSort = go [] []-- go :: [Name] -- already sorted, in reverse order- -> [Set Name] -- each set contains all the variables which must be placed- -- before the tv corresponding to the set; they are accumulations- -- of the fvs in the sorted tvs' kinds-- -- This list is in 1-to-1 correspondence with the sorted tyvars- -- INVARIANT:- -- all (\tl -> all (`isSubsetOf` head tl) (tail tl)) (tails fv_list)- -- That is, each set in the list is a superset of all later sets.- -> [Name] -- yet to be sorted- -> [Name]- go acc _fv_list [] = reverse acc- go acc fv_list (tv:tvs)- = go acc' fv_list' tvs- where- (acc', fv_list') = insert tv acc fv_list-- insert :: Name -- var to insert- -> [Name] -- sorted list, in reverse order- -> [Set Name] -- list of fvs, as above- -> ([Name], [Set Name]) -- augmented lists- insert tv [] [] = ([tv], [kindFVSet tv])- insert tv (a:as) (fvs:fvss)- | tv `S.member` fvs- , (as', fvss') <- insert tv as fvss- = (a:as', fvs `S.union` fv_tv : fvss')-- | otherwise- = (tv:a:as, fvs `S.union` fv_tv : fvs : fvss)- where- fv_tv = kindFVSet tv-- -- lists not in correspondence- insert _ _ _ = error "scopedSort"-- kindFVSet n =- maybe S.empty (OS.toSet . fvDType)- (M.lookup n varKindSigs)- ascribeWithKind n =- maybe (DPlainTV n ()) (DKindedTV n ()) (M.lookup n varKindSigs)-- in map ascribeWithKind $- scopedSort freeVars--dtvbName :: DTyVarBndr flag -> Name-dtvbName (DPlainTV n _) = n-dtvbName (DKindedTV n _ _) = n---- @mk_qual_do_name mb_mod orig_name@ will simply return @orig_name@ if--- @mb_mod@ is Nothing. If @mb_mod@ is @Just mod_@, then a new 'Name' will be--- returned that uses @mod_@ as the new module prefix. This is useful for--- emulating the behavior of the @QualifiedDo@ extension, which adds module--- prefixes to functions such as ('>>=') and ('>>').-mk_qual_do_name :: Maybe ModName -> Name -> Name-mk_qual_do_name mb_mod orig_name = case mb_mod of- Nothing -> orig_name- Just mod_ -> Name (OccName (nameBase orig_name)) (NameQ mod_)---- | Reconstruct an arrow 'DType' from its argument and result types.-ravelDType :: DFunArgs -> DType -> DType-ravelDType DFANil res = res-ravelDType (DFAForalls tele args) res = DForallT tele (ravelDType args res)-ravelDType (DFACxt cxt args) res = DConstrainedT cxt (ravelDType args res)-ravelDType (DFAAnon t args) res = DAppT (DAppT DArrowT t) (ravelDType args res)---- | Decompose a function 'DType' into its arguments (the 'DFunArgs') and its--- result type (the 'DType).-unravelDType :: DType -> (DFunArgs, DType)-unravelDType (DForallT tele ty) =- let (args, res) = unravelDType ty in- (DFAForalls tele args, res)-unravelDType (DConstrainedT cxt ty) =- let (args, res) = unravelDType ty in- (DFACxt cxt args, res)-unravelDType (DAppT (DAppT DArrowT t1) t2) =- let (args, res) = unravelDType t2 in- (DFAAnon t1 args, res)-unravelDType t = (DFANil, t)---- | The list of arguments in a function 'DType'.-data DFunArgs- = DFANil- -- ^ No more arguments.- | DFAForalls DForallTelescope DFunArgs- -- ^ A series of @forall@ed type variables followed by a dot (if- -- 'ForallInvis') or an arrow (if 'ForallVis'). For example,- -- the type variables @a1 ... an@ in @forall a1 ... an. r@.- | DFACxt DCxt DFunArgs- -- ^ A series of constraint arguments followed by @=>@. For example,- -- the @(c1, ..., cn)@ in @(c1, ..., cn) => r@.- | DFAAnon DType DFunArgs- -- ^ An anonymous argument followed by an arrow. For example, the @a@- -- in @a -> r@.- deriving (Eq, Show, Data, Generic)---- | A /visible/ function argument type (i.e., one that must be supplied--- explicitly in the source code). This is in contrast to /invisible/--- arguments (e.g., the @c@ in @c => r@), which are instantiated without--- the need for explicit user input.-data DVisFunArg- = DVisFADep DTyVarBndrUnit- -- ^ A visible @forall@ (e.g., @forall a -> a@).- | DVisFAAnon DType- -- ^ An anonymous argument followed by an arrow (e.g., @a -> r@).- deriving (Eq, Show, Data, Generic)---- | Filter the visible function arguments from a list of 'DFunArgs'.-filterDVisFunArgs :: DFunArgs -> [DVisFunArg]-filterDVisFunArgs DFANil = []-filterDVisFunArgs (DFAForalls tele args) =- case tele of- DForallVis tvbs -> map DVisFADep tvbs ++ args'- DForallInvis _ -> args'- where- args' = filterDVisFunArgs args-filterDVisFunArgs (DFACxt _ args) =- filterDVisFunArgs args-filterDVisFunArgs (DFAAnon t args) =- DVisFAAnon t:filterDVisFunArgs args---- | Decompose an applied type into its individual components. For example, this:------ @--- Proxy \@Type Char--- @------ would be unfolded to this:------ @--- ('DConT' ''Proxy, ['DTyArg' ('DConT' ''Type), 'DTANormal' ('DConT' ''Char)])--- @-unfoldDType :: DType -> (DType, [DTypeArg])-unfoldDType = go []- where- go :: [DTypeArg] -> DType -> (DType, [DTypeArg])- go acc (DForallT _ ty) = go acc ty- go acc (DAppT ty1 ty2) = go (DTANormal ty2:acc) ty1- go acc (DAppKindT ty ki) = go (DTyArg ki:acc) ty- go acc (DSigT ty _) = go acc ty- go acc ty = (ty, acc)---- | Extract the kind from a 'DTyVarBndr', if one is present.-extractTvbKind :: DTyVarBndr flag -> Maybe DKind-extractTvbKind (DPlainTV _ _) = Nothing-extractTvbKind (DKindedTV _ _ k) = Just k---- | Set the flag in a list of 'DTyVarBndr's. This is often useful in contexts--- where one needs to re-use a list of 'DTyVarBndr's from one flag setting to--- another flag setting. For example, in order to re-use the 'DTyVarBndr's bound--- by a 'DDataD' in a 'DForallT', one can do the following:------ @--- case x of--- 'DDataD' _ _ _ tvbs _ _ _ ->--- 'DForallT' ('DForallInvis' ('changeDTVFlags' 'SpecifiedSpec' tvbs)) ...--- @-changeDTVFlags :: newFlag -> [DTyVarBndr oldFlag] -> [DTyVarBndr newFlag]-changeDTVFlags new_flag = map (new_flag <$)---- | Some functions in this module only use certain arguments on particular--- versions of GHC. Other versions of GHC (that don't make use of those--- arguments) might need to conjure up those arguments out of thin air at the--- functions' call sites, so this function serves as a placeholder to use in--- those situations. (In other words, this is a slightly more informative--- version of 'undefined'.)-unusedArgument :: a-unusedArgument = error "Unused"--{--Note [Desugaring and sweetening ForallT]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The ForallT constructor from template-haskell is tremendously awkward. Because-ForallT contains both a list of type variable binders and constraint arguments,-ForallT expressions can be ambiguous when one of these lists is empty. For-example, consider this expression with no constraints:-- ForallT [PlainTV a] [] (VarT a)--What should this desugar to in th-desugar, which must maintain a clear-separation between type variable binders and constraints? There are two-possibilities:--1. DForallT DForallInvis [DPlainTV a] (DVarT a)- (i.e., forall a. a)-2. DForallT DForallInvis [DPlainTV a] (DConstrainedT [] (DVarT a))- (i.e., forall a. () => a)--Template Haskell generally drops these empty lists when splicing Template-Haskell expressions, so we would like to do the same in th-desugar to mimic-TH's behavior as closely as possible. However, there are some situations where-dropping empty lists of `forall`ed type variable binders can change the-semantics of a program. For instance, contrast `foo :: forall. a -> a` (which-is an error) with `foo :: a -> a` (which is fine). Therefore, we try to-preserve empty `forall`s to the best of our ability.--Here is an informal specification of how th-desugar should handle different sorts-of ambiguity. First, a specification for desugaring.-Let `tvbs` and `ctxt` be non-empty:--* `ForallT tvbs [] ty` should desugar to `DForallT DForallInvis tvbs ty`.-* `ForallT [] ctxt ty` should desguar to `DForallT DForallInvis [] (DConstrainedT ctxt ty)`.-* `ForallT [] [] ty` should desugar to `DForallT DForallInvis [] ty`.-* For all other cases, just straightforwardly desugar- `ForallT tvbs ctxt ty` to `DForallT DForallInvis tvbs (DConstraintedT ctxt ty)`.--For sweetening:--* `DForallT DForallInvis tvbs (DConstrainedT ctxt ty)` should sweeten to `ForallT tvbs ctxt ty`.-* `DForallT DForallInvis [] (DConstrainedT ctxt ty)` should sweeten to `ForallT [] ctxt ty`.-* `DForallT DForallInvis tvbs (DConstrainedT [] ty)` should sweeten to `ForallT tvbs [] ty`.-* `DForallT DForallInvis [] (DConstrainedT [] ty)` should sweeten to `ForallT [] [] ty`.-* For all other cases, just straightforwardly sweeten- `DForallT DForallInvis tvbs ty` to `ForallT tvbs [] ty` and- `DConstrainedT ctxt ty` to `ForallT [] ctxt ty`.--Note [Auxiliary tuples in pattern matching]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-th-desugar simplifies the overall treatment of pattern matching in two-notable ways:--1. Lambda expressions only bind variables and do not directly perform pattern- matching. For example, this:-- \True False -> ()-- Roughly desugars to:-- \x y -> case (x, y) of- (True, False) -> ()- _ -> error "Non-exhaustive patterns"-2. th-desugar does not have guards, as guards are desugared into pattern- matches. For example, this:-- f x y | True <- x- , False <- y- = ()-- Roughly desugars to:-- f x y = case (x, y) of- (True, False) -> ()- _ -> error "Non-exhaustive patterns"--In both of these examples, there are multiple expressions being matched on-simultaneously. When desugaring these examples to `case` expressions, we need a-construct that allows us to group these patterns together. Auxiliary tuples are-one way to accomplish this.--While this use of tuples works well when the arguments have lifted types, such-as Bool, it doesn't work when the arguments have unlifted types, such as Int#.-Imagine desugaring this lambda expression, for instance:-- \27# 42# -> ()--The approach above would desugar this to:-- \x y -> case (x, y) of- (27#, 42#) -> ()- _ -> error "Non-exhaustive patterns"--This will not typecheck, however, as we are using _lifted_ tuples, which-require their arguments to have lifted types. If we want to support unlifted-types, we need a different approach.--One idea that seems tempting at first is to create an auxiliary `let`-expression, e.g.,-- \x y ->- let aux 27# 42# = ()- in aux x y--This avoids having to use lifted tuples, but it creates a new problem: type-inference. In the general case, auxiliary `let` expressions aren't enough to-handle GADT pattern matches, such as in this example:-- data T a where- MkT :: Int -> T Int-- g :: T a -> T a -> a- g = \(MkT x1) (MkT x2) -> x1 + x2--If you desugar `g` to use an auxiliary `let` expression:-- g :: T a -> T a -> a- g = \t1 t2 ->- let aux (MkT x1) (MkT x2) = x1 + x2- in aux t1 t2--Then it will not typecheck. To make this work, you'd need to give `aux` a type-signature. Doing this in general is tantamount to performing type inference,-however, which is very challenging in a Template Haskell setting.--Another approach, which is what th-desugar currently uses, is to use auxiliary-_unboxed_ tuples. This is identical to the previous tuple approach, but with-slightly different syntax:-- \x y -> case (# x, y #) of- (# 27#, 42# #) -> ()- _ -> error "Non-exhaustive patterns"--Unboxed tuples can handle lifted and unlifted arguments alike, so it is capable-of handling all the examples above.--You might worry that this approach would require clients of th-desugar to-enable the UnboxedTuples extension in non-obvious places, but fortunately, this-is not the case. For one thing, all unboxed tuples produced by th-desugar would-be TH-generated, so we would bypass the need to enable UnboxedTuples to lex-unboxed tuple syntax. GHC's typechecker also imposes a requirement that-UnboxedTuples be enabled if a variable has an unboxed tuple type, but this-never happens in th-desugar by construction. It's possible that a future-version of GHC might be stricter about this, but it seems unlikely.--There are a couple of exceptions to the general rule that auxiliary binders-should be unboxed:--1. ParallelListComp is desugared using the `mzip` function, which returns a- lifted pair. As a result, the variables bound in a parallel list- comprehension must be lifted. This is a restriction which is inherited from- GHC itself—https://gitlab.haskell.org/ghc/ghc/-/merge_requests/7270.--2. Match flattening desugars lazy patterns that bind multiple variables to code- that extracts fields from tuples. For instance, this:-- data Pair a b = MkPair a b-- f :: Pair a b -> Pair b a- f ~(MkPair x y) = MkPair y x-- Desugars to this (roughly) when match-flattened:-- f :: Pair a b -> Pair b a- f p =- let tuple = case p of- MkPair x y -> (x, y)-- x = case tuple of- (x, _) -> x-- y = case tuple of- (_, y) -> x-- in MkPair y x-- One could imagine using an unboxed tuple here instead, but since the- intermediate `tuple` value would have an unboxed tuple this, this would- require users of match flattening to enable UnboxedTuples. Fortunately,- using unboxed tuples here isn't necessary, as GHC doesn't support binding- variables with unlifted types in lazy patterns anyway.+import Language.Haskell.TH hiding (Extension(..), match, clause, cxt)+import Language.Haskell.TH.Datatype.TyVarBndr+import Language.Haskell.TH.Syntax hiding (Extension(..), lift)++import Control.Monad hiding (forM_, mapM)+import qualified Control.Monad.Fail as Fail+import Control.Monad.Trans (MonadTrans(..))+import Control.Monad.Writer (MonadWriter(..), WriterT(..))+import Control.Monad.Zip+import Data.Data (Data)+import Data.Either (lefts)+import Data.Foldable as F hiding (concat, notElem)+import Data.Function (on)+import qualified Data.List as L+import qualified Data.Map as M+import Data.Map (Map)+import Data.Maybe (catMaybes, isJust, mapMaybe)+import Data.Monoid (All(..))+import qualified Data.Set as S+import Data.Set (Set)+import Data.Traversable++#if __GLASGOW_HASKELL__ >= 803+import GHC.OverloadedLabels ( fromLabel )+#endif++#if __GLASGOW_HASKELL__ >= 807+import GHC.Classes (IP(..))+#else+import qualified Language.Haskell.TH as LangExt (Extension(..))+#endif++#if __GLASGOW_HASKELL__ >= 902+import Data.List.NonEmpty (NonEmpty(..))+import GHC.Records (HasField(..))+#endif++import GHC.Exts+import GHC.Generics (Generic)++import Language.Haskell.TH.Desugar.AST+import Language.Haskell.TH.Desugar.FV+import qualified Language.Haskell.TH.Desugar.OSet as OS+import Language.Haskell.TH.Desugar.OSet (OSet)+import Language.Haskell.TH.Desugar.Util+import Language.Haskell.TH.Desugar.Reify+import Language.Haskell.TH.Desugar.Subst (DSubst, IgnoreKinds(..), matchTy)+import qualified Language.Haskell.TH.Desugar.Subst.Capturing as SC++-- | Desugar an expression+dsExp :: DsMonad q => Exp -> q DExp+dsExp (VarE n) = return $ DVarE n+dsExp (ConE n) = return $ DConE n+dsExp (LitE lit) = return $ DLitE lit+dsExp (AppE e1 e2) = DAppE <$> dsExp e1 <*> dsExp e2+dsExp (InfixE Nothing op Nothing) = dsExp op+dsExp (InfixE (Just lhs) op Nothing) = DAppE <$> (dsExp op) <*> (dsExp lhs)+dsExp (InfixE Nothing op (Just rhs)) = do+ lhsName <- newUniqueName "lhs"+ op' <- dsExp op+ rhs' <- dsExp rhs+ return $ dLamE [DVarP lhsName] (foldl DAppE op' [DVarE lhsName, rhs'])+dsExp (InfixE (Just lhs) op (Just rhs)) =+ DAppE <$> (DAppE <$> dsExp op <*> dsExp lhs) <*> dsExp rhs+dsExp (UInfixE _ _ _) =+ fail "Cannot desugar unresolved infix operators."+dsExp (ParensE exp) = dsExp exp+dsExp (LamE pats exp) = do+ exp' <- dsExp exp+ (pats', exp'') <- dsPatsOverExp pats exp'+ return $ dLamE pats' exp''+dsExp (LamCaseE matches) = do+ matches' <- dsMatches (LamCaseAlt LamCase) matches+ return $ dLamCaseE matches'+dsExp (TupE exps) = dsTup tupleDataName exps+dsExp (UnboxedTupE exps) = dsTup unboxedTupleDataName exps+dsExp (CondE e1 e2 e3) =+ dsExp (CaseE e1 [mkBoolMatch 'True e2, mkBoolMatch 'False e3])+ where+ mkBoolMatch :: Name -> Exp -> Match+ mkBoolMatch boolDataCon rhs =+ Match (ConP boolDataCon+#if __GLASGOW_HASKELL__ >= 901+ []+#endif+ []) (NormalB rhs) []+dsExp (MultiIfE guarded_exps) =+ let failure = mkErrorMatchExpr MultiWayIfAlt in+ dsGuards guarded_exps failure+dsExp (LetE decs exp) = do+ (decs', ip_binder) <- dsLetDecs decs+ exp' <- dsExp exp+ return $ DLetE decs' $ ip_binder exp'+dsExp (CaseE exp matches) = do+ exp' <- dsExp exp+ matches' <- dsMatches CaseAlt matches+ return $ dCaseE exp' matches'+#if __GLASGOW_HASKELL__ >= 900+dsExp (DoE mb_mod stmts) = dsDoStmts mb_mod stmts+#else+dsExp (DoE stmts) = dsDoStmts Nothing stmts+#endif+dsExp (CompE stmts) = dsComp stmts+dsExp (ArithSeqE (FromR exp)) = DAppE (DVarE 'enumFrom) <$> dsExp exp+dsExp (ArithSeqE (FromThenR exp1 exp2)) =+ DAppE <$> (DAppE (DVarE 'enumFromThen) <$> dsExp exp1) <*> dsExp exp2+dsExp (ArithSeqE (FromToR exp1 exp2)) =+ DAppE <$> (DAppE (DVarE 'enumFromTo) <$> dsExp exp1) <*> dsExp exp2+dsExp (ArithSeqE (FromThenToR e1 e2 e3)) =+ DAppE <$> (DAppE <$> (DAppE (DVarE 'enumFromThenTo) <$> dsExp e1) <*>+ dsExp e2) <*>+ dsExp e3+dsExp (ListE exps) = go exps+ where go [] = return $ DConE '[]+ go (h : t) = DAppE <$> (DAppE (DConE '(:)) <$> dsExp h) <*> go t+dsExp (SigE exp ty) = DSigE <$> dsExp exp <*> dsType ty+dsExp (RecConE con_name field_exps) = do+ con <- dataConNameToCon con_name+ reordered <- reorder con+ return $ foldl DAppE (DConE con_name) reordered+ where+ reorder con = case con of+ NormalC _name fields -> non_record fields+ InfixC field1 _name field2 -> non_record [field1, field2]+ RecC _name fields -> reorder_fields fields+ ForallC _ _ c -> reorder c+ GadtC _names fields _ret_ty -> non_record fields+ RecGadtC _names fields _ret_ty -> reorder_fields fields++ reorder_fields fields = reorderFields con_name fields field_exps+ (repeat $ DVarE 'undefined)++ non_record fields | null field_exps+ -- Special case: record construction is allowed for any+ -- constructor, regardless of whether the constructor+ -- actually was declared with records, provided that no+ -- records are given in the expression itself. (See #59).+ --+ -- Con{} desugars down to Con undefined ... undefined.+ = return $ replicate (length fields) $ DVarE 'undefined++ | otherwise =+ impossible $ "Record syntax used with non-record constructor "+ ++ (show con_name) ++ "."++dsExp (RecUpdE exp field_exps) = do+ -- here, we need to use one of the field names to find the tycon, somewhat dodgily+ first_name <- case field_exps of+ ((name, _) : _) -> return name+ _ -> impossible "Record update with no fields listed."+ info <- reifyWithLocals first_name+ applied_type <- case info of+ VarI _name ty _m_dec -> extract_first_arg ty+ _ -> impossible "Record update with an invalid field name."+ type_name <- extract_type_name applied_type+ (_, _, cons) <- getDataD "This seems to be an error in GHC." type_name+ let filtered_cons = filter_cons_with_names cons (map fst field_exps)+ exp' <- dsExp exp+ matches <- mapM con_to_dmatch filtered_cons+ let all_matches+ | length filtered_cons == length cons = matches+ | otherwise = matches ++ [error_match]+ return $ dCaseE exp' all_matches+ where+ extract_first_arg :: DsMonad q => Type -> q Type+ extract_first_arg (AppT (AppT ArrowT arg) _) = return arg+ extract_first_arg (ForallT _ _ t) = extract_first_arg t+ extract_first_arg (SigT t _) = extract_first_arg t+ extract_first_arg _ = impossible "Record selector not a function."++ extract_type_name :: DsMonad q => Type -> q Name+ extract_type_name (AppT t1 _) = extract_type_name t1+ extract_type_name (SigT t _) = extract_type_name t+ extract_type_name (ConT n) = return n+ extract_type_name _ = impossible "Record selector domain not a datatype."++ filter_cons_with_names cons field_names =+ filter has_names cons+ where+ args_contain_names args =+ let con_field_names = map fst_of_3 args in+ all (`elem` con_field_names) field_names++ has_names (RecC _con_name args) =+ args_contain_names args+ has_names (RecGadtC _con_name args _ret_ty) =+ args_contain_names args+ has_names (ForallC _ _ c) = has_names c+ has_names _ = False++ rec_con_to_dmatch con_name args = do+ let con_field_names = map fst_of_3 args+ field_var_names <- mapM (newUniqueName . nameBase) con_field_names+ DMatch (DConP con_name [] (map DVarP field_var_names)) <$>+ (foldl DAppE (DConE con_name) <$>+ (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+ -- We're assuming the GADT constructor has only one Name here, but since+ -- this constructor was reified, this assumption should always hold true.+ con_to_dmatch (RecGadtC [con_name] args _ret_ty) = rec_con_to_dmatch con_name args+ con_to_dmatch (ForallC _ _ c) = con_to_dmatch c+ con_to_dmatch _ = impossible "Internal error within th-desugar."++ error_match = DMatch DWildP (mkErrorMatchExpr RecUpd)++ fst_of_3 (x, _, _) = x+dsExp (StaticE exp) = DStaticE <$> dsExp exp+dsExp (UnboundVarE n) = return (DVarE n)+#if __GLASGOW_HASKELL__ >= 801+dsExp (AppTypeE exp ty) = DAppTypeE <$> dsExp exp <*> dsType ty+dsExp (UnboxedSumE exp alt arity) =+ DAppE (DConE $ unboxedSumDataName alt arity) <$> dsExp exp+#endif+#if __GLASGOW_HASKELL__ >= 803+dsExp (LabelE str) = return $ DVarE 'fromLabel `DAppTypeE` DLitT (StrTyLit str)+#endif+#if __GLASGOW_HASKELL__ >= 807+dsExp (ImplicitParamVarE n) = return $ DVarE 'ip `DAppTypeE` DLitT (StrTyLit n)+dsExp (MDoE {}) = fail "th-desugar currently does not support RecursiveDo"+#endif+#if __GLASGOW_HASKELL__ >= 902+dsExp (GetFieldE arg field) = DAppE (mkGetFieldProj field) <$> dsExp arg+dsExp (ProjectionE fields) =+ case fields of+ f :| fs -> return $ foldl' comp (mkGetFieldProj f) fs+ where+ comp :: DExp -> String -> DExp+ comp acc f = DVarE '(.) `DAppE` mkGetFieldProj f `DAppE` acc+#endif+#if __GLASGOW_HASKELL__ >= 903+dsExp (LamCasesE clauses) = DLamCasesE <$> dsClauses (LamCaseAlt LamCases) clauses+#endif+#if __GLASGOW_HASKELL__ >= 907+dsExp (TypedBracketE exp) = DTypedBracketE <$> dsExp exp+dsExp (TypedSpliceE exp) = DTypedSpliceE <$> dsExp exp+#endif+#if __GLASGOW_HASKELL__ >= 909+dsExp (TypeE ty) = DTypeE <$> dsType ty+#endif+#if __GLASGOW_HASKELL__ >= 911+dsExp (ForallE tvbs exp) =+ DForallE <$> (DForallInvis <$> mapM dsTvbSpec tvbs) <*> dsExp exp+dsExp (ForallVisE tvbs exp) =+ DForallE <$> (DForallVis <$> mapM dsTvbUnit tvbs) <*> dsExp exp+dsExp (ConstrainedE preds exp) =+ DConstrainedE <$> mapM dsExp preds <*> dsExp exp+#endif++#if __GLASGOW_HASKELL__ >= 809+dsTup :: DsMonad q => (Int -> Name) -> [Maybe Exp] -> q DExp+dsTup = ds_tup+#else+dsTup :: DsMonad q => (Int -> Name) -> [Exp] -> q DExp+dsTup tuple_data_name = ds_tup tuple_data_name . map Just+#endif++-- | Desugar a tuple (or tuple section) expression.+ds_tup :: forall q. DsMonad q+ => (Int -> Name) -- ^ Compute the 'Name' of a tuple (boxed or unboxed)+ -- data constructor from its arity.+ -> [Maybe Exp] -- ^ The tuple's subexpressions. 'Nothing' entries+ -- denote empty fields in a tuple section.+ -> q DExp+ds_tup tuple_data_name mb_exps = do+ section_exps <- mapM ds_section_exp mb_exps+ let section_vars = lefts section_exps+ tup_body = mk_tup_body section_exps+ pure $+ if null section_vars+ then tup_body -- If this isn't a tuple section, don't create a lambda.+ else dLamE (map DVarP section_vars) tup_body+ where+ -- If dealing with an empty field in a tuple section (Nothing), create a+ -- unique name and return Left. These names will be used to construct the+ -- lambda expression that it desugars to.+ -- (For example, `(,5)` desugars to `\ts -> (,) ts 5`.)+ --+ -- If dealing with a tuple subexpression (Just), desugar it and return+ -- Right.+ ds_section_exp :: Maybe Exp -> q (Either Name DExp)+ ds_section_exp = maybe (Left <$> qNewName "ts") (fmap Right . dsExp)++ mk_tup_body :: [Either Name DExp] -> DExp+ mk_tup_body section_exps =+ foldl' apply_tup_body (DConE $ tuple_data_name (length section_exps))+ section_exps++ apply_tup_body :: DExp -> Either Name DExp -> DExp+ apply_tup_body f (Left n) = f `DAppE` DVarE n+ apply_tup_body f (Right e) = f `DAppE` e++-- | Construct a 'DExp' value that is equivalent to writing a lambda expression.+-- Under the hood, this uses @\\cases@ ('DLamCasesE').+--+-- @'mkDLamEFromDPats' pats exp@ is equivalent to writing+-- @pure ('dLamE' pats exp)@. As such, 'mkDLamEFromDPats' is deprecated in favor+-- of 'dLamE', and 'mkDLamEFromDPats' will be removed in a future @th-desugar@+-- release.+mkDLamEFromDPats :: Quasi q => [DPat] -> DExp -> q DExp+mkDLamEFromDPats pats exp = pure $ dLamE pats exp+{-# DEPRECATED mkDLamEFromDPats "Use `dLamE` or `DLamCasesE` instead." #-}++#if __GLASGOW_HASKELL__ >= 902+mkGetFieldProj :: String -> DExp+mkGetFieldProj field = DVarE 'getField `DAppTypeE` DLitT (StrTyLit field)+#endif++-- | Desugar a list of matches for a @case@ or @\\case@ expression.+dsMatches :: DsMonad q+ => MatchContext -- ^ The context in which the matches arise+ -> [Match] -- ^ Matches of the @case@ or @\\case@ expression+ -> q [DMatch]+dsMatches _ [] = pure []+-- Include a special case for guard-less matches to make the desugared output+-- a little nicer. See Note [Desugaring clauses compactly (when possible)].+dsMatches mc (Match pat (NormalB exp) where_decs : rest) = do+ rest' <- dsMatches mc rest+ exp' <- dsExp exp+ (where_decs', ip_binder) <- dsLetDecs where_decs+ let exp_with_wheres = maybeDLetE where_decs' (ip_binder exp')+ (pats', exp'') <- dsPatOverExp pat exp_with_wheres+ pure $ DMatch pats' exp'' : rest'+dsMatches mc matches@(Match _ _ _ : _) = do+ scrutinee_name <- newUniqueName "scrutinee"+ let scrutinee = DVarE scrutinee_name+ matches' <- foldrM (ds_match scrutinee) [] matches+ pure [DMatch (DVarP scrutinee_name) (dCaseE scrutinee matches')]+ where+ ds_match :: DsMonad q => DExp -> Match -> [DMatch] -> q [DMatch]+ ds_match scrutinee (Match pat body where_decs) failure_matches = do+ let failure_exp = maybeDCaseE mc scrutinee failure_matches+ exp <- dsBody body where_decs failure_exp+ (pat', exp') <- dsPatOverExp pat exp+ uni_pattern <- isUniversalPattern pat' -- incomplete attempt at #6+ let match = DMatch pat' exp'+ if uni_pattern+ then return [match]+ else return (match : failure_matches)++-- | Desugar a @Body@+dsBody :: DsMonad q+ => Body -- ^ body to desugar+ -> [Dec] -- ^ "where" declarations+ -> DExp -- ^ what to do if the guards don't match+ -> q DExp+dsBody (NormalB exp) decs _ = do+ (decs', ip_binder) <- dsLetDecs decs+ exp' <- dsExp exp+ return $ maybeDLetE decs' $ ip_binder exp'+dsBody (GuardedB guarded_exps) decs failure = do+ (decs', ip_binder) <- dsLetDecs decs+ guarded_exp' <- dsGuards guarded_exps failure+ return $ maybeDLetE decs' $ ip_binder guarded_exp'++-- | Construct a 'DExp' value that is equivalent to writing a @case@ expression+-- that scrutinizes multiple values at once. Under the hood, this uses+-- @\\cases@ ('DLamCasesE'). For instance, given this code:+--+-- @+-- case (scrut_1, ..., scrut_n) of+-- (pat_1_1, ..., pat_1_n) -> rhs_1+-- ...+-- (pat_m_1, ..., pat_m_n) -> rhs_n+-- @+--+-- The following @\\cases@ expression will be created under the hood:+--+-- @+-- (\\cases+-- pat_1_1 ... pat_1_n -> rhs_1+-- ...+-- pat_m_1 ... pat_m_n -> rhs_n) scrut_1 ... scrut_n+-- @+--+-- In other words, this creates a 'DLamCasesE' value and then applies it to+-- argument values.+--+-- Preconditions:+--+-- * If the list of 'DClause's is non-empty, then the number of patterns in each+-- 'DClause' must be equal to the number of 'DExp' arguments.+--+-- * If the list of 'DClause's is empty, then there must be exactly one 'DExp'+-- argument.+dCasesE :: [DExp] -> [DClause] -> DExp+dCasesE scruts clauses = applyDExp (DLamCasesE clauses) scruts++-- | If decs is non-empty, delcare them in a let:+maybeDLetE :: [DLetDec] -> DExp -> DExp+maybeDLetE [] exp = exp+maybeDLetE decs exp = DLetE decs exp++-- | If matches is non-empty, make a case statement; otherwise make an error statement+maybeDCaseE :: MatchContext -> DExp -> [DMatch] -> DExp+maybeDCaseE mc _ [] = mkErrorMatchExpr mc+maybeDCaseE _ scrut matches = dCaseE scrut matches++-- | If the list of clauses is non-empty, make a @\\cases@ expression and apply+-- it using the expressions as arguments. Otherwise, make an error statement.+--+-- Precondition: if the list of 'DClause's is non-empty, then the number of+-- patterns in each 'DClause' must be equal to the number of 'DExp' arguments.+maybeDCasesE :: MatchContext -> [DExp] -> [DClause] -> DExp+maybeDCasesE mc _ [] = mkErrorMatchExpr mc+maybeDCasesE _ scruts clauses = dCasesE scruts clauses++-- | Desugar guarded expressions+dsGuards :: DsMonad q+ => [(Guard, Exp)] -- ^ Guarded expressions+ -> DExp -- ^ What to do if none of the guards match+ -> q DExp+dsGuards [] thing_inside = return thing_inside+dsGuards ((NormalG gd, exp) : rest) thing_inside =+ dsGuards ((PatG [NoBindS gd], exp) : rest) thing_inside+dsGuards ((PatG stmts, exp) : rest) thing_inside = do+ success <- dsExp exp+ failure <- dsGuards rest thing_inside+ dsGuardStmts stmts success failure++-- | Desugar the @Stmt@s in a guard+dsGuardStmts :: DsMonad q+ => [Stmt] -- ^ The @Stmt@s to desugar+ -> DExp -- ^ What to do if the @Stmt@s yield success+ -> DExp -- ^ What to do if the @Stmt@s yield failure+ -> q DExp+dsGuardStmts [] success _failure = return success+dsGuardStmts (BindS pat exp : rest) success failure = do+ success' <- dsGuardStmts rest success failure+ (pat', success'') <- dsPatOverExp pat success'+ exp' <- dsExp exp+ return $ dCaseE exp' [DMatch pat' success'', DMatch DWildP failure]+dsGuardStmts (LetS decs : rest) success failure = do+ (decs', ip_binder) <- dsLetDecs decs+ success' <- dsGuardStmts rest success failure+ return $ DLetE decs' $ ip_binder success'+ -- special-case a final pattern containing "otherwise" or "True"+ -- note that GHC does this special-casing, too, in DsGRHSs.isTrueLHsExpr+dsGuardStmts [NoBindS exp] success _failure+ | VarE name <- exp+ , name == 'otherwise+ = return success++ | ConE name <- exp+ , name == 'True+ = return success+dsGuardStmts (NoBindS exp : rest) success failure = do+ exp' <- dsExp exp+ success' <- dsGuardStmts rest success failure+ return $ dCaseE exp' [ DMatch (DConP 'True [] []) success'+ , DMatch (DConP 'False [] []) failure ]+dsGuardStmts (ParS _ : _) _ _ = impossible "Parallel comprehension in a pattern guard."+#if __GLASGOW_HASKELL__ >= 807+dsGuardStmts (RecS {} : _) _ _ = fail "th-desugar currently does not support RecursiveDo"+#endif++-- | Desugar the @Stmt@s in a @do@ expression+dsDoStmts :: forall q. DsMonad q => Maybe ModName -> [Stmt] -> q DExp+dsDoStmts mb_mod = go+ where+ go :: [Stmt] -> q DExp+ go [] = impossible "do-expression ended with something other than bare statement."+ go [NoBindS exp] = dsExp exp+ go (BindS pat exp : rest) = do+ rest' <- go rest+ dsBindS mb_mod exp pat rest' "do expression"+ go (LetS decs : rest) = do+ (decs', ip_binder) <- dsLetDecs decs+ rest' <- go rest+ return $ DLetE decs' $ ip_binder rest'+ go (NoBindS exp : rest) = do+ exp' <- dsExp exp+ rest' <- go rest+ let sequence_name = mk_qual_do_name mb_mod '(>>)+ return $ DAppE (DAppE (DVarE sequence_name) exp') rest'+ go (ParS _ : _) = impossible "Parallel comprehension in a do-statement."+#if __GLASGOW_HASKELL__ >= 807+ go (RecS {} : _) = fail "th-desugar currently does not support RecursiveDo"+#endif++-- | Desugar the @Stmt@s in a list or monad comprehension+dsComp :: DsMonad q => [Stmt] -> q DExp+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+ rest' <- dsComp rest+ dsBindS Nothing exp pat rest' "monad comprehension"+dsComp (LetS decs : rest) = do+ (decs', ip_binder) <- dsLetDecs decs+ rest' <- dsComp rest+ return $ DLetE decs' $ ip_binder rest'+dsComp (NoBindS exp : rest) = do+ exp' <- dsExp exp+ rest' <- dsComp rest+ return $ DAppE (DAppE (DVarE '(>>)) (DAppE (DVarE 'guard) exp')) rest'+dsComp (ParS stmtss : rest) = do+ (pat, exp) <- dsParComp stmtss+ rest' <- dsComp rest+ return $ DAppE (DAppE (DVarE '(>>=)) exp) (dLamE [pat] rest')+#if __GLASGOW_HASKELL__ >= 807+dsComp (RecS {} : _) = fail "th-desugar currently does not support RecursiveDo"+#endif++-- 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+ => Maybe ModName -> Exp -> Pat -> DExp -> String -> q DExp+dsBindS mb_mod 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' -- incomplete attempt at #6+ let bind_into = DAppE (DAppE (DVarE bind_name) bind_arg_exp')+ if is_univ_pat+ then return $ bind_into $ dLamE [success_pat'] success_exp'+ else do fail_name <- mk_fail_name+ return $ bind_into $ DLamCasesE+ [ DClause [success_pat'] success_exp'+ , DClause [DWildP] $+ DVarE fail_name `DAppE`+ DLitE (StringL $ "Pattern match failure in " ++ ctxt)+ ]+ where+ bind_name = mk_qual_do_name mb_mod '(>>=)++ mk_fail_name :: q Name+#if __GLASGOW_HASKELL__ >= 807+ -- GHC 8.8 deprecates the MonadFailDesugaring extension since its effects+ -- are always enabled. Furthermore, MonadFailDesugaring is no longer+ -- enabled by default, so simply use MonadFail.fail. (That happens to+ -- be the same as Prelude.fail in 8.8+.)+ mk_fail_name = return fail_MonadFail_name+#else+ mk_fail_name = do+ mfd <- qIsExtEnabled LangExt.MonadFailDesugaring+ return $ if mfd then fail_MonadFail_name else fail_Prelude_name+#endif++ fail_MonadFail_name = mk_qual_do_name mb_mod 'Fail.fail++#if __GLASGOW_HASKELL__ < 807+ fail_Prelude_name = mk_qual_do_name mb_mod 'Prelude.fail+#endif++-- | Desugar the contents of a parallel comprehension (enabled via the+-- @ParallelListComp@ language extension). For example, this expression:+--+-- @+-- [ x + y | x <- [1,2,3] | y <- [4,5,6] ]+-- @+--+-- Will be desugared to code that looks roughly like:+--+-- @+-- 'mzip' [1, 2, 3] [4, 5, 6] '>>=' \\cases (x, y) -> 'return' (x + y)+-- @+--+-- This function returns a 'DPat' containing a tuple of all bound variables and+-- a 'DExp' to produce the values for those variables.+dsParComp :: DsMonad q => [[Stmt]] -> q (DPat, DExp)+dsParComp [] = impossible "Empty list of parallel comprehension statements."+dsParComp [r] = do+ let rv = foldMap extractBoundNamesStmt r+ dsR <- dsComp (r ++ [mk_tuple_stmt rv])+ return (mk_tuple_dpat rv, dsR)+dsParComp (q : rest) = do+ let qv = foldMap extractBoundNamesStmt q+ (rest_pat, rest_exp) <- dsParComp rest+ dsQ <- dsComp (q ++ [mk_tuple_stmt qv])+ let zipped = DAppE (DAppE (DVarE 'mzip) dsQ) rest_exp+ return (DConP (tupleDataName 2) [] [mk_tuple_dpat qv, rest_pat], zipped)++-- helper function for dsParComp+mk_tuple_stmt :: OSet Name -> Stmt+mk_tuple_stmt name_set =+ NoBindS (mkTupleExp (F.foldr ((:) . VarE) [] name_set))++-- helper function for dsParComp+mk_tuple_dpat :: OSet Name -> DPat+mk_tuple_dpat name_set =+ mkTupleDPat (F.foldr ((:) . DVarP) [] name_set)++-- | Desugar a pattern, along with processing a (desugared) expression that+-- is the entire scope of the variables bound in the pattern.+dsPatOverExp :: DsMonad q => Pat -> DExp -> q (DPat, DExp)+dsPatOverExp pat exp = do+ (pat', vars) <- runWriterT $ dsPat pat+ let name_decs = map (uncurry (DValD . DVarP)) vars+ return (pat', maybeDLetE name_decs exp)++-- | Desugar multiple patterns. Like 'dsPatOverExp'.+dsPatsOverExp :: DsMonad q => [Pat] -> DExp -> q ([DPat], DExp)+dsPatsOverExp pats exp = do+ (pats', vars) <- runWriterT $ mapM dsPat pats+ let name_decs = map (uncurry (DValD . DVarP)) vars+ return (pats', maybeDLetE name_decs exp)++-- | Desugar a pattern, returning a list of (Name, DExp) pairs of extra+-- variables that must be bound within the scope of the pattern+dsPatX :: DsMonad q => Pat -> q (DPat, [(Name, DExp)])+dsPatX = runWriterT . dsPat++-- | Desugaring a pattern also returns the list of variables bound in as-patterns+-- and the values they should be bound to. This variables must be brought into+-- scope in the "body" of the pattern.+type PatM q = WriterT [(Name, DExp)] q++-- | Desugar a pattern.+dsPat :: DsMonad q => Pat -> PatM q DPat+dsPat (LitP lit) = return $ DLitP lit+dsPat (VarP n) = return $ DVarP n+dsPat (TupP pats) = DConP (tupleDataName (length pats)) [] <$> mapM dsPat pats+dsPat (UnboxedTupP pats) = DConP (unboxedTupleDataName (length pats)) [] <$>+ mapM dsPat pats+#if __GLASGOW_HASKELL__ >= 901+dsPat (ConP name tys pats) = DConP name <$> mapM dsType tys <*> mapM dsPat pats+#else+dsPat (ConP name pats) = DConP name [] <$> mapM dsPat pats+#endif+dsPat (InfixP p1 name p2) = DConP name [] <$> mapM dsPat [p1, p2]+dsPat (UInfixP _ _ _) =+ fail "Cannot desugar unresolved infix operators."+dsPat (ParensP pat) = dsPat pat+dsPat (TildeP pat) = DTildeP <$> dsPat pat+dsPat (BangP pat) = DBangP <$> dsPat pat+dsPat (AsP name pat) = do+ pat' <- dsPat pat+ pat'' <- lift $ removeWilds pat'+ tell [(name, dPatToDExp pat'')]+ return pat''+dsPat WildP = return DWildP+dsPat (RecP con_name field_pats) = do+ con <- lift $ dataConNameToCon con_name+ reordered <- reorder con+ return $ DConP con_name [] reordered+ where+ reorder con = case con of+ NormalC _name fields -> non_record fields+ InfixC field1 _name field2 -> non_record [field1, field2]+ RecC _name fields -> reorder_fields_pat fields+ ForallC _ _ c -> reorder c+ GadtC _names fields _ret_ty -> non_record fields+ RecGadtC _names fields _ret_ty -> reorder_fields_pat fields++ reorder_fields_pat fields = reorderFieldsPat con_name fields field_pats++ non_record fields | null field_pats+ -- Special case: record patterns are allowed for any+ -- constructor, regardless of whether the constructor+ -- actually was declared with records, provided that+ -- no records are given in the pattern itself. (See #59).+ --+ -- Con{} desugars down to Con _ ... _.+ = return $ replicate (length fields) DWildP+ | otherwise = lift $ impossible+ $ "Record syntax used with non-record constructor "+ ++ (show con_name) ++ "."++dsPat (ListP pats) = go pats+ where go [] = return $ DConP '[] [] []+ go (h : t) = do+ h' <- dsPat h+ t' <- go t+ return $ DConP '(:) [] [h', t']+dsPat (SigP pat ty) = DSigP <$> dsPat pat <*> dsType ty+#if __GLASGOW_HASKELL__ >= 801+dsPat (UnboxedSumP pat alt arity) =+ DConP (unboxedSumDataName alt arity) [] <$> ((:[]) <$> dsPat pat)+#endif+#if __GLASGOW_HASKELL__ >= 909+dsPat (TypeP ty) = DTypeP <$> dsType ty+dsPat (InvisP ty) = DInvisP <$> dsType ty+#endif+dsPat (ViewP _ _) =+ fail "View patterns are not supported in th-desugar. Use pattern guards instead."+#if __GLASGOW_HASKELL__ >= 911+dsPat (OrP _) =+ fail "Or-patterns are not supported in th-desugar."+#endif++-- | Convert a 'DPat' to a 'DExp'. Fails on 'DWildP' and 'DInvisP'.+dPatToDExp :: DPat -> DExp+dPatToDExp (DLitP lit) = DLitE lit+dPatToDExp (DVarP name) = DVarE name+dPatToDExp (DConP name tys pats) = foldl DAppE (foldl DAppTypeE (DConE name) tys) (map dPatToDExp pats)+dPatToDExp (DTildeP pat) = dPatToDExp pat+dPatToDExp (DBangP pat) = dPatToDExp pat+dPatToDExp (DSigP pat ty) = DSigE (dPatToDExp pat) ty+dPatToDExp (DTypeP ty) = DTypeE ty+dPatToDExp DWildP = error "Internal error in th-desugar: wildcard in rhs of as-pattern"+dPatToDExp (DInvisP {}) = error "Internal error in th-desugar: invisible type pattern in rhs of as-pattern"++-- | Remove all wildcards from a pattern, replacing any wildcard with a fresh+-- variable+removeWilds :: DsMonad q => DPat -> q DPat+removeWilds p@(DLitP _) = return p+removeWilds p@(DVarP _) = return p+removeWilds (DConP con_name tys pats) = DConP con_name tys <$> mapM removeWilds pats+removeWilds (DTildeP pat) = DTildeP <$> removeWilds pat+removeWilds (DBangP pat) = DBangP <$> removeWilds pat+removeWilds (DSigP pat ty) = DSigP <$> removeWilds pat <*> pure ty+removeWilds (DTypeP ty) = pure $ DTypeP ty+removeWilds (DInvisP ty) = pure $ DInvisP ty+removeWilds DWildP = DVarP <$> newUniqueName "wild"++-- | Desugar @Info@+dsInfo :: DsMonad q => Info -> q DInfo+dsInfo (ClassI dec instances) = do+ [ddec] <- dsDec dec+ dinstances <- dsDecs instances+ return $ DTyConI ddec (Just dinstances)+dsInfo (ClassOpI name ty parent) =+ DVarI name <$> dsType ty <*> pure (Just parent)+dsInfo (TyConI dec) = do+ [ddec] <- dsDec dec+ return $ DTyConI ddec Nothing+dsInfo (FamilyI dec instances) = do+ [ddec] <- dsDec dec+ dinstances <- dsDecs instances+ return $ DTyConI ddec (Just dinstances)+dsInfo (PrimTyConI name arity unlifted) =+ return $ DPrimTyConI name arity unlifted+dsInfo (DataConI name ty parent) =+ DVarI name <$> dsType ty <*> pure (Just parent)+dsInfo (VarI name ty Nothing) =+ DVarI name <$> dsType ty <*> pure Nothing+dsInfo (VarI name _ (Just _)) =+ impossible $ "Declaration supplied with variable: " ++ show name+dsInfo (TyVarI name ty) = DTyVarI name <$> dsType ty+#if __GLASGOW_HASKELL__ >= 801+dsInfo (PatSynI name ty) = DPatSynI name <$> dsType ty+#endif++-- | Desugar arbitrary @Dec@s+dsDecs :: DsMonad q => [Dec] -> q [DDec]+dsDecs = concatMapM dsDec++-- | Desugar a single @Dec@, perhaps producing multiple 'DDec's+dsDec :: DsMonad q => Dec -> q [DDec]+dsDec d@(FunD {}) = dsTopLevelLetDec d+dsDec d@(ValD {}) = dsTopLevelLetDec d+dsDec (DataD cxt n tvbs mk cons derivings) =+ dsDataDec Data cxt n tvbs mk cons derivings+dsDec (NewtypeD cxt n tvbs mk con derivings) =+ dsDataDec Newtype cxt n tvbs mk [con] derivings+dsDec (TySynD n tvbs ty) =+ (:[]) <$> (DTySynD n <$> mapM dsTvbVis tvbs <*> dsType ty)+dsDec (ClassD cxt n tvbs fds decs) =+ (:[]) <$> (DClassD <$> dsCxt cxt <*> pure n <*> mapM dsTvbVis tvbs+ <*> pure fds <*> dsDecs decs)+dsDec (InstanceD over cxt ty decs) =+ (:[]) <$> (DInstanceD over Nothing <$> dsCxt cxt <*> dsType ty <*> dsDecs decs)+dsDec d@(SigD {}) = dsTopLevelLetDec d+dsDec (ForeignD f) = (:[]) <$> (DForeignD <$> dsForeign f)+dsDec d@(InfixD {}) = dsTopLevelLetDec d+dsDec d@(PragmaD {}) = dsTopLevelLetDec d+dsDec (OpenTypeFamilyD tfHead) =+ (:[]) <$> (DOpenTypeFamilyD <$> dsTypeFamilyHead tfHead)+dsDec (DataFamilyD n tvbs m_k) =+ (:[]) <$> (DDataFamilyD n <$> mapM dsTvbVis tvbs <*> mapM dsType m_k)+#if __GLASGOW_HASKELL__ >= 807+dsDec (DataInstD cxt mtvbs lhs mk cons derivings) =+ case unfoldType lhs of+ (ConT n, tys) -> dsDataInstDec Data cxt n mtvbs tys mk cons derivings+ (_, _) -> fail $ "Unexpected data instance LHS: " ++ pprint lhs+dsDec (NewtypeInstD cxt mtvbs lhs mk con derivings) =+ case unfoldType lhs of+ (ConT n, tys) -> dsDataInstDec Newtype cxt n mtvbs tys mk [con] derivings+ (_, _) -> fail $ "Unexpected newtype instance LHS: " ++ pprint lhs+#else+dsDec (DataInstD cxt n tys mk cons derivings) =+ dsDataInstDec Data cxt n Nothing (map TANormal tys) mk cons derivings+dsDec (NewtypeInstD cxt n tys mk con derivings) =+ dsDataInstDec Newtype cxt n Nothing (map TANormal tys) mk [con] derivings+#endif+#if __GLASGOW_HASKELL__ >= 807+dsDec (TySynInstD eqn) = (:[]) <$> (DTySynInstD <$> dsTySynEqn unusedArgument eqn)+#else+dsDec (TySynInstD n eqn) = (:[]) <$> (DTySynInstD <$> dsTySynEqn n eqn)+#endif+dsDec (ClosedTypeFamilyD tfHead eqns) =+ (:[]) <$> (DClosedTypeFamilyD <$> dsTypeFamilyHead tfHead+ <*> mapM (dsTySynEqn (typeFamilyHeadName tfHead)) eqns)+dsDec (RoleAnnotD n roles) = return [DRoleAnnotD n roles]+#if __GLASGOW_HASKELL__ >= 801+dsDec (PatSynD n args dir pat) = do+ dir' <- dsPatSynDir n dir+ (pat', vars) <- dsPatX pat+ unless (null vars) $+ fail $ "Pattern synonym definition cannot contain as-patterns (@)."+ return [DPatSynD n args dir' pat']+dsDec (PatSynSigD n ty) = (:[]) <$> (DPatSynSigD n <$> dsType ty)+dsDec (StandaloneDerivD mds cxt ty) =+ (:[]) <$> (DStandaloneDerivD <$> mapM dsDerivStrategy mds+ <*> pure Nothing <*> dsCxt cxt <*> dsType ty)+#else+dsDec (StandaloneDerivD cxt ty) =+ (:[]) <$> (DStandaloneDerivD Nothing Nothing <$> dsCxt cxt <*> dsType ty)+#endif+dsDec (DefaultSigD n ty) = (:[]) <$> (DDefaultSigD n <$> dsType ty)+#if __GLASGOW_HASKELL__ >= 807+dsDec (ImplicitParamBindD {}) = impossible "Non-`let`-bound implicit param binding"+#endif+#if __GLASGOW_HASKELL__ >= 809+dsDec (KiSigD n ki) = (:[]) <$> (DKiSigD n <$> dsType ki)+#endif+#if __GLASGOW_HASKELL__ >= 903+dsDec (DefaultD tys) = (:[]) <$> (DDefaultD <$> mapM dsType tys)+#endif+#if __GLASGOW_HASKELL__ >= 906+dsDec (TypeDataD n tys mk cons) =+ dsDataDec TypeData [] n tys mk cons []+#endif++-- | Desugar a 'DataD', 'NewtypeD', or 'TypeDataD'.+dsDataDec :: DsMonad q+ => DataFlavor -> Cxt -> Name -> [TyVarBndrVis]+ -> Maybe Kind -> [Con] -> [DerivingClause] -> q [DDec]+dsDataDec nd cxt n tvbs mk cons derivings = do+ tvbs' <- mapM dsTvbVis tvbs+ h98_tvbs <-+ case mk of+ -- If there's an explicit return kind, we're dealing with a+ -- GADT, so this argument goes unused in dsCon.+ Just {} -> pure unusedArgument+ -- If there is no explicit return kind, we're dealing with a+ -- Haskell98-style data type, so we must compute the type variable+ -- binders to use in the types of the data constructors.+ --+ -- Rather than just returning `tvbs'` here, we propagate kind information+ -- from the data type's standalone kind signature (if one exists) to make+ -- the kinds more precise.+ Nothing -> do+ mb_sak <- dsReifyType n+ let tvbSpecs = changeDTVFlags SpecifiedSpec tvbs'+ pure $ maybe tvbSpecs dtvbForAllTyFlagsToSpecs $ do+ sak <- mb_sak+ dMatchUpSAKWithDecl sak tvbs'+ let h98_return_type = nonFamilyDataReturnType n tvbs'+ (:[]) <$> (DDataD nd <$> dsCxt cxt <*> pure n+ <*> pure tvbs' <*> mapM dsType mk+ <*> concatMapM (dsCon h98_tvbs h98_return_type) cons+ <*> mapM dsDerivClause derivings)++-- | Desugar a 'DataInstD' or a 'NewtypeInstD'.+dsDataInstDec :: DsMonad q+ => DataFlavor -> Cxt -> Name -> Maybe [TyVarBndrUnit] -> [TypeArg]+ -> Maybe Kind -> [Con] -> [DerivingClause] -> q [DDec]+dsDataInstDec nd cxt n mtvbs tys mk cons derivings = do+ mtvbs' <- mapM (mapM dsTvbUnit) mtvbs+ tys' <- mapM dsTypeArg tys+ let lhs' = applyDType (DConT n) tys'+ h98_tvbs =+ changeDTVFlags SpecifiedSpec $+ case (mk, mtvbs') of+ -- If there's an explicit return kind, we're dealing with a+ -- GADT, so this argument goes unused in dsCon.+ (Just {}, _) -> unusedArgument+ -- H98, and there is an explicit `forall` in front. Just reuse the+ -- type variable binders from the `forall`.+ (Nothing, Just tvbs') -> tvbs'+ -- H98, and no explicit `forall`. Compute the bound variables+ -- manually.+ (Nothing, Nothing) -> dataFamInstTvbs tys'+ h98_fam_inst_type = dataFamInstReturnType n tys'+ (:[]) <$> (DDataInstD nd <$> dsCxt cxt <*> pure mtvbs'+ <*> pure lhs' <*> mapM dsType mk+ <*> concatMapM (dsCon h98_tvbs h98_fam_inst_type) cons+ <*> mapM dsDerivClause derivings)++-- | Desugar a @FamilyResultSig@+dsFamilyResultSig :: DsMonad q => FamilyResultSig -> q DFamilyResultSig+dsFamilyResultSig NoSig = return DNoSig+dsFamilyResultSig (KindSig k) = DKindSig <$> dsType k+dsFamilyResultSig (TyVarSig tvb) = DTyVarSig <$> dsTvbUnit tvb++-- | Desugar a @TypeFamilyHead@+dsTypeFamilyHead :: DsMonad q => TypeFamilyHead -> q DTypeFamilyHead+dsTypeFamilyHead (TypeFamilyHead n tvbs result inj)+ = DTypeFamilyHead n <$> mapM dsTvbVis tvbs+ <*> dsFamilyResultSig result+ <*> pure inj++typeFamilyHeadName :: TypeFamilyHead -> Name+typeFamilyHeadName (TypeFamilyHead n _ _ _) = n++-- | Desugar @Dec@s that can appear in a @let@ expression. See the+-- documentation for 'dsLetDec' for an explanation of what the return type+-- represents.+dsLetDecs :: DsMonad q => [Dec] -> q ([DLetDec], DExp -> DExp)+dsLetDecs decs = do+ (let_decss, ip_binders) <- mapAndUnzipM dsLetDec decs+ let let_decs :: [DLetDec]+ let_decs = concat let_decss++ ip_binder :: DExp -> DExp+ ip_binder = foldr (.) id ip_binders+ return (let_decs, ip_binder)++-- | Desugar a single 'Dec' that can appear in a @let@ expression.+-- This produces the following output:+--+-- * One or more 'DLetDec's (a single 'Dec' can produce multiple 'DLetDec's+-- in the event of a value declaration that binds multiple things by way+-- of pattern matching.+--+-- * A function of type @'DExp' -> 'DExp'@, which should be applied to the+-- expression immediately following the 'DLetDec's. This function prepends+-- binding forms for any implicit params that were bound in the argument+-- 'Dec'. (If no implicit params are bound, this is simply the 'id'+-- function.)+--+-- For instance, if the argument to 'dsLetDec' is the @?x = 42@ part of this+-- expression:+--+-- @+-- let { ?x = 42 } in ?x+-- @+--+-- Then the output is:+--+-- * @let new_x_val = 42@+--+-- * @\\z -> 'bindIP' \@\"x\" new_x_val z@+--+-- This way, the expression+-- @let { new_x_val = 42 } in 'bindIP' \@"x" new_x_val ('ip' \@\"x\")@ can be+-- formed. The implicit param binders always come after all the other+-- 'DLetDec's to support parallel assignment of implicit params.+dsLetDec :: DsMonad q => Dec -> q ([DLetDec], DExp -> DExp)+dsLetDec (FunD name clauses) = do+ clauses' <- dsClauses (FunRhs name) clauses+ return ([DFunD name clauses'], id)+dsLetDec (ValD pat body where_decs) = do+ (pat', vars) <- dsPatX pat+ body' <- dsBody body where_decs error_exp+ let extras = uncurry (zipWith (DValD . DVarP)) $ unzip vars+ return (DValD pat' body' : extras, id)+ where+ error_exp = mkErrorMatchExpr (LetDecRhs pat)+dsLetDec (SigD name ty) = do+ ty' <- dsType ty+ return ([DSigD name ty'], id)+#if __GLASGOW_HASKELL__ >= 909+dsLetDec (InfixD fixity ns_spec name) =+ return ([DInfixD fixity ns_spec name], id)+#else+dsLetDec (InfixD fixity name) =+ return ([DInfixD fixity NoNamespaceSpecifier name], id)+#endif+dsLetDec (PragmaD prag) = do+ prag' <- dsPragma prag+ return ([DPragmaD prag'], id)+#if __GLASGOW_HASKELL__ >= 807+dsLetDec (ImplicitParamBindD n e) = do+ new_n_name <- qNewName $ "new_" ++ n ++ "_val"+ e' <- dsExp e+ let let_dec :: DLetDec+ let_dec = DValD (DVarP new_n_name) e'++ ip_binder :: DExp -> DExp+ ip_binder = (DVarE 'bindIP `DAppTypeE`+ DLitT (StrTyLit n) `DAppE`+ DVarE new_n_name `DAppE`)+ return ([let_dec], ip_binder)+#endif+dsLetDec _dec = impossible "Illegal declaration in let expression."++-- | Desugar a single 'Dec' corresponding to something that could appear after+-- the @let@ in a @let@ expression, but occurring at the top level. Because the+-- 'Dec' occurs at the top level, there is nothing that would correspond to the+-- @in ...@ part of the @let@ expression. As a consequence, this function does+-- not return a @'DExp' -> 'DExp'@ function corresonding to implicit param+-- binders (these cannot occur at the top level).+dsTopLevelLetDec :: DsMonad q => Dec -> q [DDec]+dsTopLevelLetDec = fmap (map DLetDec . fst) . dsLetDec+ -- Note the use of fst above: we're silently throwing away any implicit param+ -- binders that dsLetDec returns, since there is invariant that there will be+ -- no implicit params in the first place.++-- | 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+ => [DTyVarBndrSpec] -- ^ 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+ expl_dtvbs = univ_dtvbs ++ ex_dtvbs+ impl_dtvbs = changeDTVFlags SpecifiedSpec $+ toposortKindVarsOfTvbs expl_dtvbs in+ DCon (impl_dtvbs ++ expl_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, [DTyVarBndrSpec], 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 [(n, [], [], DNormalC True [dty1, dty2], Nothing)]+dsCon' (ForallC tvbs cxt con) = do+ dtvbs <- mapM dsTvbSpec tvbs+ dcxt <- dsCxt cxt+ dcons' <- dsCon' con+ return $ flip map dcons' $ \(n, dtvbs', dcxt', fields, m_gadt_type) ->+ (n, dtvbs ++ dtvbs', dcxt ++ dcxt', fields, m_gadt_type)+dsCon' (GadtC nms btys rty) = do+ dbtys <- mapM dsBangType btys+ drty <- dsType rty+ sequence $ flip map nms $ \nm -> do+ mbFi <- reifyFixityWithLocals nm+ -- A GADT data constructor is declared infix when these three+ -- properties hold:+ let decInfix = isInfixDataCon (nameBase nm) -- 1. Its name uses operator syntax+ -- (e.g., (:*:))+ && length dbtys == 2 -- 2. It has exactly two fields+ && isJust mbFi -- 3. It has a programmer-specified+ -- fixity declaration+ 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 ->+ (nm, [], [], DRecC dvbtys, Just drty)++-- | Desugar a @BangType@.+dsBangType :: DsMonad q => BangType -> q DBangType+dsBangType (b, ty) = (b, ) <$> dsType ty++-- | Desugar a @VarBangType@.+dsVarBangType :: DsMonad q => VarBangType -> q DVarBangType+dsVarBangType (n, b, ty) = (n, b, ) <$> dsType ty++-- | Desugar a @Foreign@.+dsForeign :: DsMonad q => Foreign -> q DForeign+dsForeign (ImportF cc safety str n ty) = DImportF cc safety str n <$> dsType ty+dsForeign (ExportF cc str n ty) = DExportF cc str n <$> dsType ty++-- | Desugar a @Pragma@.+dsPragma :: DsMonad q => Pragma -> q DPragma+dsPragma (InlineP n inl rm phases) = return $ DInlineP n inl rm phases+dsPragma (SpecialiseP n ty m_inl phases) = DSpecialiseP n <$> dsType ty+ <*> pure m_inl+ <*> pure phases+dsPragma (SpecialiseInstP ty) = DSpecialiseInstP <$> dsType ty+#if __GLASGOW_HASKELL__ >= 807+dsPragma (RuleP str mtvbs rbs lhs rhs phases)+ = DRuleP str <$> mapM (mapM dsTvbUnit) mtvbs+ <*> mapM dsRuleBndr rbs+ <*> dsExp lhs+ <*> dsExp rhs+ <*> pure phases+#else+dsPragma (RuleP str rbs lhs rhs phases) = DRuleP str Nothing+ <$> mapM dsRuleBndr rbs+ <*> dsExp lhs+ <*> dsExp rhs+ <*> pure phases+#endif+dsPragma (AnnP target exp) = DAnnP target <$> dsExp exp+dsPragma (LineP n str) = return $ DLineP n str+#if __GLASGOW_HASKELL__ >= 801+dsPragma (CompleteP cls mty) = return $ DCompleteP cls mty+#endif+#if __GLASGOW_HASKELL__ >= 903+dsPragma (OpaqueP n) = return $ DOpaqueP n+#endif+#if __GLASGOW_HASKELL__ >= 909+dsPragma (SCCP nm mstr) = return $ DSCCP nm mstr+#endif+#if __GLASGOW_HASKELL__ >= 913+dsPragma (SpecialiseEP mTyBndrs tmBndrs specE mInline phases) =+ DSpecialiseEP+ <$> mapM (mapM dsTvbUnit) mTyBndrs+ <*> mapM dsRuleBndr tmBndrs+ <*> dsExp specE+ <*> pure mInline+ <*> pure phases+#endif++-- | Desugar a @RuleBndr@.+dsRuleBndr :: DsMonad q => RuleBndr -> q DRuleBndr+dsRuleBndr (RuleVar n) = return $ DRuleVar n+dsRuleBndr (TypedRuleVar n ty) = DTypedRuleVar n <$> dsType ty++#if __GLASGOW_HASKELL__ >= 807+-- | Desugar a @TySynEqn@. (Available only with GHC 7.8+)+--+-- This requires a 'Name' as an argument since 'TySynEqn's did not have+-- this information prior to GHC 8.8.+dsTySynEqn :: DsMonad q => Name -> TySynEqn -> q DTySynEqn+dsTySynEqn _ (TySynEqn mtvbs lhs rhs) =+ DTySynEqn <$> mapM (mapM dsTvbUnit) mtvbs <*> dsType lhs <*> dsType rhs+#else+-- | Desugar a @TySynEqn@. (Available only with GHC 7.8+)+dsTySynEqn :: DsMonad q => Name -> TySynEqn -> q DTySynEqn+dsTySynEqn n (TySynEqn lhss rhs) = do+ lhss' <- mapM dsType lhss+ let lhs' = applyDType (DConT n) $ map DTANormal lhss'+ DTySynEqn Nothing lhs' <$> dsType rhs+#endif++-- | Desugar clauses to a function definition+dsClauses :: DsMonad q+ => MatchContext -- ^ The context in which the clauses arise+ -> [Clause] -- ^ Clauses to desugar+ -> q [DClause]+dsClauses _ [] = return []+-- Include a special case for guard-less clauses to make the desugared output+-- a little nicer. See Note [Desugaring clauses compactly (when possible)].+dsClauses mc (Clause pats (NormalB exp) where_decs : rest) = do+ rest' <- dsClauses mc rest+ exp' <- dsExp exp+ (where_decs', ip_binder) <- dsLetDecs where_decs+ let exp_with_wheres = maybeDLetE where_decs' (ip_binder exp')+ (pats', exp'') <- dsPatsOverExp pats exp_with_wheres+ return $ DClause pats' exp'' : rest'+dsClauses mc clauses@(Clause outer_pats _ _ : _) = do+ arg_names <- replicateM (length outer_pats) (newUniqueName "arg")+ let scrutinees = map DVarE arg_names+ clauses' <- foldrM (ds_clause scrutinees) [] clauses+ pure [DClause (map DVarP arg_names) (dCasesE scrutinees clauses')]+ where+ ds_clause :: DsMonad q => [DExp] -> Clause -> [DClause] -> q [DClause]+ ds_clause scrutinees (Clause pats body where_decs) failure_clauses = do+ let failure_exp = maybeDCasesE mc scrutinees failure_clauses+ exp <- dsBody body where_decs failure_exp+ (pats', exp') <- dsPatsOverExp pats exp+ -- incomplete attempt at #6+ uni_pats <- fmap getAll $ concatMapM (fmap All . isUniversalPattern) pats'+ let clause = DClause pats' exp'+ if uni_pats+ then return [clause]+ else return (clause : failure_clauses)++-- | The context of a pattern match. This is used to produce+-- @Non-exhaustive patterns in...@ messages that are tailored to specific+-- situations. Compare this to GHC's @HsMatchContext@ data type+-- (https://gitlab.haskell.org/ghc/ghc/-/blob/81cf52bb301592ff3d043d03eb9a0d547891a3e1/compiler/Language/Haskell/Syntax/Expr.hs#L1662-1695),+-- from which the @MatchContext@ data type takes inspiration.+data MatchContext+ = FunRhs Name+ -- ^ A pattern matching on an argument of a function binding+ | LetDecRhs Pat+ -- ^ A pattern in a @let@ declaration+ | RecUpd+ -- ^ A record update+ | MultiWayIfAlt+ -- ^ Guards in a multi-way if alternative+ | CaseAlt+ -- ^ Patterns and guards in a case alternative+ | LamCaseAlt LamCaseVariant+ -- ^ Patterns and guards in @\\case@ and @\\cases@++-- | Which kind of lambda case are we dealing with? Compare this to GHC's+-- @LamCaseVariant@ data type+-- (https://gitlab.haskell.org/ghc/ghc/-/blob/81cf52bb301592ff3d043d03eb9a0d547891a3e1/compiler/Language/Haskell/Syntax/Expr.hs#L686-690)+-- from which we take inspiration.+data LamCaseVariant+ = LamCase -- ^ @\\case@+ | LamCases -- ^ @\\cases@++-- | Construct an expression that throws an error when encountering a pattern+-- at runtime that is not covered by pattern matching.+mkErrorMatchExpr :: MatchContext -> DExp+mkErrorMatchExpr mc =+ DAppE (DVarE 'error) (DLitE (StringL ("Non-exhaustive patterns in " ++ pp_context)))+ where+ pp_context =+ case mc of+ FunRhs n -> show n+ LetDecRhs pat -> pprint pat+ RecUpd -> "record update"+ MultiWayIfAlt -> "multi-way if"+ CaseAlt -> "case"+ LamCaseAlt lv -> pp_lam_case_variant lv++ pp_lam_case_variant LamCase = "\\case"+ pp_lam_case_variant LamCases = "\\cases"++{-+Note [Desugaring clauses compactly (when possible)]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In the general case, th-desugar's approach to desugaring clauses with guards+requires binding an extra variable. For example, consider this code:++ \case+ A x | x == "hello" -> x+ B y -> y+ _ -> ""++As part of desugaring, th-desugar will get rid of the guards by rewriting the+code to something that looks closer to this:++ \scrutinee ->+ case scrutinee of+ A x ->+ if x == "hello"+ then x+ else case scrutinee of+ B y -> y+ _ -> ""+ B y -> y+ _ -> ""++(The fully desugared output would then translate the lambda and `case`+expressions to `\cases` expressions, but let's put that aside for now. We'll+come back to this in a bit.)++Note the `scrutinee` argument, which is now explicitly named. Binding the+argument to a name is important because we need to further match on it when the+`x == "hello"` guard fails to match.++This approach gets the job done, but it does add a some amount of extra+clutter. We take steps to avoid this clutter where possible. Consider this+simpler example:++ \case+ A x -> x+ B y -> y+ _ -> ""++If we were to desugar this example using the same approach as above, we'd end+up with something like this:++ \scrutinee ->+ case scrutinee of+ A x -> x+ B y -> y+ _ -> ""++Recall that th-desugar will desugar lambda and `case` expressions to `\cases`+exprressions. As such, the fully desugared output would be:++ \cases+ scrutinee ->+ (\cases+ A x -> x+ B y -> y+ _ -> "") scrutinee++This would technically work, but we would lose something along the way. By+using this approach, we would transform something with a single `\case`+expression to something with multiple `\cases` expressions. Moreover, the+original expression never needed to give a name to the `scrutinee` variable, so+it would be strange for the desugared output to require this extra clutter.++Luckily, we can avoid the clutter by observing that the `scrutinee` variable+can be eta-contracted away. More generally, if a set of clauses does not use+any guards, then we don't bother explicitly binding a variable like+`scrutinee`, as we never need to use it outside of the initial matching. This+means that we can desugar the simpler example above to:++ \cases+ (A x) -> x+ (B y) -> y+ _ -> ""++Ahh. Much nicer.++Of course, the flip side is that we /do/ need the extra `scrutinee` clutter+when desugaring clauses involving guards. Personally, I'm not too bothered by+this, as th-desugar's approach to desugaring guards already has various+limitations (see the "Known limitations" section of the th-desugar README). As+such, I'm not inclined to invest more effort into fixing this unless someone+explicitly asks for it.+-}++-- | Desugar a type+dsType :: DsMonad q => Type -> q DType+#if __GLASGOW_HASKELL__ >= 900+-- See Note [Gracefully handling linear types]+dsType (MulArrowT `AppT` _) = return DArrowT+dsType MulArrowT = fail "Cannot desugar exotic uses of linear types."+#endif+dsType (ForallT tvbs preds ty) =+ mkDForallConstrainedT <$> (DForallInvis <$> mapM dsTvbSpec tvbs)+ <*> dsCxt preds <*> dsType ty+dsType (AppT t1 t2) = DAppT <$> dsType t1 <*> dsType t2+dsType (SigT ty ki) = DSigT <$> dsType ty <*> dsType ki+dsType (VarT name) = return $ DVarT name+dsType (ConT name) = return $ DConT name+-- The PromotedT case is identical to the ConT case above.+-- See Note [Desugaring promoted types].+dsType (PromotedT name) = return $ DConT name+dsType (TupleT n) = return $ DConT (tupleTypeName n)+dsType (UnboxedTupleT n) = return $ DConT (unboxedTupleTypeName n)+dsType ArrowT = return DArrowT+dsType ListT = return $ DConT ''[]+dsType (PromotedTupleT n) = return $ DConT (tupleDataName n)+dsType PromotedNilT = return $ DConT '[]+dsType PromotedConsT = return $ DConT '(:)+dsType StarT = return $ DConT typeKindName+dsType ConstraintT = return $ DConT ''Constraint+dsType (LitT lit) = return $ DLitT lit+dsType EqualityT = return $ DConT ''(~)+dsType (InfixT t1 n t2) = dsInfixT t1 n t2+dsType (UInfixT{}) = dsUInfixT+dsType (ParensT t) = dsType t+dsType WildCardT = return DWildCardT+#if __GLASGOW_HASKELL__ >= 801+dsType (UnboxedSumT arity) = return $ DConT (unboxedSumTypeName arity)+#endif+#if __GLASGOW_HASKELL__ >= 807+dsType (AppKindT t k) = DAppKindT <$> dsType t <*> dsType k+dsType (ImplicitParamT n t) = do+ t' <- dsType t+ return $ DConT ''IP `DAppT` DLitT (StrTyLit n) `DAppT` t'+#endif+#if __GLASGOW_HASKELL__ >= 809+dsType (ForallVisT tvbs ty) =+ DForallT <$> (DForallVis <$> mapM dsTvbUnit tvbs) <*> dsType ty+#endif+#if __GLASGOW_HASKELL__ >= 903+-- The PromotedInfixT case is identical to the InfixT case above.+-- See Note [Desugaring promoted types].+dsType (PromotedInfixT t1 n t2) = dsInfixT t1 n t2+dsType PromotedUInfixT{} = dsUInfixT+#endif++#if __GLASGOW_HASKELL__ >= 900+-- | Desugar a 'TyVarBndr'.+dsTvb :: DsMonad q => TyVarBndr_ flag -> q (DTyVarBndr flag)+dsTvb (PlainTV n flag) = return $ DPlainTV n flag+dsTvb (KindedTV n flag k) = DKindedTV n flag <$> dsType k+#else+-- | Desugar a 'TyVarBndr' with a particular @flag@.+dsTvb :: DsMonad q => flag -> TyVarBndr -> q (DTyVarBndr flag)+dsTvb flag (PlainTV n) = return $ DPlainTV n flag+dsTvb flag (KindedTV n k) = DKindedTV n flag <$> dsType k+#endif++{-+Note [Gracefully handling linear types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Per the README, th-desugar does not currently support linear types.+Unfortunately, we cannot simply reject all occurrences of+multiplicity-polymorphic function arrows (i.e., MulArrowT), as it is possible+for "non-linear" code to contain them when reified. For example, the type of a+Haskell98 data constructor such as `Just` will be reified as++ a #-> Maybe a++In terms of the TH AST, that is:++ MulArrowT `AppT` PromotedConT 'One `AppT` VarT a `AppT` (ConT ''Maybe `AppT` VarT a)++Therefore, in order to desugar these sorts of types, we have to do *something*+with MulArrowT. The approach that th-desugar takes is to pretend that all+multiplicity-polymorphic function arrows are actually ordinary function arrows+(->) when desugaring types. In other words, whenever th-desugar sees+(MulArrowT `AppT` m), for any particular value of `m`, it will turn it into+DArrowT.++This approach is enough to gracefully handle most uses of MulArrowT, as TH+reification always generates MulArrowT applied to some particular multiplicity+(as of GHC 9.0, at least). It's conceivable that some wily user could manually+construct a TH AST containing MulArrowT in a different position, but since this+situation is rare, we simply throw an error in such cases.++We adopt a similar stance in L.H.TH.Desugar.Reify when locally reifying the+types of data constructors: since th-desugar doesn't currently support linear+types, we pretend as if MulArrowT does not exist. As a result, the type of+`Just` would be locally reified as `a -> Maybe a`, not `a #-> Maybe a`.++Note [Desugaring promoted types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+ConT and PromotedT both contain Names as a payload, the only difference being+that PromotedT is intended to refer exclusively to promoted data constructor+Names, while ConT can refer to both type and data constructor Names alike.++When desugaring a PromotedT, we make the assumption that the TH quoting+mechanism produced the correct Name and wrap the name in a DConT. In other+words, we desugar ConT and PromotedT identically. This assumption about+PromotedT may not always be correct, however. Consider this example:++ data a :+: b = Inl a | Inr b+ data Exp a = ... | Exp :+: Exp++How should `PromotedT (mkName ":+:")` be desugared? Morally, it ought to be+desugared to a DConT that contains (:+:) the data constructor, not (:+:) the+type constructor. Deciding between the two is not always straightforward,+however. We could use the `lookupDataName` function to try and distinguish+between the two Names, but this may not necessarily work. This is because the+Name passed to `lookupDataName` could have its original module attached, which+may not be in scope.++Long story short: we make things simple (albeit slightly wrong) by desugaring+ConT and PromotedT identically. We'll wait for someone to complain about the+wrongness of this approach before researching a more accurate solution.++Note that the same considerations also apply to InfixT and PromotedInfixT,+which are also desugared identically.+-}++-- | Desugar an infix 'Type'.+dsInfixT :: DsMonad q => Type -> Name -> Type -> q DType+dsInfixT t1 n t2 = DAppT <$> (DAppT (DConT n) <$> dsType t1) <*> dsType t2++-- | We cannot desugar unresolved infix operators, so fail if we encounter one.+dsUInfixT :: Fail.MonadFail m => m a+dsUInfixT = fail "Cannot desugar unresolved infix operators."++-- | Desugar a 'TyVarBndrSpec'.+dsTvbSpec :: DsMonad q => TyVarBndrSpec -> q DTyVarBndrSpec+#if __GLASGOW_HASKELL__ >= 900+dsTvbSpec = dsTvb+#else+dsTvbSpec = dsTvb SpecifiedSpec+#endif++-- | Desugar a 'TyVarBndrUnit'.+dsTvbUnit :: DsMonad q => TyVarBndrUnit -> q DTyVarBndrUnit+#if __GLASGOW_HASKELL__ >= 900+dsTvbUnit = dsTvb+#else+dsTvbUnit = dsTvb ()+#endif++-- | Desugar a 'TyVarBndrVis'.+dsTvbVis :: DsMonad q => TyVarBndrVis -> q DTyVarBndrVis+#if __GLASGOW_HASKELL__ >= 900+dsTvbVis = dsTvb+#else+dsTvbVis = dsTvb BndrReq+#endif++-- | Desugar a @Cxt@+dsCxt :: DsMonad q => Cxt -> q DCxt+dsCxt = concatMapM dsPred++#if __GLASGOW_HASKELL__ >= 801+-- | A backwards-compatible type synonym for the thing representing a single+-- derived class in a @deriving@ clause. (This is a @DerivClause@, @Pred@, or+-- @Name@ depending on the GHC version.)+type DerivingClause = DerivClause++-- | Desugar a @DerivingClause@.+dsDerivClause :: DsMonad q => DerivingClause -> q DDerivClause+dsDerivClause (DerivClause mds cxt) =+ DDerivClause <$> mapM dsDerivStrategy mds <*> dsCxt cxt+#else+type DerivingClause = Pred++dsDerivClause :: DsMonad q => DerivingClause -> q DDerivClause+dsDerivClause p = DDerivClause Nothing <$> dsPred p+#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+dsPatSynDir _ ImplBidir = pure DImplBidir+dsPatSynDir n (ExplBidir clauses) = DExplBidir <$> dsClauses (FunRhs n) clauses+#endif++-- | Desugar a @Pred@, flattening any internal tuples+dsPred :: DsMonad q => Pred -> q DCxt+dsPred t+ | Just ts <- splitTuple_maybe t+ = concatMapM dsPred ts+dsPred (ForallT tvbs cxt p) = dsForallPred tvbs cxt p+dsPred (AppT t1 t2) = do+ [p1] <- dsPred t1 -- tuples can't be applied!+ (:[]) <$> DAppT p1 <$> dsType t2+dsPred (SigT ty ki) = do+ preds <- dsPred ty+ case preds of+ [p] -> (:[]) <$> DSigT p <$> dsType ki+ other -> return other -- just drop the kind signature on a tuple.+dsPred (VarT n) = return [DVarT n]+dsPred (ConT n) = return [DConT n]+dsPred t@(PromotedT _) =+ impossible $ "Promoted type seen as head of constraint: " ++ show t+dsPred (TupleT 0) = return [DConT (tupleTypeName 0)]+dsPred (TupleT _) =+ impossible "Internal error in th-desugar in detecting tuple constraints."+dsPred t@(UnboxedTupleT _) =+ impossible $ "Unboxed tuple seen as head of constraint: " ++ show t+dsPred ArrowT = impossible "Arrow seen as head of constraint."+dsPred ListT = impossible "List seen as head of constraint."+dsPred (PromotedTupleT _) =+ impossible "Promoted tuple seen as head of constraint."+dsPred PromotedNilT = impossible "Promoted nil seen as head of constraint."+dsPred PromotedConsT = impossible "Promoted cons seen as head of constraint."+dsPred StarT = impossible "* seen as head of constraint."+dsPred ConstraintT =+ impossible "The kind `Constraint' seen as head of constraint."+dsPred t@(LitT _) =+ impossible $ "Type literal seen as head of constraint: " ++ show t+dsPred EqualityT = return [DConT ''(~)]+dsPred (InfixT t1 n t2) = (:[]) <$> dsInfixT t1 n t2+dsPred (UInfixT{}) = dsUInfixT+dsPred (ParensT t) = dsPred t+dsPred WildCardT = return [DWildCardT]+#if __GLASGOW_HASKELL__ >= 801+dsPred t@(UnboxedSumT {}) =+ impossible $ "Unboxed sum seen as head of constraint: " ++ show t+#endif+#if __GLASGOW_HASKELL__ >= 807+dsPred (AppKindT t k) = do+ [p] <- dsPred t+ (:[]) <$> (DAppKindT p <$> dsType k)+dsPred (ImplicitParamT n t) = do+ t' <- dsType t+ return [DConT ''IP `DAppT` DLitT (StrTyLit n) `DAppT` t']+#endif+#if __GLASGOW_HASKELL__ >= 809+dsPred t@(ForallVisT {}) =+ impossible $ "Visible dependent quantifier seen as head of constraint: " ++ show t+#endif+#if __GLASGOW_HASKELL__ >= 900+dsPred MulArrowT = impossible "Linear arrow seen as head of constraint."+#endif+#if __GLASGOW_HASKELL__ >= 903+dsPred t@PromotedInfixT{} =+ impossible $ "Promoted infix type seen as head of constraint: " ++ show t+dsPred PromotedUInfixT{} = dsUInfixT+#endif++-- | Desugar a quantified constraint.+dsForallPred :: DsMonad q => [TyVarBndrSpec] -> Cxt -> Pred -> q DCxt+dsForallPred tvbs cxt p = do+ ps' <- dsPred p+ case ps' of+ [p'] -> (:[]) <$> (mkDForallConstrainedT <$>+ (DForallInvis <$> mapM dsTvbSpec tvbs) <*> dsCxt cxt <*> pure p')+ _ -> fail "Cannot desugar constraint tuples in the body of a quantified constraint"+ -- See GHC #15334.++-- | Like 'reify', but safer and desugared. Uses local declarations where+-- available.+dsReify :: DsMonad q => Name -> q (Maybe DInfo)+dsReify = traverse dsInfo <=< reifyWithLocals_maybe++-- | Like 'reifyType', but safer and desugared. Uses local declarations where+-- available.+dsReifyType :: DsMonad q => Name -> q (Maybe DType)+dsReifyType = traverse dsType <=< reifyTypeWithLocals_maybe++-- Given a list of `forall`ed type variable binders and a context, construct+-- a DType using DForallT and DConstrainedT as appropriate. The phrase+-- "as appropriate" is used because DConstrainedT will not be used if the+-- context is empty, per Note [Desugaring and sweetening ForallT].+mkDForallConstrainedT :: DForallTelescope -> DCxt -> DType -> DType+mkDForallConstrainedT tele ctxt ty =+ DForallT tele $ if null ctxt then ty else DConstrainedT ctxt ty++-- create a list of expressions in the same order as the fields in the first argument+-- 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 => Name -> [VarStrictType] -> [FieldExp] -> [DExp] -> q [DExp]+reorderFields = reorderFields' dsExp++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 DWildP)++reorderFields' :: (Applicative m, Fail.MonadFail m)+ => (a -> m da)+ -> Name -- ^ The name of the constructor (used for error reporting)+ -> [VarStrictType] -> [(Name, a)]+ -> [da] -> m [da]+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."++-- mkTupleDExp and friends construct tuples, avoiding the use of 1-tuples. These+-- are used to create auxiliary tuple values when desugaring ParallelListComp+-- expressions (see the Haddocks for dsParComp) and when match-flattening lazy+-- patterns (see the Haddocks for mkSelectorDecs in L.H.TH.Desugar.Match).++-- | Make a tuple 'DExp' from a list of 'DExp's. Avoids using a 1-tuple.+mkTupleDExp :: [DExp] -> DExp+mkTupleDExp [exp] = exp+mkTupleDExp exps = foldl DAppE (DConE $ tupleDataName (length exps)) exps++-- | Make a tuple 'Exp' from a list of 'Exp's. Avoids using a 1-tuple.+mkTupleExp :: [Exp] -> Exp+mkTupleExp [exp] = exp+mkTupleExp exps = foldl AppE (ConE $ tupleDataName (length exps)) exps++-- | Make a tuple 'DPat' from a list of 'DPat's. Avoids using a 1-tuple.+mkTupleDPat :: [DPat] -> DPat+mkTupleDPat [pat] = pat+mkTupleDPat pats = DConP (tupleDataName (length pats)) [] pats++-- | Make a tuple 'DType' from a list of 'DType's. Avoids using a 1-tuple.+mkTupleDType :: [DType] -> DType+mkTupleDType [ty] = ty+mkTupleDType tys = foldl DAppT (DConT $ tupleTypeName (length tys)) tys++-- | Is this pattern guaranteed to match?+isUniversalPattern :: DsMonad q => DPat -> q Bool+isUniversalPattern (DLitP {}) = return False+isUniversalPattern (DVarP {}) = return True+isUniversalPattern (DConP con_name _ pats) = do+ data_name <- dataConNameToDataName con_name+ (_df, _tvbs, cons) <- getDataD "Internal error." data_name+ if length cons == 1+ then fmap and $ mapM isUniversalPattern pats+ else return False+isUniversalPattern (DTildeP {}) = return True+isUniversalPattern (DBangP pat) = isUniversalPattern pat+isUniversalPattern (DSigP pat _) = isUniversalPattern pat+isUniversalPattern DWildP = return True+isUniversalPattern (DTypeP _) = return True+isUniversalPattern (DInvisP _) = return True++-- | Apply one 'DExp' to a list of arguments+applyDExp :: DExp -> [DExp] -> DExp+applyDExp = foldl DAppE++-- | Apply one 'DType' to a list of arguments+applyDType :: DType -> [DTypeArg] -> DType+applyDType = foldl apply+ where+ apply :: DType -> DTypeArg -> DType+ apply f (DTANormal x) = f `DAppT` x+ apply f (DTyArg x) = f `DAppKindT` x++-- | An argument to a type, either a normal type ('DTANormal') or a visible+-- kind application ('DTyArg').+--+-- 'DTypeArg' does not appear directly in the @th-desugar@ AST, but it is+-- useful when decomposing an application of a 'DType' to its arguments.+data DTypeArg+ = DTANormal DType+ | DTyArg DKind+ deriving (Eq, Show, Data, Generic)++-- | Desugar a 'TypeArg'.+dsTypeArg :: DsMonad q => TypeArg -> q DTypeArg+dsTypeArg (TANormal t) = DTANormal <$> dsType t+dsTypeArg (TyArg k) = DTyArg <$> dsType k++-- | Filter the normal type arguments from a list of 'DTypeArg's.+filterDTANormals :: [DTypeArg] -> [DType]+filterDTANormals = mapMaybe getDTANormal+ where+ getDTANormal :: DTypeArg -> Maybe DType+ getDTANormal (DTANormal t) = Just t+ getDTANormal (DTyArg {}) = Nothing++-- | Convert a 'DTyVarBndr' into a 'DType'+dTyVarBndrToDType :: DTyVarBndr flag -> DType+dTyVarBndrToDType (DPlainTV a _) = DVarT a+dTyVarBndrToDType (DKindedTV a _ k) = DVarT a `DSigT` k++-- | Convert a 'DTyVarBndrVis' to a 'DTypeArg'. That is, convert a binder with a+-- 'BndrReq' visibility to a 'DTANormal' and a binder with 'BndrInvis'+-- visibility to a 'DTyArg'.+--+-- If given a 'DKindedTV', the resulting 'DTypeArg' will omit the kind+-- signature. Use 'dTyVarBndrVisToDTypeArgWithSig' if you want to preserve the+-- kind signature.+dTyVarBndrVisToDTypeArg :: DTyVarBndrVis -> DTypeArg+dTyVarBndrVisToDTypeArg bndr =+ case dtvbFlag bndr of+ BndrReq -> DTANormal bndr_ty+ BndrInvis -> DTyArg bndr_ty+ where+ bndr_ty = case bndr of+ DPlainTV a _ -> DVarT a+ DKindedTV a _ _ -> DVarT a++-- | Convert a 'DTyVarBndrVis' to a 'DTypeArg'. That is, convert a binder with a+-- 'BndrReq' visibility to a 'DTANormal' and a binder with 'BndrInvis'+-- visibility to a 'DTyArg'.+--+-- If given a 'DKindedTV', the resulting 'DTypeArg' will preserve the kind+-- signature. Use 'dTyVarBndrVisToDTypeArg' if you want to omit the kind+-- signature.+dTyVarBndrVisToDTypeArgWithSig :: DTyVarBndrVis -> DTypeArg+dTyVarBndrVisToDTypeArgWithSig bndr =+ case dtvbFlag bndr of+ BndrReq -> DTANormal bndr_ty+ BndrInvis -> DTyArg bndr_ty+ where+ bndr_ty = dTyVarBndrToDType bndr++-- | Extract the underlying 'DType' or 'DKind' from a 'DTypeArg'. This forgets+-- information about whether a type is a normal argument or not, so use with+-- caution.+probablyWrongUnDTypeArg :: DTypeArg -> DType+probablyWrongUnDTypeArg (DTANormal t) = t+probablyWrongUnDTypeArg (DTyArg k) = k++-- 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 -> [DTyVarBndrVis] -> DType+nonFamilyDataReturnType con_name =+ applyDType (DConT con_name) . map dTyVarBndrVisToDTypeArg++-- Take a data family name and apply it to its argument types to form a+-- data family instance DType.+dataFamInstReturnType :: Name -> [DTypeArg] -> DType+dataFamInstReturnType fam_name = applyDType (DConT fam_name)++-- Data family instance declarations did not come equipped with a list of bound+-- type variables until GHC 8.8 (and even then, it's optional whether the user+-- provides them or not). This means that there are situations where we must+-- reverse engineer this information ourselves from the list of type+-- arguments. 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 :: [DTypeArg] -> [DTyVarBndrUnit]+dataFamInstTvbs = toposortTyVarsOf . map probablyWrongUnDTypeArg++-- | Take a list of 'DType's, find their free variables, and sort them in+-- reverse topological order to ensure that they are well scoped. In other+-- words, the free variables are ordered such that:+--+-- 1. Whenever an explicit kind signature of the form @(A :: K)@ is+-- encountered, the free variables of @K@ will always appear to the left of+-- the free variables of @A@ in the returned result.+--+-- 2. The constraint in (1) notwithstanding, free variables will appear in+-- left-to-right order of their original appearance.+--+-- On older GHCs, this takes measures to avoid returning explicitly bound+-- kind variables, which was not possible before @TypeInType@.+toposortTyVarsOf :: [DType] -> [DTyVarBndrUnit]+toposortTyVarsOf tys =+ let freeVars :: [Name]+ freeVars = F.toList $ foldMap fvDType tys++ varKindSigs :: Map Name DKind+ varKindSigs = foldMap go_ty tys+ where+ go_ty :: DType -> Map Name DKind+ go_ty (DForallT tele t) = go_tele tele (go_ty t)+ go_ty (DConstrainedT ctxt t) = foldMap go_ty ctxt `mappend` go_ty t+ go_ty (DAppT t1 t2) = go_ty t1 `mappend` go_ty t2+ go_ty (DAppKindT t k) = go_ty t `mappend` go_ty k+ go_ty (DSigT t k) =+ let kSigs = go_ty k+ in case t of+ DVarT n -> M.insert n k kSigs+ _ -> go_ty t `mappend` kSigs+ go_ty (DVarT {}) = mempty+ go_ty (DConT {}) = mempty+ go_ty DArrowT = mempty+ go_ty (DLitT {}) = mempty+ go_ty DWildCardT = mempty++ go_tele :: DForallTelescope -> Map Name DKind -> Map Name DKind+ go_tele (DForallVis tvbs) = go_tvbs tvbs+ go_tele (DForallInvis tvbs) = go_tvbs tvbs++ go_tvbs :: [DTyVarBndr flag] -> Map Name DKind -> Map Name DKind+ go_tvbs tvbs m = foldr go_tvb m tvbs++ go_tvb :: DTyVarBndr flag -> Map Name DKind -> Map Name DKind+ go_tvb (DPlainTV n _) m = M.delete n m+ go_tvb (DKindedTV n _ k) m = M.delete n m `mappend` go_ty k++ -- | Do a topological sort on a list of tyvars,+ -- so that binders occur before occurrences+ -- E.g. given [ a::k, k::*, b::k ]+ -- it'll return a well-scoped list [ k::*, a::k, b::k ]+ --+ -- This is a deterministic sorting operation+ -- (that is, doesn't depend on Uniques).+ --+ -- It is also meant to be stable: that is, variables should not+ -- be reordered unnecessarily.+ scopedSort :: [Name] -> [Name]+ scopedSort = go [] []++ go :: [Name] -- already sorted, in reverse order+ -> [Set Name] -- each set contains all the variables which must be placed+ -- before the tv corresponding to the set; they are accumulations+ -- of the fvs in the sorted tvs' kinds++ -- This list is in 1-to-1 correspondence with the sorted tyvars+ -- INVARIANT:+ -- all (\tl -> all (`isSubsetOf` head tl) (tail tl)) (tails fv_list)+ -- That is, each set in the list is a superset of all later sets.+ -> [Name] -- yet to be sorted+ -> [Name]+ go acc _fv_list [] = reverse acc+ go acc fv_list (tv:tvs)+ = go acc' fv_list' tvs+ where+ (acc', fv_list') = insert tv acc fv_list++ insert :: Name -- var to insert+ -> [Name] -- sorted list, in reverse order+ -> [Set Name] -- list of fvs, as above+ -> ([Name], [Set Name]) -- augmented lists+ insert tv [] [] = ([tv], [kindFVSet tv])+ insert tv (a:as) (fvs:fvss)+ | tv `S.member` fvs+ , (as', fvss') <- insert tv as fvss+ = (a:as', fvs `S.union` fv_tv : fvss')++ | otherwise+ = (tv:a:as, fvs `S.union` fv_tv : fvs : fvss)+ where+ fv_tv = kindFVSet tv++ -- lists not in correspondence+ insert _ _ _ = error "scopedSort"++ kindFVSet n =+ maybe S.empty (OS.toSet . fvDType)+ (M.lookup n varKindSigs)+ ascribeWithKind n =+ maybe (DPlainTV n ()) (DKindedTV n ()) (M.lookup n varKindSigs)++ in map ascribeWithKind $+ scopedSort freeVars++-- | Take a telescope of 'DTyVarBndr's, find the free variables in their kinds,+-- and sort them in reverse topological order to ensure that they are well+-- scoped. Because the argument list is assumed to be telescoping, kind+-- variables that are bound earlier in the list are not returned. For example,+-- this:+--+-- @+-- 'toposortKindVarsOfTvbs' [a :: k, b :: Proxy a]+-- @+--+-- Will return @[k]@, not @[k, a]@, since @a@ is bound earlier by @a :: k@.+toposortKindVarsOfTvbs :: [DTyVarBndr flag] -> [DTyVarBndrUnit]+toposortKindVarsOfTvbs tvbs =+ foldr (\tvb kvs ->+ foldMap (\t -> toposortTyVarsOf [t]) (extractTvbKind tvb) `L.union`+ L.deleteBy ((==) `on` dtvbName) tvb kvs)+ []+ (changeDTVFlags () tvbs)++dtvbName :: DTyVarBndr flag -> Name+dtvbName (DPlainTV n _) = n+dtvbName (DKindedTV n _ _) = n++dtvbFlag :: DTyVarBndr flag -> flag+dtvbFlag (DPlainTV _ flag) = flag+dtvbFlag (DKindedTV _ flag _) = flag++-- | Map over the 'Name' of a 'DTyVarBndr'.+mapDTVName :: (Name -> Name) -> DTyVarBndr flag -> DTyVarBndr flag+mapDTVName f (DPlainTV name flag) = DPlainTV (f name) flag+mapDTVName f (DKindedTV name flag kind) = DKindedTV (f name) flag kind++-- | Map over the 'DKind' of a 'DTyVarBndr'.+mapDTVKind :: (DKind -> DKind) -> DTyVarBndr flag -> DTyVarBndr flag+mapDTVKind _ tvb@(DPlainTV{}) = tvb+mapDTVKind f (DKindedTV name flag kind) = DKindedTV name flag (f kind)++-- @mk_qual_do_name mb_mod orig_name@ will simply return @orig_name@ if+-- @mb_mod@ is Nothing. If @mb_mod@ is @Just mod_@, then a new 'Name' will be+-- returned that uses @mod_@ as the new module prefix. This is useful for+-- emulating the behavior of the @QualifiedDo@ extension, which adds module+-- prefixes to functions such as ('>>=') and ('>>').+mk_qual_do_name :: Maybe ModName -> Name -> Name+mk_qual_do_name mb_mod orig_name = case mb_mod of+ Nothing -> orig_name+ Just mod_ -> Name (OccName (nameBase orig_name)) (NameQ mod_)++-- | Reconstruct an arrow 'DType' from its argument and result types.+ravelDType :: DFunArgs -> DType -> DType+ravelDType DFANil res = res+ravelDType (DFAForalls tele args) res = DForallT tele (ravelDType args res)+ravelDType (DFACxt cxt args) res = DConstrainedT cxt (ravelDType args res)+ravelDType (DFAAnon t args) res = DAppT (DAppT DArrowT t) (ravelDType args res)++-- | Decompose a function 'DType' into its arguments (the 'DFunArgs') and its+-- result type (the 'DType).+unravelDType :: DType -> (DFunArgs, DType)+unravelDType (DForallT tele ty) =+ let (args, res) = unravelDType ty in+ (DFAForalls tele args, res)+unravelDType (DConstrainedT cxt ty) =+ let (args, res) = unravelDType ty in+ (DFACxt cxt args, res)+unravelDType (DAppT (DAppT DArrowT t1) t2) =+ let (args, res) = unravelDType t2 in+ (DFAAnon t1 args, res)+unravelDType t = (DFANil, t)++-- | The list of arguments in a function 'DType'.+data DFunArgs+ = DFANil+ -- ^ No more arguments.+ | DFAForalls DForallTelescope DFunArgs+ -- ^ A series of @forall@ed type variables followed by a dot (if+ -- 'ForallInvis') or an arrow (if 'ForallVis'). For example,+ -- the type variables @a1 ... an@ in @forall a1 ... an. r@.+ | DFACxt DCxt DFunArgs+ -- ^ A series of constraint arguments followed by @=>@. For example,+ -- the @(c1, ..., cn)@ in @(c1, ..., cn) => r@.+ | DFAAnon DType DFunArgs+ -- ^ An anonymous argument followed by an arrow. For example, the @a@+ -- in @a -> r@.+ deriving (Eq, Show, Data, Generic)++-- | A /visible/ function argument type (i.e., one that must be supplied+-- explicitly in the source code). This is in contrast to /invisible/+-- arguments (e.g., the @c@ in @c => r@), which are instantiated without+-- the need for explicit user input.+data DVisFunArg+ = DVisFADep DTyVarBndrUnit+ -- ^ A visible @forall@ (e.g., @forall a -> a@).+ | DVisFAAnon DType+ -- ^ An anonymous argument followed by an arrow (e.g., @a -> r@).+ deriving (Eq, Show, Data, Generic)++-- | Filter the visible function arguments from a list of 'DFunArgs'.+filterDVisFunArgs :: DFunArgs -> [DVisFunArg]+filterDVisFunArgs DFANil = []+filterDVisFunArgs (DFAForalls tele args) =+ case tele of+ DForallVis tvbs -> map DVisFADep tvbs ++ args'+ DForallInvis _ -> args'+ where+ args' = filterDVisFunArgs args+filterDVisFunArgs (DFACxt _ args) =+ filterDVisFunArgs args+filterDVisFunArgs (DFAAnon t args) =+ DVisFAAnon t:filterDVisFunArgs args++-- | Decompose an applied type into its individual components. For example, this:+--+-- @+-- Proxy \@Type Char+-- @+--+-- would be unfolded to this:+--+-- @+-- ('DConT' ''Proxy, ['DTyArg' ('DConT' ''Type), 'DTANormal' ('DConT' ''Char)])+-- @+unfoldDType :: DType -> (DType, [DTypeArg])+unfoldDType = go []+ where+ go :: [DTypeArg] -> DType -> (DType, [DTypeArg])+ go acc (DForallT _ ty) = go acc ty+ go acc (DAppT ty1 ty2) = go (DTANormal ty2:acc) ty1+ go acc (DAppKindT ty ki) = go (DTyArg ki:acc) ty+ go acc (DSigT ty _) = go acc ty+ go acc ty = (ty, acc)++-- | Extract the kind from a 'DTyVarBndr', if one is present.+extractTvbKind :: DTyVarBndr flag -> Maybe DKind+extractTvbKind (DPlainTV _ _) = Nothing+extractTvbKind (DKindedTV _ _ k) = Just k++-- | Set the flag in a list of 'DTyVarBndr's. This is often useful in contexts+-- where one needs to re-use a list of 'DTyVarBndr's from one flag setting to+-- another flag setting. For example, in order to re-use the 'DTyVarBndr's bound+-- by a 'DDataD' in a 'DForallT', one can do the following:+--+-- @+-- case x of+-- 'DDataD' _ _ _ tvbs _ _ _ ->+-- 'DForallT' ('DForallInvis' ('changeDTVFlags' 'SpecifiedSpec' tvbs)) ...+-- @+changeDTVFlags :: newFlag -> [DTyVarBndr oldFlag] -> [DTyVarBndr newFlag]+changeDTVFlags new_flag = map (new_flag <$)++-- @'dMatchUpSAKWithDecl' decl_sak decl_bndrs@ produces @'DTyVarBndr'+-- 'ForAllTyFlag'@s for a declaration, using the original declaration's+-- standalone kind signature (@decl_sak@) and its user-written binders+-- (@decl_bndrs@) as a template. For this example:+--+-- @+-- type D :: forall j k. k -> j -> Type+-- data D \@j \@l (a :: l) b = ...+-- @+--+-- We would produce the following @'DTyVarBndr' 'ForAllTyFlag'@s:+--+-- @+-- \@j \@l (a :: l) (b :: j)+-- @+--+-- From here, these @'DTyVarBndr' 'ForAllTyFlag'@s can be converted into other+-- forms of 'DTyVarBndr's:+--+-- * They can be converted to 'DTyVarBndrSpec's using 'dtvbForAllTyFlagsToSpecs'.+--+-- * They can be converted to 'DTyVarBndrVis'es using 'tvbForAllTyFlagsToVis'.+--+-- Note that:+--+-- * This function has a precondition that the length of @decl_bndrs@ must+-- always be equal to the number of visible quantifiers (i.e., the number of+-- function arrows plus the number of visible @forall@–bound variables) in+-- @decl_sak@.+--+-- * Whenever possible, this function reuses type variable names from the+-- declaration's user-written binders. This is why the @'DTyVarBndr'+-- 'ForAllTyFlag'@ use @\@j \@l@ instead of @\@j \@k@, since the @(a :: l)@+-- binder uses @l@ instead of @k@. We could have just as well chose the other+-- way around, but we chose to pick variable names from the user-written+-- binders since they scope over other parts of the declaration. (For example,+-- the user-written binders of a @data@ declaration scope over the type+-- variables mentioned in a @deriving@ clause.) As such, keeping these names+-- avoids having to perform some alpha-renaming.+--+-- This function's implementation was heavily inspired by parts of GHC's+-- kcCheckDeclHeader_sig function:+-- https://gitlab.haskell.org/ghc/ghc/-/blob/1464a2a8de082f66ae250d63ab9d94dbe2ef8620/compiler/GHC/Tc/Gen/HsType.hs#L2524-2643+dMatchUpSAKWithDecl ::+ forall q.+ Fail.MonadFail q+ => DKind+ -- ^ The declaration's standalone kind signature+ -> [DTyVarBndrVis]+ -- ^ The user-written binders in the declaration+ -> q [DTyVarBndr ForAllTyFlag]+dMatchUpSAKWithDecl decl_sak decl_bndrs = do+ -- (1) First, explicitly quantify any free kind variables in `decl_sak` using+ -- an invisible @forall@. This is done to ensure that precondition (2) in+ -- `dMatchUpSigWithDecl` is upheld. (See the Haddocks for that function).+ let decl_sak_free_tvbs =+ changeDTVFlags SpecifiedSpec $ toposortTyVarsOf [decl_sak]+ decl_sak' = DForallT (DForallInvis decl_sak_free_tvbs) decl_sak++ -- (2) Next, compute type variable binders using `dMatchUpSigWithDecl`. Note+ -- that these can be biased towards type variable names mention in `decl_sak`+ -- over names mentioned in `decl_bndrs`, but we will fix that up in the next+ -- step.+ let (decl_sak_args, _) = unravelDType decl_sak'+ sing_sak_tvbs <- dMatchUpSigWithDecl decl_sak_args decl_bndrs++ -- (3) Finally, swizzle the type variable names so that names in `decl_bndrs`+ -- are preferred over names in `decl_sak`.+ --+ -- This is heavily inspired by similar code in GHC:+ -- https://gitlab.haskell.org/ghc/ghc/-/blob/cec903899234bf9e25ea404477ba846ac1e963bb/compiler/GHC/Tc/Gen/HsType.hs#L2607-2616+ let invis_decl_sak_args = filterInvisTvbArgs decl_sak_args+ invis_decl_sak_arg_nms = map dtvbName invis_decl_sak_args++ invis_decl_bndrs = toposortKindVarsOfTvbs decl_bndrs+ invis_decl_bndr_nms = map dtvbName invis_decl_bndrs++ swizzle_env =+ M.fromList $ zip invis_decl_sak_arg_nms invis_decl_bndr_nms+ (_, swizzled_sing_sak_tvbs) =+ mapAccumL (swizzleTvb swizzle_env) M.empty sing_sak_tvbs+ pure swizzled_sing_sak_tvbs++-- Match the quantifiers in a type-level declaration's standalone kind signature+-- with the user-written binders in the declaration. This function assumes the+-- following preconditions:+--+-- 1. The number of required binders in the declaration's user-written binders+-- is equal to the number of visible quantifiers (i.e., the number of+-- function arrows plus the number of visible @forall@–bound variables) in+-- the standalone kind signature.+--+-- 2. The number of invisible \@-binders in the declaration's user-written+-- binders is less than or equal to the number of invisible quantifiers+-- (i.e., the number of invisible @forall@–bound variables) in the+-- standalone kind signature.+--+-- The implementation of this function is heavily based on a GHC function of+-- the same name:+-- https://gitlab.haskell.org/ghc/ghc/-/blob/1464a2a8de082f66ae250d63ab9d94dbe2ef8620/compiler/GHC/Tc/Gen/HsType.hs#L2645-2715+dMatchUpSigWithDecl ::+ forall q.+ Fail.MonadFail q+ => DFunArgs+ -- ^ The quantifiers in the declaration's standalone kind signature+ -> [DTyVarBndrVis]+ -- ^ The user-written binders in the declaration+ -> q [DTyVarBndr ForAllTyFlag]+dMatchUpSigWithDecl = go_fun_args M.empty+ where+ go_fun_args ::+ DSubst+ -- ^ A substitution from the names of @forall@-bound variables in the+ -- standalone kind signature to corresponding binder names in the+ -- user-written binders. This is because we want to reuse type variable+ -- names from the user-written binders whenever possible. For example:+ --+ -- @+ -- type T :: forall a. forall b -> Maybe (a, b) -> Type+ -- data T @x y z+ -- @+ --+ -- After matching up the @a@ in @forall a.@ with @x@ and+ -- the @b@ in @forall b ->@ with @y@, this substitution will be+ -- extended with @[a :-> x, b :-> y]@. This ensures that we will+ -- produce @Maybe (x, y)@ instead of @Maybe (a, b)@ in+ -- the kind for @z@.+ -> DFunArgs -> [DTyVarBndrVis] -> q [DTyVarBndr ForAllTyFlag]+ go_fun_args _ DFANil [] =+ pure []+ -- This should not happen, per precondition (1).+ go_fun_args _ DFANil decl_bndrs =+ fail $ "dMatchUpSigWithDecl.go_fun_args: Too many binders: " ++ show decl_bndrs+ -- GHC now disallows kind-level constraints, per this GHC proposal:+ -- https://github.com/ghc-proposals/ghc-proposals/blob/b0687d96ce8007294173b7f628042ac4260cc738/proposals/0547-no-kind-equalities.rst+ -- As such, we reject non-empty kind contexts. Empty contexts (which are+ -- benign) can sometimes arise due to @ForallT@, so we add a special case+ -- to allow them.+ go_fun_args subst (DFACxt [] args) decl_bndrs =+ go_fun_args subst args decl_bndrs+ go_fun_args _ (DFACxt{}) _ =+ fail "dMatchUpSigWithDecl.go_fun_args: Unexpected kind-level constraint"+ go_fun_args subst (DFAForalls (DForallInvis tvbs) sig_args) decl_bndrs =+ go_invis_tvbs subst tvbs sig_args decl_bndrs+ go_fun_args subst (DFAForalls (DForallVis tvbs) sig_args) decl_bndrs =+ go_vis_tvbs subst tvbs sig_args decl_bndrs+ go_fun_args subst (DFAAnon anon sig_args) (decl_bndr:decl_bndrs) =+ case dtvbFlag decl_bndr of+ -- If the next decl_bndr is required, then we must match its kind (if+ -- one is provided) against the anonymous kind argument.+ BndrReq -> do+ let decl_bndr_name = dtvbName decl_bndr+ mb_decl_bndr_kind = extractTvbKind decl_bndr+ anon' = SC.substTy subst anon++ anon'' =+ case mb_decl_bndr_kind of+ Nothing -> anon'+ Just decl_bndr_kind ->+ let mb_match_subst = matchTy NoIgnore decl_bndr_kind anon' in+ maybe decl_bndr_kind (`SC.substTy` decl_bndr_kind) mb_match_subst+ sig_args' <- go_fun_args subst sig_args decl_bndrs+ pure $ DKindedTV decl_bndr_name Required anon'' : sig_args'+ -- We have a visible, anonymous argument in the kind, but an invisible+ -- @-binder as the next decl_bndr. This is ill kinded, so throw an+ -- error.+ --+ -- This should not happen, per precondition (2).+ BndrInvis ->+ fail $ "dMatchUpSigWithDecl.go_fun_args: Expected visible binder, encountered invisible binder: "+ ++ show decl_bndr+ -- This should not happen, per precondition (1).+ go_fun_args _ _ [] =+ fail "dMatchUpSigWithDecl.go_fun_args: Too few binders"++ go_invis_tvbs :: DSubst -> [DTyVarBndrSpec] -> DFunArgs -> [DTyVarBndrVis] -> q [DTyVarBndr ForAllTyFlag]+ go_invis_tvbs subst [] sig_args decl_bndrs =+ go_fun_args subst sig_args decl_bndrs+ go_invis_tvbs subst (invis_tvb:invis_tvbs) sig_args decl_bndrss =+ case decl_bndrss of+ [] -> skip_invis_bndr+ decl_bndr:decl_bndrs ->+ case dtvbFlag decl_bndr of+ BndrReq -> skip_invis_bndr+ -- If the next decl_bndr is an invisible @-binder, then we must match it+ -- against the invisible forall–bound variable in the kind.+ BndrInvis -> do+ let (subst', sig_tvb) = match_tvbs subst invis_tvb decl_bndr+ sig_args' <- go_invis_tvbs subst' invis_tvbs sig_args decl_bndrs+ pure (fmap Invisible sig_tvb : sig_args')+ where+ -- There is an invisible forall in the kind without a corresponding+ -- invisible @-binder, which is allowed. In this case, we simply apply+ -- the substitution and recurse.+ skip_invis_bndr :: q [DTyVarBndr ForAllTyFlag]+ skip_invis_bndr = do+ let (subst', invis_tvb') = SC.substTyVarBndr subst invis_tvb+ sig_args' <- go_invis_tvbs subst' invis_tvbs sig_args decl_bndrss+ pure $ fmap Invisible invis_tvb' : sig_args'++ go_vis_tvbs :: DSubst -> [DTyVarBndrUnit] -> DFunArgs -> [DTyVarBndrVis] -> q [DTyVarBndr ForAllTyFlag]+ go_vis_tvbs subst [] sig_args decl_bndrs =+ go_fun_args subst sig_args decl_bndrs+ -- This should not happen, per precondition (1).+ go_vis_tvbs _ (_:_) _ [] =+ fail "dMatchUpSigWithDecl.go_vis_tvbs: Too few binders"+ go_vis_tvbs subst (vis_tvb:vis_tvbs) sig_args (decl_bndr:decl_bndrs) = do+ case dtvbFlag decl_bndr of+ -- If the next decl_bndr is required, then we must match it against the+ -- visible forall–bound variable in the kind.+ BndrReq -> do+ let (subst', sig_tvb) = match_tvbs subst vis_tvb decl_bndr+ sig_args' <- go_vis_tvbs subst' vis_tvbs sig_args decl_bndrs+ pure ((Required <$ sig_tvb) : sig_args')+ -- We have a visible forall in the kind, but an invisible @-binder as+ -- the next decl_bndr. This is ill kinded, so throw an error.+ --+ -- This should not happen, per precondition (2).+ BndrInvis ->+ fail $ "dMatchUpSigWithDecl.go_vis_tvbs: Expected visible binder, encountered invisible binder: "+ ++ show decl_bndr++ -- @match_tvbs subst sig_tvb decl_bndr@ will match the kind of @decl_bndr@+ -- against the kind of @sig_tvb@ to produce a new kind. This function+ -- produces two values as output:+ --+ -- 1. A new @subst@ that has been extended such that the name of @sig_tvb@+ -- maps to the name of @decl_bndr@. (See the Haddocks for the 'DSubst'+ -- argument to @go_fun_args@ for an explanation of why we do this.)+ --+ -- 2. A 'DTyVarBndrSpec' that has the name of @decl_bndr@, but with the new+ -- kind resulting from matching.+ match_tvbs :: DSubst -> DTyVarBndr flag -> DTyVarBndrVis -> (DSubst, DTyVarBndr flag)+ match_tvbs subst sig_tvb decl_bndr =+ let decl_bndr_name = dtvbName decl_bndr+ mb_decl_bndr_kind = extractTvbKind decl_bndr++ sig_tvb_name = dtvbName sig_tvb+ sig_tvb_flag = dtvbFlag sig_tvb+ mb_sig_tvb_kind = SC.substTy subst <$> extractTvbKind sig_tvb++ mb_kind :: Maybe DKind+ mb_kind =+ case (mb_decl_bndr_kind, mb_sig_tvb_kind) of+ (Nothing, Nothing) -> Nothing+ (Just decl_bndr_kind, Nothing) -> Just decl_bndr_kind+ (Nothing, Just sig_tvb_kind) -> Just sig_tvb_kind+ (Just decl_bndr_kind, Just sig_tvb_kind) -> do+ match_subst <- matchTy NoIgnore decl_bndr_kind sig_tvb_kind+ Just $ SC.substTy match_subst decl_bndr_kind++ subst' = M.insert sig_tvb_name (DVarT decl_bndr_name) subst+ sig_tvb' = case mb_kind of+ Nothing -> DPlainTV decl_bndr_name sig_tvb_flag+ Just kind -> DKindedTV decl_bndr_name sig_tvb_flag kind in++ (subst', sig_tvb')++-- Collect the invisible type variable binders from a sequence of DFunArgs.+filterInvisTvbArgs :: DFunArgs -> [DTyVarBndrSpec]+filterInvisTvbArgs DFANil = []+filterInvisTvbArgs (DFACxt _ args) = filterInvisTvbArgs args+filterInvisTvbArgs (DFAAnon _ args) = filterInvisTvbArgs args+filterInvisTvbArgs (DFAForalls tele args) =+ let res = filterInvisTvbArgs args in+ case tele of+ DForallVis _ -> res+ DForallInvis tvbs' -> tvbs' ++ res++-- This is heavily inspired by the `swizzleTcb` function in GHC:+-- https://gitlab.haskell.org/ghc/ghc/-/blob/cec903899234bf9e25ea404477ba846ac1e963bb/compiler/GHC/Tc/Gen/HsType.hs#L2741-2755+swizzleTvb ::+ Map Name Name+ -- ^ A \"swizzle environment\" (i.e., a map from binder names in a+ -- standalone kind signature to binder names in the corresponding+ -- type-level declaration).+ -> DSubst+ -- ^ Like the swizzle environment, but as a full-blown substitution.+ -> DTyVarBndr flag+ -> (DSubst, DTyVarBndr flag)+swizzleTvb swizzle_env subst tvb =+ (subst', tvb2)+ where+ subst' = M.insert tvb_name (DVarT (dtvbName tvb2)) subst+ tvb_name = dtvbName tvb+ tvb1 = mapDTVKind (SC.substTy subst) tvb+ tvb2 =+ case M.lookup tvb_name swizzle_env of+ Just user_name -> mapDTVName (const user_name) tvb1+ Nothing -> tvb1++-- | Convert a list of @'DTyVarBndr' 'ForAllTyFlag'@s to a list of+-- 'DTyVarBndrSpec's, which is suitable for use in an invisible @forall@.+-- Specifically:+--+-- * Variable binders that use @'Invisible' spec@ are converted to @spec@.+--+-- * Variable binders that are 'Required' are converted to 'SpecifiedSpec',+-- as all of the 'DTyVarBndrSpec's are invisible. As an example of how this+-- is used, consider what would happen when singling this data type:+--+-- @+-- type T :: forall k -> k -> Type+-- data T k (a :: k) where ...+-- @+--+-- Here, the @k@ binder is 'Required'. When we produce the standalone kind+-- signature for the singled data type, we use 'dtvbForAllTyFlagsToSpecs' to+-- produce the type variable binders in the outermost @forall@:+--+-- @+-- type ST :: forall k (a :: k). T k a -> Type+-- data ST z where ...+-- @+--+-- Note that the @k@ is bound visibily (i.e., using 'SpecifiedSpec') in the+-- outermost, invisible @forall@.+dtvbForAllTyFlagsToSpecs :: [DTyVarBndr ForAllTyFlag] -> [DTyVarBndrSpec]+dtvbForAllTyFlagsToSpecs = map (fmap to_spec)+ where+ to_spec :: ForAllTyFlag -> Specificity+ to_spec (Invisible spec) = spec+ to_spec Required = SpecifiedSpec++-- | Convert a list of @'DTyVarBndr' 'ForAllTyFlag'@s to a list of+-- 'DTyVarBndrVis'es, which is suitable for use in a type-level declaration+-- (e.g., the @var_1 ... var_n@ in @class C var_1 ... var_n@). Specifically:+--+-- * Variable binders that use @'Invisible' 'InferredSpec'@ are dropped+-- entirely. Such binders cannot be represented in source Haskell.+--+-- * Variable binders that use @'Invisible' 'SpecifiedSpec'@ are converted to+-- 'BndrInvis'.+--+-- * Variable binders that are 'Required' are converted to 'BndrReq'.+dtvbForAllTyFlagsToBndrVis :: [DTyVarBndr ForAllTyFlag] -> [DTyVarBndrVis]+dtvbForAllTyFlagsToBndrVis = catMaybes . map (traverse to_spec_maybe)+ where+ to_spec_maybe :: ForAllTyFlag -> Maybe BndrVis+ to_spec_maybe (Invisible InferredSpec) = Nothing+ to_spec_maybe (Invisible SpecifiedSpec) = Just bndrInvis+ to_spec_maybe Required = Just BndrReq++-- | Some functions in this module only use certain arguments on particular+-- versions of GHC. Other versions of GHC (that don't make use of those+-- arguments) might need to conjure up those arguments out of thin air at the+-- functions' call sites, so this function serves as a placeholder to use in+-- those situations. (In other words, this is a slightly more informative+-- version of 'undefined'.)+unusedArgument :: a+unusedArgument = error "Unused"++{-+Note [Desugaring and sweetening ForallT]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The ForallT constructor from template-haskell is tremendously awkward. Because+ForallT contains both a list of type variable binders and constraint arguments,+ForallT expressions can be ambiguous when one of these lists is empty. For+example, consider this expression with no constraints:++ ForallT [PlainTV a] [] (VarT a)++What should this desugar to in th-desugar, which must maintain a clear+separation between type variable binders and constraints? There are two+possibilities:++1. DForallT DForallInvis [DPlainTV a] (DVarT a)+ (i.e., forall a. a)+2. DForallT DForallInvis [DPlainTV a] (DConstrainedT [] (DVarT a))+ (i.e., forall a. () => a)++Template Haskell generally drops these empty lists when splicing Template+Haskell expressions, so we would like to do the same in th-desugar to mimic+TH's behavior as closely as possible. However, there are some situations where+dropping empty lists of `forall`ed type variable binders can change the+semantics of a program. For instance, contrast `foo :: forall. a -> a` (which+is an error) with `foo :: a -> a` (which is fine). Therefore, we try to+preserve empty `forall`s to the best of our ability.++Here is an informal specification of how th-desugar should handle different sorts+of ambiguity. First, a specification for desugaring.+Let `tvbs` and `ctxt` be non-empty:++* `ForallT tvbs [] ty` should desugar to `DForallT DForallInvis tvbs ty`.+* `ForallT [] ctxt ty` should desguar to `DForallT DForallInvis [] (DConstrainedT ctxt ty)`.+* `ForallT [] [] ty` should desugar to `DForallT DForallInvis [] ty`.+* For all other cases, just straightforwardly desugar+ `ForallT tvbs ctxt ty` to `DForallT DForallInvis tvbs (DConstraintedT ctxt ty)`.++For sweetening:++* `DForallT DForallInvis tvbs (DConstrainedT ctxt ty)` should sweeten to `ForallT tvbs ctxt ty`.+* `DForallT DForallInvis [] (DConstrainedT ctxt ty)` should sweeten to `ForallT [] ctxt ty`.+* `DForallT DForallInvis tvbs (DConstrainedT [] ty)` should sweeten to `ForallT tvbs [] ty`.+* `DForallT DForallInvis [] (DConstrainedT [] ty)` should sweeten to `ForallT [] [] ty`.+* For all other cases, just straightforwardly sweeten+ `DForallT DForallInvis tvbs ty` to `ForallT tvbs [] ty` and+ `DConstrainedT ctxt ty` to `ForallT [] ctxt ty`. -}
Language/Haskell/TH/Desugar/FV.hs view
@@ -41,18 +41,21 @@ -- | Extract the term variables bound by a 'DPat'. ----- This does /not/ extract any type variables bound by pattern signatures.+-- This does /not/ extract any type variables bound by pattern signatures,+-- constructor patterns, or type patterns. extractBoundNamesDPat :: DPat -> OSet Name extractBoundNamesDPat = go where go :: DPat -> OSet Name- go (DLitP _) = OS.empty- go (DVarP n) = OS.singleton n- go (DConP _ tys pats) = foldMap fvDType tys <> foldMap go pats- go (DTildeP p) = go p- go (DBangP p) = go p- go (DSigP p _) = go p- go DWildP = OS.empty+ go (DLitP _) = OS.empty+ go (DVarP n) = OS.singleton n+ go (DConP _ _ pats) = foldMap go pats+ go (DTildeP p) = go p+ go (DBangP p) = go p+ go (DSigP p _) = go p+ go DWildP = OS.empty+ go (DTypeP _) = OS.empty+ go (DInvisP _) = OS.empty ----- -- Binding forms
Language/Haskell/TH/Desugar/Lift.hs view
@@ -7,36 +7,12 @@ -- Stability : experimental -- Portability : non-portable ----- Defines @Lift@ instances for the desugared language. This is defined--- in a separate module because it also must define @Lift@ instances for--- several TH types, which are orphans and may want another definition--- downstream.+-- Historically, this module defined orphan @Lift@ instances for the data types+-- in @th-desugar@. Nowadays, these instances are defined alongside the data+-- types themselves, so this module simply re-exports the instances. -- ---------------------------------------------------------------------------- -{-# LANGUAGE CPP, TemplateHaskell #-}-{-# OPTIONS_GHC -Wno-orphans #-}- module Language.Haskell.TH.Desugar.Lift () where -import Language.Haskell.TH.Desugar-import Language.Haskell.TH.Instances ()-import Language.Haskell.TH.Lift--$(deriveLiftMany [ ''DExp, ''DPat, ''DType, ''DForallTelescope, ''DTyVarBndr- , ''DMatch, ''DClause, ''DLetDec, ''DDec, ''DDerivClause, ''DCon- , ''DConFields, ''DForeign, ''DPragma, ''DRuleBndr, ''DTySynEqn- , ''DPatSynDir , ''NewOrData, ''DDerivStrategy- , ''DTypeFamilyHead, ''DFamilyResultSig-#if __GLASGOW_HASKELL__ < 801- , ''PatSynArgs-#endif-#if __GLASGOW_HASKELL__ < 900- , ''Specificity-#endif-- , ''TypeArg, ''DTypeArg- , ''FunArgs, ''DFunArgs- , ''VisFunArg, ''DVisFunArg- , ''ForallTelescope- ])+import Language.Haskell.TH.Desugar ()
Language/Haskell/TH/Desugar/Match.hs view
@@ -20,6 +20,8 @@ import Data.Data import qualified Data.Foldable as F import Data.Generics+import qualified Data.List.NonEmpty as NE+import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.Set as S import qualified Data.Map as Map import Language.Haskell.TH.Instances ()@@ -38,41 +40,62 @@ -- a 'DLitPa', or a 'DWildPa'. scExp :: DsMonad q => DExp -> q DExp scExp (DAppE e1 e2) = DAppE <$> scExp e1 <*> scExp e2-scExp (DLamE names exp) = DLamE names <$> scExp exp-scExp (DCaseE scrut matches)- | DVarE name <- scrut- = simplCaseExp [name] clauses- | otherwise- = do scrut_name <- newUniqueName "scrut"- case_exp <- simplCaseExp [scrut_name] clauses- return $ DLetE [DValD (DVarP scrut_name) scrut] case_exp- where- clauses = map match_to_clause matches- match_to_clause (DMatch pat exp) = DClause [pat] exp-+scExp (DLamCasesE clauses) = do+ -- Per the Haddocks for DLamCasesE, an empty list of clauses indicates that+ -- the overall `\cases` expression takes one argument. Otherwise, we look at+ -- the first clause to see how many arguments the expression takes, as each+ -- clause is required to have the same number of patterns.+ let num_args =+ case clauses of+ [] -> 1+ DClause pats _ : _ -> length pats+ clause' <- scClauses num_args clauses+ pure $ DLamCasesE [clause'] scExp (DLetE decs body) = DLetE <$> mapM scLetDec decs <*> scExp body scExp (DSigE exp ty) = DSigE <$> scExp exp <*> pure ty scExp (DAppTypeE exp ty) = DAppTypeE <$> scExp exp <*> pure ty+scExp (DTypedBracketE exp) = DTypedBracketE <$> scExp exp+scExp (DTypedSpliceE exp) = DTypedSpliceE <$> scExp exp+scExp (DForallE tele exp) = DForallE tele <$> scExp exp+scExp (DConstrainedE cxt exp) = DConstrainedE <$> mapM scExp cxt <*> scExp exp scExp e@(DVarE {}) = return e scExp e@(DConE {}) = return e scExp e@(DLitE {}) = return e scExp e@(DStaticE {}) = return e+scExp e@(DTypeE {}) = return e -- | Like 'scExp', but for a 'DLetDec'. scLetDec :: DsMonad q => DLetDec -> q DLetDec-scLetDec (DFunD name clauses@(DClause pats1 _ : _)) = do- arg_names <- mapM (const (newUniqueName "_arg")) pats1- clauses' <- mapM sc_clause_rhs clauses- case_exp <- simplCaseExp arg_names clauses'- return $ DFunD name [DClause (map DVarP arg_names) case_exp]- where- sc_clause_rhs (DClause pats exp) = DClause pats <$> scExp exp+scLetDec (DFunD name clauses) = do+ -- `DFunD`s are expected to have a non-empty list of clauses where each clause+ -- has a number of patterns equal to the number of arguments.+ let num_args =+ case clauses of+ [] -> error $ "The `" ++ nameBase name +++ "` function has no clauses -- should never happen"+ DClause pats _ : _ -> length pats+ clause' <- scClauses num_args clauses+ pure $ DFunD name [clause'] scLetDec (DValD pat exp) = DValD pat <$> scExp exp scLetDec (DPragmaD prag) = DPragmaD <$> scLetPragma prag scLetDec dec@(DSigD {}) = return dec scLetDec dec@(DInfixD {}) = return dec-scLetDec dec@(DFunD _ []) = return dec +-- | Convert a list of 'DClause's into a single 'DClause', where the right-hand+-- side of the output 'DClause' matches on all of the patterns of the input+-- 'DClause's without using nested pattern matching.+scClauses ::+ DsMonad q+ => Int -- ^ The number of arguments in each 'DClause'.+ -> [DClause] -> q DClause+scClauses num_args clauses = do+ arg_names <- replicateM num_args (newUniqueName "_arg")+ clauses' <- mapM sc_clause_rhs clauses+ case_exp <- simplCaseExp arg_names clauses'+ pure $ DClause (map DVarP arg_names) case_exp+ where+ sc_clause_rhs (DClause pats exp) = DClause pats <$> scExp exp+ scLetPragma :: DsMonad q => DPragma -> q DPragma scLetPragma = topEverywhereM scExp -- Only topEverywhereM because scExp already recurses on its own @@ -89,11 +112,17 @@ -> [DClause] -> q DExp simplCaseExp vars clauses =- do let eis = [ EquationInfo pats (\_ -> rhs) |+ do let eis = [ EquationInfo (to_ne_pats pats) (\_ -> rhs) | DClause pats rhs <- clauses ] matchResultToDExp `liftM` simplCase vars eis+ where+ to_ne_pats :: [DPat] -> NonEmpty DPat+ to_ne_pats pats =+ case pats of+ p:ps -> p:|ps+ [] -> error "Clause encountered with no patterns -- should never happen" -data EquationInfo = EquationInfo [DPat] MatchResult -- like DClause, but with a hole+data EquationInfo = EquationInfo (NonEmpty DPat) MatchResult -- like DClause, but with a hole -- analogous to GHC's match (in deSugar/Match.lhs) simplCase :: DsMonad q@@ -103,35 +132,35 @@ simplCase [] clauses = return (foldr1 (.) match_results) where match_results = [ mr | EquationInfo _ mr <- clauses ]-simplCase vars@(v:_) clauses = do+simplCase (v:vs) clauses = do (aux_binds, tidy_clauses) <- mapAndUnzipM (tidyClause v) clauses let grouped = groupClauses tidy_clauses match_results <- match_groups grouped return (adjustMatchResult (foldr (.) id aux_binds) $ foldr1 (.) match_results) where- match_groups :: DsMonad q => [[(PatGroup, EquationInfo)]] -> q [MatchResult]+ match_groups :: DsMonad q => [NonEmpty (PatGroup, EquationInfo)] -> q [MatchResult] match_groups [] = matchEmpty v match_groups gs = mapM match_group gs - match_group :: DsMonad q => [(PatGroup, EquationInfo)] -> q MatchResult- match_group [] = error "Internal error in th-desugar (match_group)"- match_group eqns@((group,_) : _) =+ match_group :: DsMonad q => NonEmpty (PatGroup, EquationInfo) -> q MatchResult+ match_group eqns@((group,_) :| _) = case group of- PgCon _ -> matchConFamily vars (subGroup [(c,e) | (PgCon c, e) <- eqns])- PgLit _ -> matchLiterals vars (subGroup [(l,e) | (PgLit l, e) <- eqns])- PgBang -> matchBangs vars (drop_group eqns)- PgAny -> matchVariables vars (drop_group eqns)+ PgCon _ -> matchConFamily vars $ subGroup [(c,e) | (PgCon c, e) <- NE.toList eqns]+ PgLit _ -> matchLiterals vars $ subGroup [(l,e) | (PgLit l, e) <- NE.toList eqns]+ PgBang -> matchBangs vars $ drop_group eqns+ PgAny -> matchVariables vars $ drop_group eqns - drop_group = map snd+ drop_group :: NonEmpty (PatGroup, EquationInfo) -> NonEmpty EquationInfo+ drop_group = fmap snd + vars = v:|vs+ -- analogous to GHC's tidyEqnInfo tidyClause :: DsMonad q => Name -> EquationInfo -> q (DExp -> DExp, EquationInfo)-tidyClause _ (EquationInfo [] _) =- error "Internal error in th-desugar: no patterns in tidyClause."-tidyClause v (EquationInfo (pat : pats) body) = do+tidyClause v (EquationInfo (pat :| pats) body) = do (wrap, pat') <- tidy1 v pat- return (wrap, EquationInfo (pat' : pats) body)+ return (wrap, EquationInfo (pat' :| pats) body) tidy1 :: DsMonad q => Name -- the name of the variable that ...@@ -152,6 +181,8 @@ DBangP p -> tidy1 v (DBangP p) -- discard ! under ! DSigP p _ -> tidy1 v (DBangP p) -- discard sig under ! DWildP -> return (id, DBangP pat) -- no change+ DTypeP _ -> return (id, DBangP pat) -- no change+ DInvisP _ -> return (id, DBangP pat) -- no change tidy1 v (DSigP pat ty) | no_tyvars_ty ty = tidy1 v pat -- The match-flattener doesn't know how to deal with patterns that mention@@ -168,13 +199,42 @@ no_tyvar_ty (DVarT{}) = False no_tyvar_ty t = gmapQl (&&) True no_tyvars_ty t tidy1 _ DWildP = return (id, DWildP)+tidy1 _ (DTypeP ty) = return (id, DTypeP ty)+tidy1 _ (DInvisP ty) = return (id, DInvisP ty) wrapBind :: Name -> Name -> DExp -> DExp wrapBind new old | new == old = id | otherwise = DLetE [DValD (DVarP new) (DVarE old)] --- like GHC's mkSelectorBinds+-- | Desugar a lazy pattern that bind multiple variables to code that extracts+-- fields from tuples. For instance, this:+--+-- @+-- data Pair a b = MkPair a b+--+-- f :: Pair a b -> Pair b a+-- f ~(MkPair x y) = MkPair y x+-- @+--+-- Desugars to this (roughly) when match-flattened:+--+-- @+-- f :: Pair a b -> Pair b a+-- f p =+-- let tuple = case p of+-- MkPair x y -> (x, y)+--+-- x = case tuple of+-- (x, _) -> x+--+-- y = case tuple of+-- (_, y) -> x+--+-- in MkPair y x+-- @+--+-- This takes heavy inspiration from GHC's own @mkSelectorBinds@ function. mkSelectorDecs :: DsMonad q => DPat -- pattern to deconstruct -> Name -- variable being matched against@@ -184,10 +244,10 @@ | OS.null binders = return [] - | OS.size binders == 1+ | [binder] <- F.toList binders = do val_var <- newUniqueName "var" err_var <- newUniqueName "err"- bind <- mk_bind val_var err_var (head $ F.toList binders)+ bind <- mk_bind val_var err_var binder return [DValD (DVarP val_var) (DVarE name), DValD (DVarP err_var) (DVarE 'error `DAppE` (DLitE $ StringL "Irrefutable match failed")),@@ -212,7 +272,7 @@ -> q DExp mk_projection tup_name i = do var_name <- newUniqueName "proj"- return $ DCaseE (DVarE tup_name) [DMatch (DConP (tupleDataName tuple_size) [] (mk_tuple_pats var_name i))+ return $ dCaseE (DVarE tup_name) [DMatch (DConP (tupleDataName tuple_size) [] (mk_tuple_pats var_name i)) (DVarE var_name)] mk_tuple_pats :: Name -- of the projected element@@ -221,7 +281,7 @@ mk_tuple_pats elt_name i = replicate i DWildP ++ DVarP elt_name : replicate (tuple_size - i - 1) DWildP mk_bind scrut_var err_var bndr_var = do- rhs_mr <- simplCase [scrut_var] [EquationInfo [pat] (\_ -> DVarE bndr_var)]+ rhs_mr <- simplCase [scrut_var] [EquationInfo (pat:|[]) (\_ -> DVarE bndr_var)] return (DValD (DVarP bndr_var) (rhs_mr (DVarE err_var))) data PatGroup@@ -231,9 +291,9 @@ | PgBang -- like GHC's groupEquations-groupClauses :: [EquationInfo] -> [[(PatGroup, EquationInfo)]]+groupClauses :: [EquationInfo] -> [NonEmpty (PatGroup, EquationInfo)] groupClauses clauses- = runs same_gp [(patGroup (firstPat clause), clause) | clause <- clauses]+ = NE.groupBy same_gp [(patGroup (firstPat clause), clause) | clause <- clauses] where same_gp :: (PatGroup, EquationInfo) -> (PatGroup, EquationInfo) -> Bool (pg1,_) `same_gp` (pg2,_) = pg1 `sameGroup` pg2@@ -246,6 +306,8 @@ patGroup (DBangP {}) = PgBang patGroup (DSigP{}) = error "Internal error in th-desugar (patGroup DSigP)" patGroup DWildP = PgAny+patGroup (DTypeP {}) = PgAny+patGroup (DInvisP {}) = PgAny sameGroup :: PatGroup -> PatGroup -> Bool sameGroup PgAny PgAny = True@@ -254,18 +316,20 @@ sameGroup (PgLit _) (PgLit _) = True sameGroup _ _ = False -subGroup :: Ord a => [(a, EquationInfo)] -> [[EquationInfo]]+-- Precondition: the input list contains at least one element.+subGroup :: Ord a => [(a, EquationInfo)] -> NonEmpty (NonEmpty EquationInfo) subGroup group- = map reverse $ Map.elems $ foldl accumulate Map.empty group+ = case map NE.reverse $ Map.elems $ foldl accumulate Map.empty group of+ e:es -> e:|es+ [] -> error "Internal error in th-desugar (subGroup)" where accumulate pg_map (pg, eqn) = case Map.lookup pg pg_map of- Just eqns -> Map.insert pg (eqn:eqns) pg_map- Nothing -> Map.insert pg [eqn] pg_map+ Just eqns -> Map.insert pg (NE.cons eqn eqns) pg_map+ Nothing -> Map.insert pg (eqn :| []) pg_map firstPat :: EquationInfo -> DPat-firstPat (EquationInfo (pat : _) _) = pat-firstPat _ = error "Clause encountered with no patterns -- should never happen"+firstPat (EquationInfo (pat :| _) _) = pat data CaseAlt = CaseAlt { alt_con :: Name -- con name , _alt_args :: [Name] -- bound var names@@ -273,15 +337,14 @@ } -- from GHC's MatchCon.lhs-matchConFamily :: DsMonad q => [Name] -> [[EquationInfo]] -> q MatchResult-matchConFamily (var:vars) groups+matchConFamily :: DsMonad q => NonEmpty Name -> NonEmpty (NonEmpty EquationInfo) -> q MatchResult+matchConFamily (var:|vars) groups = do alts <- mapM (matchOneCon vars) groups mkDataConCase var alts-matchConFamily [] _ = error "Internal error in th-desugar (matchConFamily)" -- like matchOneConLike from MatchCon-matchOneCon :: DsMonad q => [Name] -> [EquationInfo] -> q CaseAlt-matchOneCon vars eqns@(eqn1 : _)+matchOneCon :: DsMonad q => [Name] -> NonEmpty EquationInfo -> q CaseAlt+matchOneCon vars eqns@(eqn1 :| _) = do arg_vars <- selectMatchVars (pat_args pat1) match_result <- match_group arg_vars @@ -297,19 +360,27 @@ match_group :: DsMonad q => [Name] -> q MatchResult match_group arg_vars- = simplCase (arg_vars ++ vars) (map shift eqns)+ = simplCase (arg_vars ++ vars) $ NE.toList $ fmap shift eqns - shift (EquationInfo (DConP _ _ args : pats) exp) = EquationInfo (args ++ pats) exp+ shift (EquationInfo (DConP _ _ args :| pats) exp)+ = EquationInfo (to_ne_pats (args ++ pats)) exp shift _ = error "Internal error in th-desugar (shift)"-matchOneCon _ _ = error "Internal error in th-desugar (matchOneCon)" -mkDataConCase :: DsMonad q => Name -> [CaseAlt] -> q MatchResult+ to_ne_pats :: [DPat] -> NonEmpty DPat+ to_ne_pats pats =+ case pats of+ p:ps -> p:|ps+ [] -> error "Internal error in th-desugar (matchOneCon.to_ne_pats)"++mkDataConCase :: DsMonad q => Name -> NonEmpty CaseAlt -> q MatchResult mkDataConCase var case_alts = do- all_ctors <- get_all_ctors (alt_con $ head case_alts)+ all_ctors <- get_all_ctors (alt_con $ NE.head case_alts) return $ \fail ->- let matches = map (mk_alt fail) case_alts in- DCaseE (DVarE var) (matches ++ mk_default all_ctors fail)+ let matches = fmap (mk_alt fail) case_alt_list in+ dCaseE (DVarE var) (matches ++ mk_default all_ctors fail) where+ case_alt_list = NE.toList case_alts+ mk_alt fail (CaseAlt con args body_fn) = let body = body_fn fail in DMatch (DConP con [] (map DVarP args)) body@@ -317,7 +388,7 @@ mk_default all_ctors fail | exhaustive_case all_ctors = [] | otherwise = [DMatch DWildP fail] - mentioned_ctors = S.fromList $ map alt_con case_alts+ mentioned_ctors = S.fromList $ map alt_con case_alt_list exhaustive_case all_ctors = all_ctors `S.isSubsetOf` mentioned_ctors get_all_ctors :: DsMonad q => Name -> q (S.Set Name)@@ -335,44 +406,41 @@ matchEmpty :: DsMonad q => Name -> q [MatchResult] matchEmpty var = return [mk_seq] where- mk_seq fail = DCaseE (DVarE var) [DMatch DWildP fail]+ mk_seq fail = dCaseE (DVarE var) [DMatch DWildP fail] -matchLiterals :: DsMonad q => [Name] -> [[EquationInfo]] -> q MatchResult-matchLiterals (var:vars) sub_groups+matchLiterals :: DsMonad q => NonEmpty Name -> NonEmpty (NonEmpty EquationInfo) -> q MatchResult+matchLiterals (var:|vars) sub_groups = do alts <- mapM match_group sub_groups return (mkCoPrimCaseMatchResult var alts) where- match_group :: DsMonad q => [EquationInfo] -> q (Lit, MatchResult)+ match_group :: DsMonad q => NonEmpty EquationInfo -> q (Lit, MatchResult) match_group eqns- = do let lit = case firstPat (head eqns) of+ = do let lit = case firstPat (NE.head eqns) of DLitP lit' -> lit' _ -> error $ "Internal error in th-desugar " ++ "(matchLiterals.match_group)"- match_result <- simplCase vars (shiftEqns eqns)+ match_result <- simplCase vars $ NE.toList $ shiftEqns eqns return (lit, match_result)-matchLiterals [] _ = error "Internal error in th-desugar (matchLiterals)" mkCoPrimCaseMatchResult :: Name -- Scrutinee- -> [(Lit, MatchResult)]+ -> NonEmpty (Lit, MatchResult) -> MatchResult mkCoPrimCaseMatchResult var match_alts = mk_case where- mk_case fail = let alts = map (mk_alt fail) match_alts in- DCaseE (DVarE var) (alts ++ [DMatch DWildP fail])+ mk_case fail = let alts = NE.toList $ fmap (mk_alt fail) match_alts in+ dCaseE (DVarE var) (alts ++ [DMatch DWildP fail]) mk_alt fail (lit, body_fn) = DMatch (DLitP lit) (body_fn fail) -matchBangs :: DsMonad q => [Name] -> [EquationInfo] -> q MatchResult-matchBangs (var:vars) eqns- = do match_result <- simplCase (var:vars) $- map (decomposeFirstPat getBangPat) eqns+matchBangs :: DsMonad q => NonEmpty Name -> NonEmpty EquationInfo -> q MatchResult+matchBangs (var:|vars) eqns+ = do match_result <- simplCase (var:vars) $ NE.toList $+ fmap (decomposeFirstPat getBangPat) eqns return (mkEvalMatchResult var match_result)-matchBangs [] _ = error "Internal error in th-desugar (matchBangs)" decomposeFirstPat :: (DPat -> DPat) -> EquationInfo -> EquationInfo-decomposeFirstPat extractpat (EquationInfo (pat:pats) body)- = EquationInfo (extractpat pat : pats) body-decomposeFirstPat _ _ = error "Internal error in th-desugar (decomposeFirstPat)"+decomposeFirstPat extractpat (EquationInfo (pat:|pats) body)+ = EquationInfo (extractpat pat :| pats) body getBangPat :: DPat -> DPat getBangPat (DBangP p) = p@@ -382,15 +450,19 @@ mkEvalMatchResult var body_fn fail = foldl DAppE (DVarE 'seq) [DVarE var, body_fn fail] -matchVariables :: DsMonad q => [Name] -> [EquationInfo] -> q MatchResult-matchVariables (_:vars) eqns = simplCase vars (shiftEqns eqns)-matchVariables _ _ = error "Internal error in th-desugar (matchVariables)"+matchVariables :: DsMonad q => NonEmpty Name -> NonEmpty EquationInfo -> q MatchResult+matchVariables (_:|vars) eqns = simplCase vars $ NE.toList $ shiftEqns eqns -shiftEqns :: [EquationInfo] -> [EquationInfo]-shiftEqns = map shift+shiftEqns :: NonEmpty EquationInfo -> NonEmpty EquationInfo+shiftEqns = fmap shift where- shift (EquationInfo pats rhs) = EquationInfo (tail pats) rhs+ shift (EquationInfo pats rhs) = EquationInfo (to_ne_pats (NE.tail pats)) rhs + to_ne_pats :: [DPat] -> NonEmpty DPat+ to_ne_pats pats =+ case pats of+ p:ps -> p:|ps+ [] -> error "Internal error in th-desugar (shiftEqns.to_ne_pats)" adjustMatchResult :: (DExp -> DExp) -> MatchResult -> MatchResult adjustMatchResult wrap mr fail = wrap $ mr fail@@ -405,9 +477,3 @@ selectMatchVar (DTildeP pat) = selectMatchVar pat selectMatchVar (DVarP var) = newUniqueName ('_' : nameBase var) selectMatchVar _ = newUniqueName "_pat"---- like GHC's runs-runs :: (a -> a -> Bool) -> [a] -> [[a]]-runs _ [] = []-runs p (x:xs) = case span (p x) xs of- (first, rest) -> (x:first) : (runs p rest)
Language/Haskell/TH/Desugar/Reify.hs view
@@ -48,13 +48,19 @@ import qualified Data.Set as Set import Data.Set (Set) -import Language.Haskell.TH.Datatype+import Language.Haskell.TH.Datatype ( freeVariables, freeVariablesWellScoped+ , quantifyType, resolveTypeSynonyms ) import Language.Haskell.TH.Datatype.TyVarBndr import Language.Haskell.TH.Instances () import Language.Haskell.TH.Syntax hiding ( lift )+import qualified Language.Haskell.TH.Syntax.Compat as Compat ( Quote ) -import Language.Haskell.TH.Desugar.Util+import Language.Haskell.TH.Desugar.Util as Util +#if __GLASGOW_HASKELL__ >= 907+import qualified Language.Haskell.TH as LangExt (Extension(..))+#endif+ -- | Like @reify@ from Template Haskell, but looks also in any not-yet-typechecked -- declarations. To establish this list of not-yet-typechecked declarations, -- use 'withLocalDeclarations'. Returns 'Nothing' if reification fails.@@ -93,26 +99,30 @@ -- Utilities --------------------------------- --- | Extract the @TyVarBndr@s and constructors given the @Name@ of a type+-- | Extract the 'DataFlavor', 'TyVarBndr's and constructors given the 'Name'+-- of a type. getDataD :: DsMonad q => String -- ^ Print this out on failure -> Name -- ^ Name of the datatype (@data@ or @newtype@) of interest- -> q ([TyVarBndrUnit], [Con])+ -> q (DataFlavor, [TyVarBndrVis], [Con]) getDataD err name = do info <- reifyWithLocals name dec <- case info of TyConI dec -> return dec _ -> badDeclaration case dec of- DataD _cxt _name tvbs mk cons _derivings -> go tvbs mk cons- NewtypeD _cxt _name tvbs mk con _derivings -> go tvbs mk [con]+ DataD _cxt _name tvbs mk cons _derivings -> go Data tvbs mk cons+ NewtypeD _cxt _name tvbs mk con _derivings -> go Newtype tvbs mk [con]+#if __GLASGOW_HASKELL__ >= 906+ TypeDataD _name tvbs mk cons -> go Util.TypeData tvbs mk cons+#endif _ -> badDeclaration where- go tvbs mk cons = do+ go df tvbs mk cons = do let k = fromMaybe (ConT typeKindName) mk extra_tvbs <- mkExtraKindBinders k let all_tvbs = tvbs ++ extra_tvbs- return (all_tvbs, cons)+ return (df, all_tvbs, cons) badDeclaration = fail $ "The name (" ++ (show name) ++ ") refers to something " ++@@ -132,16 +142,18 @@ -- are fresh type variable names. -- -- This expands kind synonyms if necessary.-mkExtraKindBinders :: forall q. Quasi q => Kind -> q [TyVarBndrUnit]+mkExtraKindBinders :: forall q. Quasi q => Kind -> q [TyVarBndrVis] mkExtraKindBinders k = do k' <- runQ $ resolveTypeSynonyms k let (fun_args, _) = unravelType k' vis_fun_args = filterVisFunArgs fun_args mapM mk_tvb vis_fun_args where- mk_tvb :: VisFunArg -> q TyVarBndrUnit- mk_tvb (VisFADep tvb) = return tvb- mk_tvb (VisFAAnon ki) = kindedTV <$> qNewName "a" <*> return ki+ mk_tvb :: VisFunArg -> q TyVarBndrVis+ mk_tvb (VisFADep tvb) = return $ mapTVFlag (const BndrReq) tvb+ mk_tvb (VisFAAnon ki) = do+ name <- qNewName "a"+ pure $ kindedTVFlag name BndrReq ki -- | From the name of a data constructor, retrive the datatype definition it -- is a part of.@@ -159,7 +171,7 @@ -- 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 type_name <- dataConNameToDataName con_name- (_, cons) <- getDataD "This seems to be an error in GHC." type_name+ (_, _, cons) <- getDataD "This seems to be an error in GHC." type_name let m_con = List.find (any (con_name ==) . get_con_name) cons case m_con of Just con -> return con@@ -191,7 +203,8 @@ -- | A convenient implementation of the 'DsMonad' class. Use by calling -- 'withLocalDeclarations'. newtype DsM q a = DsM (ReaderT [Dec] q a)- deriving ( Functor, Applicative, Monad, MonadTrans, Quasi, Fail.MonadFail+ deriving ( Functor, Applicative, Monad, MonadTrans, Fail.MonadFail+ , Quasi, Compat.Quote #if __GLASGOW_HASKELL__ >= 803 , MonadIO #endif@@ -231,7 +244,11 @@ reifyFixityInDecs :: Name -> [Dec] -> Maybe Fixity reifyFixityInDecs n = firstMatch match_fixity where- match_fixity (InfixD fixity n') | n `nameMatches` n'+ match_fixity (InfixD fixity+#if __GLASGOW_HASKELL__ >= 909+ _+#endif+ n') | n `nameMatches` n' = Just fixity match_fixity (ClassD _ _ _ _ sub_decs) = firstMatch match_fixity sub_decs match_fixity _ = Nothing@@ -263,16 +280,30 @@ reifyInDec n decs (PatSynD n' _ _ _) | n `nameMatches` n' = Just (n', mkPatSynI n decs) #endif+#if __GLASGOW_HASKELL__ >= 906+reifyInDec n _ dec@(TypeDataD n' _ _ _) | n `nameMatches` n' = Just (n', TyConI dec)+#endif reifyInDec n decs (DataD _ ty_name tvbs _mk cons _)- | Just info <- maybeReifyCon n decs ty_name (map tvbToTANormalWithSig tvbs) cons+ | Just info <- maybeReifyCon n decs ty_name+ (matchUpSAKWithTvbsSpec decs ty_name tvbs)+ (applyType (ConT ty_name) (map tyVarBndrVisToTypeArg tvbs))+ cons = Just info reifyInDec n decs (NewtypeD _ ty_name tvbs _mk con _)- | Just info <- maybeReifyCon n decs ty_name (map tvbToTANormalWithSig tvbs) [con]+ | Just info <- maybeReifyCon n decs ty_name+ (matchUpSAKWithTvbsSpec decs ty_name tvbs)+ (applyType (ConT ty_name) (map tyVarBndrVisToTypeArg tvbs))+ [con] = Just info-reifyInDec n _decs (ClassD _ ty_name tvbs _ sub_decs)+reifyInDec n decs (ClassD _ cls_name cls_tvbs _ sub_decs) | Just (n', ty) <- findType n sub_decs- = Just (n', ClassOpI n (quantifyClassMethodType ty_name tvbs True ty) ty_name)+ = Just (n', ClassOpI n+ (quantifyClassMethodType+ (matchUpSAKWithTvbsSpec decs cls_name cls_tvbs)+ (applyType (ConT cls_name) (map tyVarBndrVisToTypeArg cls_tvbs))+ True ty)+ cls_name) reifyInDec n decs (ClassD _ _ _ _ sub_decs) | Just info <- firstMatch (reifyInDec n decs) sub_decs -- Important: don't pass (sub_decs ++ decs) to reifyInDec@@ -286,28 +317,72 @@ reify_in_instance dec@(DataInstD {}) = reifyInDec n (sub_decs ++ decs) dec reify_in_instance dec@(NewtypeInstD {}) = reifyInDec n (sub_decs ++ decs) dec reify_in_instance _ = Nothing+#if __GLASGOW_HASKELL__ >= 801+reifyInDec n decs (PatSynD pat_syn_name args _ _)+ | Just (n', full_sel_ty) <- maybeReifyPatSynRecSelector n decs pat_syn_name args+ = Just (n', VarI n full_sel_ty Nothing)+#endif #if __GLASGOW_HASKELL__ >= 807-reifyInDec n decs (DataInstD _ _ lhs _ cons _)+reifyInDec n decs (DataInstD _ mtvbs lhs _ cons _) | (ConT ty_name, tys) <- unfoldType lhs- , Just info <- maybeReifyCon n decs ty_name tys cons+ , Just info <- maybeReifyCon n decs ty_name+ (dataFamInstH98ConTvbs mtvbs tys)+ -- Why do we reapply `ty_name` to `tys` here instead of just+ -- reusing `lhs`? See Note [Apply data family type+ -- constructors in prefix form in local reification].+ (applyType (ConT ty_name) tys)+ cons = Just info-reifyInDec n decs (NewtypeInstD _ _ lhs _ con _)+reifyInDec n decs (NewtypeInstD _ mtvbs lhs _ con _) | (ConT ty_name, tys) <- unfoldType lhs- , Just info <- maybeReifyCon n decs ty_name tys [con]+ , Just info <- maybeReifyCon n decs ty_name+ (dataFamInstH98ConTvbs mtvbs tys)+ -- Why do we reapply `ty_name` to `tys` here instead of just+ -- reusing `lhs`? See Note [Apply data family type+ -- constructors in prefix form in local reification].+ (applyType (ConT ty_name) tys)+ [con] = Just info #else reifyInDec n decs (DataInstD _ ty_name tys _ cons _)- | Just info <- maybeReifyCon n decs ty_name (map TANormal tys) cons+ | Just info <- maybeReifyCon n decs ty_name+ (dataFamInstH98ConTvbsNoInstTvbs tys)+ (applyType (ConT ty_name) (map TANormal tys))+ cons = Just info reifyInDec n decs (NewtypeInstD _ ty_name tys _ con _)- | Just info <- maybeReifyCon n decs ty_name (map TANormal tys) [con]+ | Just info <- maybeReifyCon n decs ty_name+ (dataFamInstH98ConTvbsNoInstTvbs tys)+ (applyType (ConT ty_name) (map TANormal tys))+ [con] = Just info #endif+#if __GLASGOW_HASKELL__ >= 906+reifyInDec n decs (TypeDataD ty_name tvbs _mk cons)+ | Just info <- maybeReifyCon n decs ty_name+ (matchUpSAKWithTvbsSpec decs ty_name tvbs)+ (applyType (ConT ty_name) (map tyVarBndrVisToTypeArg tvbs))+ cons+ = Just info+#endif reifyInDec _ _ _ = Nothing -maybeReifyCon :: Name -> [Dec] -> Name -> [TypeArg] -> [Con] -> Maybe (Named Info)-maybeReifyCon n _decs ty_name ty_args cons+maybeReifyCon ::+ Name+ -> [Dec]+ -> Name+ -> [TyVarBndrSpec]+ -- ^ The universally quantified type variables, derived from the parent+ -- data declaration. This is only used if reifying a Haskell98-style data+ -- constructor.+ -> Type+ -- ^ The data constructor's return type, derived from the parent data+ -- declaration. This is only used if reifying a Haskell98-style data+ -- constructor.+ -> [Con]+ -> Maybe (Named Info)+maybeReifyCon n _decs ty_name h98_tvbs h98_res_ty cons | Just (n', con) <- findCon n cons -- See Note [Use unSigType in maybeReifyCon] , let full_con_ty = unSigType $ con_to_type h98_tvbs h98_res_ty con@@ -320,22 +395,180 @@ -- we don't try to ferret out naughty record selectors. = Just (n', VarI n full_sel_ty Nothing) where- extract_rec_sel_info :: RecSelInfo -> ([TyVarBndrUnit], Type, Type)+ extract_rec_sel_info :: RecSelInfo -> ([TyVarBndrSpec], Type, Type) -- Returns ( Selector type variable binders -- , Record field type -- , constructor result type ) extract_rec_sel_info rec_sel_info = case rec_sel_info of- RecSelH98 sel_ty -> (h98_tvbs, sel_ty, h98_res_ty)- RecSelGADT sel_ty con_res_ty ->- ( freeVariablesWellScoped [con_res_ty, sel_ty]- , sel_ty, con_res_ty)+ RecSelH98 sel_ty ->+ let -- All of the type variables bound by the data type, with any+ -- implicitly quantified kind variables made explicit.+ all_h98_tvbs = quantifyAllTvbsSpec h98_tvbs in+ ( all_h98_tvbs+ , sel_ty+ , h98_res_ty+ )+ RecSelGADT mb_con_tvbs sel_ty con_res_ty ->+ let -- If the GADT constructor type signature explicitly quantifies+ -- its type variables, make sure to use that same order in the+ -- record selector's type.+ con_tvbs' =+ case mb_con_tvbs of+ Just con_tvbs -> con_tvbs+ Nothing ->+ changeTVFlags SpecifiedSpec $+ freeVariablesWellScoped [con_res_ty, sel_ty] in+ ( con_tvbs'+ , sel_ty+ , con_res_ty+ ) - h98_tvbs = freeVariablesWellScoped $ map probablyWrongUnTypeArg ty_args- h98_res_ty = applyType (ConT ty_name) ty_args+maybeReifyCon _ _ _ _ _ _ = Nothing -maybeReifyCon _ _ _ _ _ = Nothing+#if __GLASGOW_HASKELL__ >= 801+-- | Attempt to reify the type of a pattern synonym record selector @n@.+-- The algorithm for computing this type works as follows:+--+-- 1. Reify the type of the parent pattern synonym. Broadly speaking, this+-- will look something like:+--+-- @+-- pattern P :: forall <req_tvbs>. req_cxt =>+-- forall <prov_tvbs>. prov_cxt =>+-- arg_ty_1 -> ... -> arg_ty_k -> res+-- @+--+-- 2. Check if @P@ is a record pattern synonym. If it isn't a record pattern+-- synonym, return 'Nothing'. If it is a record pattern synonym, it will+-- have @k@ record selectors @sel_1@, ..., @sel_k@.+--+-- 3. Check if @n@ is equal to some @sel_i@. If it isn't equal to any of them,+-- return @Nothing@. If it is equal to some @sel_i@, then return 'Just'+-- @sel_i@ paired with the following type:+--+-- @+-- sel_i :: forall <req_tvbs>. req_cxt => res -> arg_ty_i+-- @+maybeReifyPatSynRecSelector ::+ Name -> [Dec] -> Name -> PatSynArgs -> Maybe (Named Type)+maybeReifyPatSynRecSelector n decs pat_syn_name pat_syn_args =+ case pat_syn_args of+ -- Part (2) in the Haddocks+ RecordPatSyn fld_names+ -> firstMatch match_pat_syn_rec_sel $+ zip fld_names pat_syn_ty_vis_args+ _ -> Nothing+ where+ -- Part (3) in the Haddocks+ match_pat_syn_rec_sel :: (Name, Type) -> Maybe (Named Type)+ match_pat_syn_rec_sel (n', field_ty)+ | n `nameMatches` n'+ = Just ( n'+ , -- See Note [Use unSigType in maybeReifyCon]+ unSigType $+ maybeForallT pat_syn_ty_tvbs pat_syn_ty_req_cxt $+ ArrowT `AppT` pat_syn_ty_res `AppT` field_ty+ )+ match_pat_syn_rec_sel _+ = Nothing + -- The type of the pattern synonym to which this record selector belongs,+ -- as described in part (1) in the Haddocks.+ pat_syn_ty :: Type+ pat_syn_ty =+ case findPatSynType pat_syn_name decs of+ Just ty -> ty+ Nothing -> no_type n++ pat_syn_ty_args :: FunArgs+ pat_syn_ty_res :: Type+ (pat_syn_ty_args, pat_syn_ty_res) =+ unravelType pat_syn_ty++ -- Decompose a pattern synonym type into the constituent parts described in+ -- part (1) in the Haddocks. The Haddocks present an idealized form of+ -- pattern synonym type signature where the required and provided foralls+ -- and contexts are made explicit. In reality, some of these parts may be+ -- omitted, so we have to be careful to handle every combination of+ -- explicit and implicit parts.+ pat_syn_ty_tvbs :: [TyVarBndrSpec]+ pat_syn_ty_req_cxt :: Cxt+ pat_syn_ty_vis_args :: [Type]+ (pat_syn_ty_tvbs, pat_syn_ty_req_cxt, pat_syn_ty_vis_args) =+ case pat_syn_ty_args of+ -- Both the required foralls and context are explicit.+ --+ -- The provided foralls and context may be explicit or implicit, but it+ -- doesn't really matter, as the type of a pattern synonym record+ -- selector only cares about the required foralls and context.+ -- Similarly for all cases below this one.+ FAForalls (ForallInvis req_tvbs) (FACxt req_cxt args) ->+ ( req_tvbs+ , req_cxt+ , mapMaybe vis_arg_anon_maybe $ filterVisFunArgs args+ )++ -- Only the required foralls are explicit. We can assume that there is+ -- no required context due to the case above not matching.+ FAForalls (ForallInvis req_tvbs) args ->+ ( req_tvbs+ , []+ , mapMaybe vis_arg_anon_maybe $ filterVisFunArgs args+ )++ -- The required context is explicit, but the required foralls are+ -- implicit. As a result, the order of type variables in the outer+ -- forall in the type of the pattern synonym is determined by the usual+ -- left-to-right scoped sort.+ --+ -- Note that there may be explicit, provided foralls in this case. For+ -- example, consider this example:+ --+ -- @+ -- data T a where+ -- MkT :: b -> T (Maybe b)+ --+ -- pattern X :: Show a => forall b. (a ~ Maybe b) => b -> T a+ -- pattern X{unX} = MkT unX+ -- @+ --+ -- You might worry that the type of @unX@ would need to mention @b@.+ -- But actually, you can't use @unX@ as a top-level record selector in+ -- the first place! If you try to do so, GHC will throw the following+ -- error:+ --+ -- @+ -- Cannot use record selector `unX' as a function due to escaped type variables+ -- @+ --+ -- As a result, we choose not to care about this corner case. We could+ -- imagine trying to detect this sort of thing here and throwing a+ -- similar error message, but detecting which type variables do or do+ -- not escape is tricky in general. (See the Haddocks for+ -- getRecordSelectors in L.H.TH.Desugar for more on this point.) As a+ -- result, we don't even bother trying. Similarly for the case below.+ FACxt req_cxt args ->+ ( changeTVFlags SpecifiedSpec $+ freeVariablesWellScoped [pat_syn_ty]+ , req_cxt+ , mapMaybe vis_arg_anon_maybe $ filterVisFunArgs args+ )++ -- The required foralls are implicit. We can assume that there is no+ -- required context due to the case above not matching.+ args ->+ ( changeTVFlags SpecifiedSpec $+ freeVariablesWellScoped [pat_syn_ty]+ , []+ , mapMaybe vis_arg_anon_maybe $ filterVisFunArgs args+ )++vis_arg_anon_maybe :: VisFunArg -> Maybe Type+vis_arg_anon_maybe (VisFAAnon ty) = Just ty+vis_arg_anon_maybe (VisFADep{}) = Nothing+#endif+ {- Note [Use unSigType in maybeReifyCon] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -350,10 +583,36 @@ This is contrast to GHC's own reification, which will produce `D a` (without the explicit kind signature) as the type of the first argument.++Note [Apply data family type constructors in prefix form in local reification]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we wish to locally reify the type of `MkD` below:++ data family a :&: b+ data instance a :&: b = MkD a b++You might be tempted to think that the return type should be:++ MkD :: a -> b -> a :&: b++However, keep in mind that local reification tries its best to mimic GHC's+behavior when reifying global declarations using Template Haskell. As it turns+out, if `MkD` were defined globally, then Template Haskell would reify it as:++ MkD :: a -> b -> (:&:) a b++Note that `(:&:)` is applied prefix, not infix! This is somewhat surprising,+but nevertheless valid code. We mimic this surprising behavior when locally+reifying data family instances such as (:&:). This means that we cannot just+reuse the type `a :&: b` in the return type of `MkD`. Instead, we must+decompose `a :&: b` into its type arguments and apply (:&:) (in prefix form) to+the type arguments.++The R40 test case checks for this property. -} -- Reverse-engineer the type of a data constructor.-con_to_type :: [TyVarBndrUnit] -- The type variables bound by a data type head.+con_to_type :: [TyVarBndrSpec] -- The type variables bound by a data type head. -- Only used for Haskell98-style constructors. -> Type -- The constructor result type. -- Only used for Haskell98-style constructors.@@ -361,7 +620,7 @@ con_to_type h98_tvbs h98_result_ty con = case go con of (is_gadt, ty) | is_gadt -> ty- | otherwise -> maybeForallT h98_tvbs [] ty+ | otherwise -> maybeForallT all_h98_tvbs [] ty where -- Note that we deliberately ignore linear types and use (->) everywhere. -- See [Gracefully handling linear types] in L.H.TH.Desugar.Core.@@ -373,6 +632,11 @@ go (GadtC _ stys rty) = (True, mkArrows (map snd stys) rty) go (RecGadtC _ vstys rty) = (True, mkArrows (map thdOf3 vstys) rty) + -- All of the type variables bound by the data type, with any implicitly+ -- quantified kind variables made explicit.+ all_h98_tvbs :: [TyVarBndrSpec]+ all_h98_tvbs = quantifyAllTvbsSpec h98_tvbs+ mkVarI :: Name -> [Dec] -> Info mkVarI n decs = mkVarITy n (maybe (no_type n) snd $ findType n decs) @@ -521,7 +785,11 @@ sub_decs' = mapMaybe go sub_decs go (SigD n ty) = Just $ SigD n- $ quantifyClassMethodType cls_name cls_tvbs prepend_cls ty+ $ quantifyClassMethodType+ (changeTVFlags SpecifiedSpec cls_tvbs)+ (applyType (ConT cls_name) (map tyVarBndrVisToTypeArg cls_tvbs))+ prepend_cls+ ty go d@(TySynInstD {}) = Just d go d@(OpenTypeFamilyD {}) = Just d go d@(DataFamilyD {}) = Just d@@ -542,8 +810,8 @@ -- [d| class C a where -- method :: a -> b -> a |] ----- If one invokes `quantifyClassMethodType C [a] prepend (a -> b -> a)`, then--- the output will be:+-- If one invokes `quantifyClassMethodType [a] (C a) prepend (a -> b -> a)`,+-- then the output will be: -- -- 1. `forall a. C a => forall b. a -> b -> a` (if `prepend` is True) -- 2. `forall b. a -> b -> a` (if `prepend` is False)@@ -555,22 +823,19 @@ -- a single class method, like `method`, then one needs the class context to -- appear in the reified type, so `True` is appropriate. quantifyClassMethodType- :: Name -- ^ The class name.- -> [TyVarBndrUnit] -- ^ The class's type variable binders.+ :: [TyVarBndrSpec] -- ^ The class's type variable binders.+ -> Pred -- ^ The class context. -> Bool -- ^ If 'True', prepend a class predicate. -> Type -- ^ The method type. -> Type-quantifyClassMethodType cls_name cls_tvbs prepend meth_ty =+quantifyClassMethodType cls_tvbs cls_pred prepend meth_ty = add_cls_cxt quantified_meth_ty where add_cls_cxt :: Type -> Type add_cls_cxt- | prepend = ForallT (changeTVFlags SpecifiedSpec all_cls_tvbs) cls_cxt+ | prepend = ForallT all_cls_tvbs [cls_pred] | otherwise = id - cls_cxt :: Cxt- cls_cxt = [foldl AppT (ConT cls_name) (map tvbToType cls_tvbs)]- quantified_meth_ty :: Type quantified_meth_ty | null meth_tvbs@@ -581,13 +846,15 @@ = ForallT meth_tvbs [] meth_ty meth_tvbs :: [TyVarBndrSpec]- meth_tvbs = changeTVFlags SpecifiedSpec $- List.deleteFirstsBy ((==) `on` tvName)- (freeVariablesWellScoped [meth_ty]) all_cls_tvbs+ meth_tvbs = List.deleteFirstsBy ((==) `on` tvName)+ (changeTVFlags SpecifiedSpec+ (freeVariablesWellScoped [meth_ty]))+ all_cls_tvbs - -- Explicitly quantify any kind variables bound by the class, if any.- all_cls_tvbs :: [TyVarBndrUnit]- all_cls_tvbs = freeVariablesWellScoped $ map tvbToTypeWithSig cls_tvbs+ -- All of the type variables bound by the class, with any implicitly+ -- quantified kind variables made explicit.+ all_cls_tvbs :: [TyVarBndrSpec]+ all_cls_tvbs = quantifyAllTvbsSpec cls_tvbs stripInstanceDec :: Dec -> Dec stripInstanceDec (InstanceD over cxt ty _) = InstanceD over cxt ty []@@ -597,13 +864,11 @@ mkArrows [] res_ty = res_ty mkArrows (t:ts) res_ty = AppT (AppT ArrowT t) $ mkArrows ts res_ty -maybeForallT :: [TyVarBndrUnit] -> Cxt -> Type -> Type+maybeForallT :: [TyVarBndrSpec] -> Cxt -> Type -> Type maybeForallT tvbs cxt ty | null tvbs && null cxt = ty- | ForallT tvbs2 cxt2 ty2 <- ty = ForallT (tvbs_spec ++ tvbs2) (cxt ++ cxt2) ty2- | otherwise = ForallT tvbs_spec cxt ty- where- tvbs_spec = changeTVFlags SpecifiedSpec tvbs+ | ForallT tvbs2 cxt2 ty2 <- ty = ForallT (tvbs ++ tvbs2) (cxt ++ cxt2) ty2+ | otherwise = ForallT tvbs cxt ty findCon :: Name -> [Con] -> Maybe (Named Con) findCon n = firstMatch match_con@@ -628,24 +893,123 @@ data RecSelInfo = RecSelH98 Type -- The record field's type- | RecSelGADT Type -- The record field's type+ | RecSelGADT (Maybe [TyVarBndrSpec])+ -- If the data constructor explicitly quantifies its type+ -- variables with a forall, this will be Just. Otherwise,+ -- this will be Nothing.+ Type -- The record field's type Type -- The GADT return type findRecSelector :: Name -> [Con] -> Maybe (Named RecSelInfo)-findRecSelector n = firstMatch match_con+findRecSelector n = firstMatch (match_con Nothing) where- match_con :: Con -> Maybe (Named RecSelInfo)- match_con (RecC _ vstys) = fmap (liftSnd RecSelH98) $- firstMatch match_rec_sel vstys- match_con (RecGadtC _ vstys ret_ty) = fmap (liftSnd (`RecSelGADT` ret_ty)) $- firstMatch match_rec_sel vstys- match_con (ForallC _ _ c) = match_con c- match_con _ = Nothing+ match_con :: Maybe [TyVarBndrSpec] -> Con -> Maybe (Named RecSelInfo)+ match_con mb_tvbs con =+ case con of+ RecC _ vstys ->+ fmap (liftSnd RecSelH98) $+ firstMatch match_rec_sel vstys+ RecGadtC _ vstys ret_ty ->+ fmap (liftSnd (\field_ty ->+ RecSelGADT (fmap (filter_ret_tvs ret_ty) mb_tvbs) field_ty ret_ty)) $+ firstMatch match_rec_sel vstys+ ForallC tvbs _ c ->+ -- This is the only recursive case, and it is also the place where+ -- the type variable binders are determined (hence the use of Just+ -- below). Note that GHC forbids nested foralls in GADT constructor+ -- type signatures, so it is guaranteed that if a type variable in+ -- the rest of the type signature appears free, then its binding site+ -- can be found in one of these binders found in this case.+ match_con (Just tvbs) c+ _ -> Nothing match_rec_sel (n', _, sel_ty) | n `nameMatches` n' = Just (n', sel_ty) match_rec_sel _ = Nothing + -- There may be type variables in the type of a GADT constructor that do+ -- not appear in the type of a record selector. For example, consider:+ --+ -- data G a where+ -- MkG :: forall a b. { x :: a, y :: b } -> G a+ --+ -- The type of `x` will only quantify `a` and not `b`:+ --+ -- x :: forall a. G a -> a+ --+ -- Accordingly, we must filter out any type variables in the GADT+ -- constructor type that do not appear free in the return type. Note that+ -- this implies that we cannot support reifying the type of `y`, as `b`+ -- does not appear free in `G a`. This does not bother us, however, as we+ -- make no attempt to support naughty record selectors. (See the Haddocks+ -- for getRecordSelectors in L.H.TH.Desugar for more on this point.)+ --+ -- This mirrors the implementation of mkOneRecordSelector in GHC:+ -- https://gitlab.haskell.org/ghc/ghc/-/blob/37cfe3c0f4fb16189bbe3bb735f758cd6e3d9157/compiler/GHC/Tc/TyCl/Utils.hs#L908-909+ filter_ret_tvs :: Type -> [TyVarBndrSpec] -> [TyVarBndrSpec]+ filter_ret_tvs ret_ty =+ filter (\tvb -> tvName tvb `Set.member` ret_fvs)+ where+ ret_fvs = Set.fromList $ freeVariables [ret_ty]++-- | Match up the type variable binders from a data type or class declaration+-- with its standalone kind signature (if any) to produce a list of+-- 'TyVarBndrSpec's, which can then be used in the types of data constructors or+-- class methods. This makes the kinds more precise.+matchUpSAKWithTvbsSpec ::+ [Dec]+ -- ^ The local declarations currently in scope.+ -> Name+ -- ^ The name of the data type or class declaration.+ -> [TyVarBndrVis]+ -- ^ The data type or class declaration's type variable binders.+ -> [TyVarBndrSpec]+matchUpSAKWithTvbsSpec decs ty_name tvbs =+ fromMaybe (changeTVFlags SpecifiedSpec tvbs) $ do+ sak <- findKind False ty_name decs+ tvbForAllTyFlagsToSpecs <$> matchUpSAKWithDecl sak tvbs++-- | Compute the type variable binders to use in the type of a Haskell98-style+-- data constructor for a data family instance. If the data family instance+-- comes equipped with explicit type variable binders, this is easy. If not,+-- we must compute the type variable binders from the list of type arguments to+-- the data family instance.+dataFamInstH98ConTvbs :: Maybe [TyVarBndrUnit] -> [TypeArg] -> [TyVarBndrSpec]+dataFamInstH98ConTvbs mtvbs tys =+ case mtvbs of+ Just tvbs ->+ changeTVFlags SpecifiedSpec tvbs+ Nothing ->+ dataFamInstH98ConTvbsNoInstTvbs $+ map probablyWrongUnTypeArg tys++-- | Compute the type variable binders to use in the type of a Haskell98-style+-- data constructor for a data family instance where the instance lacks explicit+-- type variable binders. To compute these binders, we must reverse engineer+-- them from the list of type arguments to the data family instance.+dataFamInstH98ConTvbsNoInstTvbs :: [Type] -> [TyVarBndrSpec]+dataFamInstH98ConTvbsNoInstTvbs tys =+ changeTVFlags SpecifiedSpec $+ freeVariablesWellScoped tys++-- | Explicitly quantify all type variable binders in the type of a+-- Haskell98-style data constructor or class method. This is sometimes required+-- in order to ensure that kind variables are all explicitly quantified, e.g.,+--+-- @+-- -- NB: No standalone kind signature for `T`+-- data T (a :: k) = MkT+-- @+--+-- We want the type of @MkT@ to be @forall k (a :: k). T a@, but we are only+-- given @(a :: k)@. We must call 'quantifyAllTvbsSpec' on @(a :: k)@ to obtain+-- @[k, a :: k]@. If we don't, we might accidentally end up with+-- @forall (a :: k). T a@ as the type of @MkT@, which is ill-scoped.+quantifyAllTvbsSpec :: [TyVarBndrSpec] -> [TyVarBndrSpec]+quantifyAllTvbsSpec h98_tvbs =+ let h98_kvbs = freeKindVariablesWellScoped h98_tvbs in+ changeTVFlags SpecifiedSpec h98_kvbs ++ h98_tvbs+ --------------------------------- -- Reifying fixities ---------------------------------@@ -757,7 +1121,7 @@ cls_tvb_kind_map = Map.fromList [ (tvName tvb, tvb_kind) | (tvb, mb_vis_arg_ki) <- zip tvbs mb_vis_arg_kis- , Just tvb_kind <- [mb_vis_arg_ki <|> tvb_kind_maybe tvb]+ , Just tvb_kind <- [mb_vis_arg_ki <|> extractTvbKind_maybe tvb] ] = firstMatch (find_assoc_type_kind n cls_tvb_kind_map) sub_decs match_kind_sig n _ dec = find_kind_sig n dec@@ -799,9 +1163,14 @@ all tvb_is_kinded tvbs , let cls_tvb_kind_map = Map.fromList [ (tvName tvb, tvb_kind) | tvb <- tvbs- , Just tvb_kind <- [tvb_kind_maybe tvb]+ , Just tvb_kind <- [extractTvbKind_maybe tvb] ] = firstMatch (find_assoc_type_kind n cls_tvb_kind_map) sub_decs+#if __GLASGOW_HASKELL__ >= 906+match_cusk n (TypeDataD n' tvbs m_ki _)+ | n `nameMatches` n'+ = datatype_kind tvbs m_ki+#endif match_cusk _ _ = Nothing -- Uncover the kind of an associated type family. There is an invariant@@ -821,17 +1190,18 @@ (default_res_ki $ res_sig_to_kind res_sig) _ -> Nothing where- ascribe_tf_tvb_kind :: TyVarBndrUnit -> TyVarBndrUnit+ ascribe_tf_tvb_kind :: TyVarBndrVis -> TyVarBndrVis ascribe_tf_tvb_kind tvb =- elimTV (\tvn -> kindedTV tvn $ fromMaybe StarT $ Map.lookup tvn cls_tvb_kind_map)- (\_ _ -> tvb)- tvb+ elimTVFlag+ (\tvn flag -> kindedTVFlag tvn flag $ fromMaybe StarT $ Map.lookup tvn cls_tvb_kind_map)+ (\_ _ _ -> tvb)+ tvb -- Data types have CUSKs when: -- -- 1. All of their type variables have explicit kinds. -- 2. All kind variables in the result kind are explicitly quantified.-datatype_kind :: [TyVarBndrUnit] -> Maybe Kind -> Maybe Kind+datatype_kind :: [TyVarBndrVis] -> Maybe Kind -> Maybe Kind datatype_kind tvbs m_ki = whenAlt (all tvb_is_kinded tvbs && ki_fvs_are_bound) $ build_kind tvbs (default_res_ki m_ki)@@ -843,14 +1213,14 @@ in ki_fvs `Set.isSubsetOf` tvb_vars -- Classes have CUSKs when all of their type variables have explicit kinds.-class_kind :: [TyVarBndrUnit] -> Maybe Kind+class_kind :: [TyVarBndrVis] -> Maybe Kind class_kind tvbs = whenAlt (all tvb_is_kinded tvbs) $ build_kind tvbs ConstraintT -- Open type families and data families always have CUSKs. Type variables -- without explicit kinds default to Type, as does the return kind if it -- is not specified.-open_ty_fam_kind :: [TyVarBndrUnit] -> Maybe Kind -> Maybe Kind+open_ty_fam_kind :: [TyVarBndrVis] -> Maybe Kind -> Maybe Kind open_ty_fam_kind tvbs m_ki = build_kind (map default_tvb tvbs) (default_res_ki m_ki) @@ -858,7 +1228,7 @@ -- -- 1. All of their type variables have explicit kinds. -- 2. An explicit return kind is supplied.-closed_ty_fam_kind :: [TyVarBndrUnit] -> Maybe Kind -> Maybe Kind+closed_ty_fam_kind :: [TyVarBndrVis] -> Maybe Kind -> Maybe Kind closed_ty_fam_kind tvbs m_ki = case m_ki of Just ki -> whenAlt (all tvb_is_kinded tvbs) $@@ -869,7 +1239,7 @@ -- -- 1. All of their type variables have explicit kinds. -- 2. The right-hand-side type is annotated with an explicit kind.-ty_syn_kind :: [TyVarBndrUnit] -> Type -> Maybe Kind+ty_syn_kind :: [TyVarBndrVis] -> Type -> Maybe Kind ty_syn_kind tvbs rhs = case rhs of SigT _ ki -> whenAlt (all tvb_is_kinded tvbs) $@@ -881,16 +1251,16 @@ -- this function is `Maybe Kind` because there are situations where even -- this amount of information is not sufficient to determine the full kind. -- See Note [The limitations of standalone kind signatures].-build_kind :: [TyVarBndrUnit] -> Kind -> Maybe Kind+build_kind :: [TyVarBndrVis] -> Kind -> Maybe Kind build_kind arg_kinds res_kind = fmap quantifyType $ fst $ foldr go (Just res_kind, Set.fromList (freeVariables res_kind)) arg_kinds where- go :: TyVarBndrUnit -> (Maybe Kind, Set Name) -> (Maybe Kind, Set Name)+ go :: TyVarBndrVis -> (Maybe Kind, Set Name) -> (Maybe Kind, Set Name) go tvb (res, res_fvs) = elimTV (\n -> ( if n `Set.member` res_fvs- then forall_vis tvb res+ then forall_ tvb res else Nothing -- We have a type variable binder without an -- explicit kind that is not used dependently, so -- we cannot build a kind from it. This is the@@ -899,15 +1269,22 @@ )) (\n k -> ( if n `Set.member` res_fvs- then forall_vis tvb res+ then forall_ tvb res else fmap (ArrowT `AppT` k `AppT`) res , Set.fromList (freeVariables k) `Set.union` res_fvs )) tvb - forall_vis :: TyVarBndrUnit -> Maybe Kind -> Maybe Kind+ forall_ :: TyVarBndrVis -> Maybe Kind -> Maybe Kind #if __GLASGOW_HASKELL__ >= 809- forall_vis tvb m_ki = fmap (ForallVisT [tvb]) m_ki+ forall_ tvb m_ki = fmap forallT m_ki+ where+ bndrVis :: BndrVis+ bndrVis = elimTVFlag (\_ flag -> flag) (\_ flag _ -> flag) tvb+ forallT :: Kind -> Kind+ forallT = case bndrVis of+ BndrReq -> ForallVisT (changeTVFlags () [tvb])+ BndrInvis -> ForallT (changeTVFlags SpecifiedSpec [tvb]) [] -- One downside of this approach is that we generate kinds like this: -- -- forall a -> forall b -> forall c -> (a, b, c)@@ -918,21 +1295,18 @@ -- -- Thankfully, the difference is only cosmetic. #else- forall_vis _ _ = Nothing+ forall_ _ _ = Nothing #endif tvb_is_kinded :: TyVarBndr_ flag -> Bool-tvb_is_kinded = isJust . tvb_kind_maybe--tvb_kind_maybe :: TyVarBndr_ flag -> Maybe Kind-tvb_kind_maybe = elimTV (\_ -> Nothing) (\_ k -> Just k)+tvb_is_kinded = isJust . extractTvbKind_maybe vis_arg_kind_maybe :: VisFunArg -> Maybe Kind-vis_arg_kind_maybe (VisFADep tvb) = tvb_kind_maybe tvb+vis_arg_kind_maybe (VisFADep tvb) = extractTvbKind_maybe tvb vis_arg_kind_maybe (VisFAAnon k) = Just k -default_tvb :: TyVarBndrUnit -> TyVarBndrUnit-default_tvb tvb = elimTV (\n -> kindedTV n StarT) (\_ _ -> tvb) tvb+default_tvb :: TyVarBndr_ flag -> TyVarBndr_ flag+default_tvb tvb = elimTVFlag (\n flag -> kindedTVFlag n flag StarT) (\_ _ _ -> tvb) tvb default_res_ki :: Maybe Kind -> Kind default_res_ki = fromMaybe StarT@@ -940,7 +1314,7 @@ res_sig_to_kind :: FamilyResultSig -> Maybe Kind res_sig_to_kind NoSig = Nothing res_sig_to_kind (KindSig k) = Just k-res_sig_to_kind (TyVarSig tvb) = tvb_kind_maybe tvb+res_sig_to_kind (TyVarSig tvb) = extractTvbKind_maybe tvb whenAlt :: Alternative f => Bool -> f a -> f a whenAlt b fa = if b then fa else empty@@ -993,7 +1367,7 @@ lookupTypeNameWithLocals :: DsMonad q => String -> q (Maybe Name) lookupTypeNameWithLocals = lookupNameWithLocals True -lookupNameWithLocals :: DsMonad q => Bool -> String -> q (Maybe Name)+lookupNameWithLocals :: forall q. DsMonad q => Bool -> String -> q (Maybe Name) lookupNameWithLocals ns s = do mb_name <- qLookupName ns s case mb_name of@@ -1006,23 +1380,33 @@ decs <- localDeclarations let mb_infos = map (reifyInDec built_name decs) decs infos = catMaybes mb_infos- return $ firstMatch (if ns then find_type_name- else find_value_name) infos+ firstMatchM (if ns then find_type_name+ else find_value_name) infos -- These functions work over Named Infos so we can avoid performing -- tiresome pattern-matching to retrieve the name associated with each Info.- find_type_name, find_value_name :: Named Info -> Maybe Name- find_type_name (n, info) =- case infoNameSpace info of+ find_type_name, find_value_name :: Named Info -> q (Maybe Name)+ find_type_name (n, info) = do+ name_space <- lookupInfoNameSpace info+ pure $ case name_space of TcClsName -> Just n VarName -> Nothing DataName -> Nothing+#if __GLASGOW_HASKELL__ >= 907+ FldName{} -> Nothing+#endif - find_value_name (n, info) =- case infoNameSpace info of- VarName -> Just n- DataName -> Just n- TcClsName -> Nothing+ find_value_name (n, info) = do+ name_space <- lookupInfoNameSpace info+ case name_space of+ VarName -> pure $ Just n+ DataName -> pure $ Just n+ TcClsName -> pure Nothing+#if __GLASGOW_HASKELL__ >= 907+ FldName{} -> do+ fieldSels <- qIsExtEnabled LangExt.FieldSelectors+ pure $ if fieldSels then Just n else Nothing+#endif -- | Like TH's @lookupValueName@, but if this name is not bound, then we assume -- it is declared in the current module.@@ -1060,22 +1444,62 @@ -- For other names, we must use reification to determine what NameSpace -- it lives in (if any). _ -> do mb_info <- reifyWithLocals_maybe n- pure $ fmap infoNameSpace mb_info+ traverse lookupInfoNameSpace mb_info --- | Determine a name's 'NameSpace' from its 'Info'.-infoNameSpace :: Info -> NameSpace-infoNameSpace info =+-- | Look up a name's 'NameSpace' from its 'Info'.+lookupInfoNameSpace :: DsMonad q => Info -> q NameSpace+lookupInfoNameSpace info = case info of- ClassI{} -> TcClsName- TyConI{} -> TcClsName- FamilyI{} -> TcClsName- PrimTyConI{} -> TcClsName- TyVarI{} -> TcClsName+ ClassI{} -> pure TcClsName+ TyConI{} -> pure TcClsName+ FamilyI{} -> pure TcClsName+ PrimTyConI{} -> pure TcClsName+ TyVarI{} -> pure TcClsName - ClassOpI{} -> VarName- VarI{} -> VarName+ ClassOpI{} -> pure VarName+#if __GLASGOW_HASKELL__ >= 907+ -- A VarI might correspond to a top-level value (i.e., a VarName) or a+ -- record field (i.e., a FldName). The only way to distinguish them is to+ -- check if the VarI's Name and Type correspond to a data type with a+ -- corresponding record field Name.+ VarI n ty _ -> do+ -- First, check to see if `ty` is of the form `D -> T`, where `D` is+ -- headed by a data type. We can safely ignore `forall`s here by using+ -- `filterVisFunArgs`, as we only care about the first visible argument.+ let (ty_args, _ty_res) = unravelType ty+ ty_vis_args = filterVisFunArgs ty_args+ case ty_vis_args of+ [VisFAAnon ty_anon_arg]+ | (ConT parent_name, _) <- unfoldType ty_anon_arg+ -> -- If we find the data type constructor `parent_name`, then check+ -- if one of the data constructors for `parent_name` contains a+ -- record field named `n`.+ do mb_parent_info <- reifyWithLocals_maybe parent_name+ pure $ case mb_parent_info of+ Just (TyConI (DataD _cxt _name _tvbs _mk cons _derivings))+ | isJust $ findRecSelector n cons+ -> FldName $ nameBase parent_name+ Just (TyConI (NewtypeD _cxt _name _tvbs _mk con _derivings))+ | isJust $ findRecSelector n [con]+ -> FldName $ nameBase parent_name+ _ -> VarName+ _ -> pure VarName+#else+ VarI{} -> pure VarName+#endif - DataConI{} -> DataName+ DataConI _dc_name _dc_ty parent_name -> do+ -- DataConI usually refers to a value-level Name, but it could also refer+ -- to a type-level 'Name' if the data constructor corresponds to a+ -- @type data@ declaration. In order to know for sure, we must perform+ -- some additional reification.+ mb_parent_info <- reifyWithLocals_maybe parent_name+ pure $ case mb_parent_info of+#if __GLASGOW_HASKELL__ >= 906+ Just (TyConI (TypeDataD {}))+ -> TcClsName+#endif+ _ -> DataName #if __GLASGOW_HASKELL__ >= 801- PatSynI{} -> DataName+ PatSynI{} -> pure DataName #endif
Language/Haskell/TH/Desugar/Subst.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE CPP #-}- ----------------------------------------------------------------------------- -- | -- Module : Language.Haskell.TH.Desugar.Subst@@ -9,7 +7,9 @@ -- Stability : experimental -- Portability : non-portable ----- Capture-avoiding substitutions on 'DType's+-- Capture-avoiding substitutions on 'DType's. (For non–capture-avoiding+-- substitution functions, use "Language.Haskell.TH.Desugar.Subst.Capturing"+-- instead.) -- ---------------------------------------------------------------------------- @@ -17,7 +17,7 @@ DSubst, -- * Capture-avoiding substitution- substTy, substForallTelescope, substTyVarBndrs,+ substTy, substForallTelescope, substTyVarBndrs, substTyVarBndr, unionSubsts, unionMaybeSubsts, -- * Matching a type template against a type@@ -29,13 +29,15 @@ import qualified Data.Set as S import Language.Haskell.TH.Desugar.AST-import Language.Haskell.TH.Syntax import Language.Haskell.TH.Desugar.Util+import Language.Haskell.TH.Syntax --- | A substitution is just a map from names to types+-- | A substitution is just a map from names to types. type DSubst = M.Map Name DType --- | Capture-avoiding substitution on types+-- | Capture-avoiding substitution on 'DType's. This function requires a 'Quasi'+-- constraint because it may need to create fresh names in order to avoid+-- capture when substituting into a @forall@ type (see 'substTyVarBndr'). substTy :: Quasi q => DSubst -> DType -> q DType substTy vars (DForallT tele ty) = do (vars', tele') <- substForallTelescope vars tele@@ -59,6 +61,10 @@ substTy _ ty@(DLitT _) = return ty substTy _ ty@DWildCardT = return ty +-- | Capture-avoiding substitution on 'DForallTelescope's. This returns a pair+-- containing the new 'DSubst' as well as a new 'DForallTelescope' value, where+-- the names have been renamed to avoid capture and the kinds have been+-- substituted. substForallTelescope :: Quasi q => DSubst -> DForallTelescope -> q (DSubst, DForallTelescope) substForallTelescope vars tele =@@ -70,16 +76,25 @@ (vars', tvbs') <- substTyVarBndrs vars tvbs return (vars', DForallInvis tvbs') +-- | Capture-avoiding substitution on a telescope of 'DTyVarBndr's. This returns+-- a pair containing the new 'DSubst' as well as a new telescope of+-- 'DTyVarBndr's, where the names have been renamed to avoid capture and the+-- kinds have been substituted. substTyVarBndrs :: Quasi q => DSubst -> [DTyVarBndr flag] -> q (DSubst, [DTyVarBndr flag])-substTyVarBndrs = mapAccumLM substTvb+substTyVarBndrs = mapAccumLM substTyVarBndr -substTvb :: Quasi q => DSubst -> DTyVarBndr flag+-- | Capture-avoiding substitution on a 'DTyVarBndr'. This uses the 'Quasi'+-- constraint to create a new, fresh name (based on the name of the supplied+-- 'DTyVarBndr'), update the 'DSubst' to map from the old name to the new name,+-- and this also returns a 'DTyVarBndr' containing the new name and the kind of+-- the supplied 'DTyVarBndr' (with the substitution applied).+substTyVarBndr :: Quasi q => DSubst -> DTyVarBndr flag -> q (DSubst, DTyVarBndr flag)-substTvb vars (DPlainTV n flag) = do+substTyVarBndr vars (DPlainTV n flag) = do new_n <- qNewName (nameBase n) return (M.insert n (DVarT new_n) vars, DPlainTV new_n flag)-substTvb vars (DKindedTV n flag k) = do+substTyVarBndr vars (DKindedTV n flag k) = do new_n <- qNewName (nameBase n) k' <- substTy vars k return (M.insert n (DVarT new_n) vars, DKindedTV new_n flag k')@@ -116,12 +131,17 @@ matchTy :: IgnoreKinds -> DType -> DType -> Maybe DSubst matchTy _ (DVarT var_name) arg = Just $ M.singleton var_name arg -- if a pattern has a kind signature, it's really easy to get- -- this wrong.+ -- the following two cases wrong. matchTy ign (DSigT ty _ki) arg = case ign of YesIgnore -> matchTy ign ty arg NoIgnore -> Nothing- -- but we can safely ignore kind signatures on the target-matchTy ign pat (DSigT ty _ki) = matchTy ign pat ty+matchTy ign (DAppKindT ty _ki) arg = case ign of+ YesIgnore -> matchTy ign ty arg+ NoIgnore -> Nothing+ -- but we can safely ignore kind signatures on the target,+ -- as in the following two cases.+matchTy ign pat (DSigT ty _ki) = matchTy ign pat ty+matchTy ign pat (DAppKindT ty _ki) = matchTy ign pat ty matchTy _ (DForallT {}) _ = error "Cannot match a forall in a pattern" matchTy _ _ (DForallT {}) =
+ Language/Haskell/TH/Desugar/Subst/Capturing.hs view
@@ -0,0 +1,77 @@+-----------------------------------------------------------------------------+-- |+-- Module : Language.Haskell.TH.Desugar.Subst.Capturing+-- Copyright : (C) 2024 Ryan Scott+-- License : BSD-style (see LICENSE)+-- Maintainer : Ryan Scott+-- Stability : experimental+-- Portability : non-portable+--+-- Substitutions on 'DType's that do /not/ avoid capture. (For capture-avoiding+-- substitution functions, use "Language.Haskell.TH.Desugar.Subst" instead.)+--+----------------------------------------------------------------------------++module Language.Haskell.TH.Desugar.Subst.Capturing (+ DSubst,++ -- * Non–capture-avoiding substitution+ substTy, substForallTelescope, substTyVarBndrs, substTyVarBndr,+ unionSubsts, unionMaybeSubsts,++ -- * Matching a type template against a type+ IgnoreKinds(..), matchTy+ ) where++import Data.Bifunctor (second)+import qualified Data.List as L+import qualified Data.Map as M++import Language.Haskell.TH.Desugar.AST+import Language.Haskell.TH.Desugar.Subst+ (DSubst, unionSubsts, unionMaybeSubsts, IgnoreKinds(..), matchTy)++-- | Non–capture-avoiding substitution on 'DType's. Unlike the @substTy@+-- function in "Language.Haskell.TH.Desugar.Subst", this 'substTy' function is+-- pure, as it never needs to create fresh names.+substTy :: DSubst -> DType -> DType+substTy subst ty | M.null subst = ty+substTy subst (DForallT tele inner_ty)+ = DForallT tele' inner_ty'+ where+ (subst', tele') = substForallTelescope subst tele+ inner_ty' = substTy subst' inner_ty+substTy subst (DConstrainedT cxt inner_ty) =+ DConstrainedT (map (substTy subst) cxt) (substTy subst inner_ty)+substTy subst (DAppT ty1 ty2) = substTy subst ty1 `DAppT` substTy subst ty2+substTy subst (DAppKindT ty ki) = substTy subst ty `DAppKindT` substTy subst ki+substTy subst (DSigT ty ki) = substTy subst ty `DSigT` substTy subst ki+substTy subst (DVarT n) =+ case M.lookup n subst of+ Just ki -> ki+ Nothing -> DVarT n+substTy _ ty@(DConT {}) = ty+substTy _ ty@(DArrowT) = ty+substTy _ ty@(DLitT {}) = ty+substTy _ ty@DWildCardT = ty++-- | Non–capture-avoiding substitution on 'DForallTelescope's. This returns a+-- pair containing the new 'DSubst' as well as a new 'DForallTelescope' value,+-- where the kinds have been substituted.+substForallTelescope :: DSubst -> DForallTelescope -> (DSubst, DForallTelescope)+substForallTelescope s (DForallInvis tvbs) = second DForallInvis $ substTyVarBndrs s tvbs+substForallTelescope s (DForallVis tvbs) = second DForallVis $ substTyVarBndrs s tvbs++-- | Non–capture-avoiding substitution on a telescope of 'DTyVarBndr's. This+-- returns a pair containing the new 'DSubst' as well as a new telescope of+-- 'DTyVarBndr's, where the kinds have been substituted.+substTyVarBndrs :: DSubst -> [DTyVarBndr flag] -> (DSubst, [DTyVarBndr flag])+substTyVarBndrs = L.mapAccumL substTyVarBndr++-- | Non–capture-avoiding substitution on a 'DTyVarBndr'. This updates the+-- 'DSubst' to remove the 'DTyVarBndr' name from the domain (as that name is now+-- bound by the 'DTyVarBndr') and applies the substitution to the kind of the+-- 'DTyVarBndr'.+substTyVarBndr :: DSubst -> DTyVarBndr flag -> (DSubst, DTyVarBndr flag)+substTyVarBndr s tvb@(DPlainTV n _) = (M.delete n s, tvb)+substTyVarBndr s (DKindedTV n f k) = (M.delete n s, DKindedTV n f (substTy s k))
Language/Haskell/TH/Desugar/Sweeten.hs view
@@ -39,7 +39,7 @@ import Prelude hiding (exp) import Control.Arrow -import Language.Haskell.TH hiding (cxt)+import Language.Haskell.TH hiding (Extension(..), cxt) import Language.Haskell.TH.Datatype.TyVarBndr import Language.Haskell.TH.Desugar.AST@@ -51,8 +51,6 @@ expToTH (DConE n) = ConE n expToTH (DLitE l) = LitE l expToTH (DAppE e1 e2) = AppE (expToTH e1) (expToTH e2)-expToTH (DLamE names exp) = LamE (map VarP names) (expToTH exp)-expToTH (DCaseE exp matches) = CaseE (expToTH exp) (map matchToTH matches) expToTH (DLetE decs exp) = LetE (map letDecToTH decs) (expToTH exp) expToTH (DSigE exp ty) = SigE (expToTH exp) (typeToTH ty) expToTH (DStaticE exp) = StaticE (expToTH exp)@@ -63,7 +61,94 @@ -- type applications, we will simply drop the applied type. expToTH (DAppTypeE exp _) = expToTH exp #endif+expToTH (DLamCasesE clauses)+ -- In the source language, `\cases` expressions must have at least one clause.+ -- As such, we adopt the convention that a DLamCasesE value with no clauses+ -- shall sweeten to a `\case{}` expression. Unlike `\cases`, it is legal for+ -- `\case` to have no clauses, and `\case{}` is assumed to have a single+ -- argument.+ | null clauses+ = LamCaseE []+#if __GLASGOW_HASKELL__ >= 904+ -- If building with GHC 9.4 or later, sweetening a DLamCasesE value is as+ -- simple as using LamCasesE...+ | otherwise+ = LamCasesE (map clauseToTH clauses)+#else+ -- ...but if we are building with a pre-9.4 version of GHC, we do not have+ -- access to LamCasesE, making our life harder. We want to have at least+ -- /some/ support for sweetening DLamCasesE values, since we desugar simpler+ -- language constructs like lambda, `case`, and `\case` expressions to+ -- DLamCasesE, and we'd like to be able to sweeten them back.+ --+ -- Therefore, we add special treatment for DLamCasesE values that look simpler+ -- language constructs and sweeten these back to LamE, LamCaseE, etc. If we+ -- encounter anything more complicated, we give up and raise an error. + -- Special case: if a DLamCasesE value has exactly one clause, we can sweeten+ -- the DLamCasesE value as though it were a lambda expression (LamE).+ | [DClause pats exp] <- clauses+ = LamE (map patToTH pats) (expToTH exp)+ -- Special case: if a DLamCasesE value's clauses each have exactly one+ -- pattern, we can sweeten the DLamCasesE value as though it were a `\case`+ -- expression (LamCaseE).+ | Just matches <- traverse dMatch_maybe clauses+ = LamCaseE (map matchToTH matches)+ -- NB: You might wonder why there is not another special case that returns+ -- CaseE for things that look like `case` expressions. This is because the+ -- special case for LamCaseE above already suffices. Note that we desugar+ -- `case` expressions to code that looks like this:+ --+ -- (\cases+ -- pat_1 -> rhs_1+ -- ...+ -- pat_n -> rhs_n) scrut+ --+ -- That is, a value that looks like `DAppE (DLamCasesE ...) scrut`. Each+ -- clause in the DLamCasesE value has exactly one pattern, however. Therefore,+ -- because of the special treatment for LamCaseE above, this code would+ -- sweeten to `AppE (LamCaseE ...) scrut`.++ -- If we lack a special case for the DLamCasesE value, then we raise an error.+ | otherwise+ = error $ unlines+ [ "Non-trivial \\cases expressions supported only in GHC 9.4+."+ , "Here, \"non-trivial\" means that the \\cases expression cannot easily"+ , "be rewritten to a lambda, case, or \\case expression without"+ , "significantly rewriting the expression. Either rewrite the expression"+ , "yourself or upgrade to a later version of GHC."+ ]+#endif+#if __GLASGOW_HASKELL__ >= 907+expToTH (DTypedBracketE exp) = TypedBracketE (expToTH exp)+expToTH (DTypedSpliceE exp) = TypedSpliceE (expToTH exp)+#else+expToTH (DTypedBracketE {}) =+ error "Typed Template Haskell brackets supported only in GHC 9.8+"+expToTH (DTypedSpliceE {}) =+ error "Typed Template Haskell splices supported only in GHC 9.8+"+#endif+#if __GLASGOW_HASKELL__ >= 909+expToTH (DTypeE ty) = TypeE (typeToTH ty)+#else+expToTH (DTypeE {}) =+ error "Embedded type expressions supported only in GHC 9.10+"+#endif+#if __GLASGOW_HASKELL__ >= 911+expToTH (DForallE tele exp) =+ case tele of+ DForallInvis tvbs -> ForallE (map tvbToTH tvbs) exp'+ DForallVis tvbs -> ForallVisE (map tvbToTH tvbs) exp'+ where+ exp' = expToTH exp+expToTH (DConstrainedE cxt exp) = ConstrainedE (map expToTH cxt) (expToTH exp)+#else+expToTH (DForallE {}) =+ error "Embedded `forall`s supported only in GHC 9.12+"+expToTH (DConstrainedE {}) =+ error "Embedded constraints supported only in GHC 9.12+"+#endif+ matchToTH :: DMatch -> Match matchToTH (DMatch pat exp) = Match (patToTH pat) (NormalB (expToTH exp)) [] @@ -79,6 +164,15 @@ patToTH (DBangP pat) = BangP (patToTH pat) patToTH (DSigP pat ty) = SigP (patToTH pat) (typeToTH ty) patToTH DWildP = WildP+#if __GLASGOW_HASKELL__ >= 909+patToTH (DTypeP ty) = TypeP (typeToTH ty)+patToTH (DInvisP ty) = InvisP (typeToTH ty)+#else+patToTH (DTypeP {}) =+ error "Embedded type patterns supported only in GHC 9.10+"+patToTH (DInvisP {}) =+ error "Invisible type patterns supported only in GHC 9.10+"+#endif decsToTH :: [DDec] -> [Dec] decsToTH = map decToTH@@ -108,9 +202,10 @@ DataFamilyD n (map tvbToTH tvbs) (fmap typeToTH mk) decToTH (DDataInstD nd cxt mtvbs lhs mk cons derivings) = let ndc = case (nd, cons) of- (Newtype, [con]) -> DNewtypeCon con- (Newtype, _) -> error "Newtype that doesn't have only one constructor"- (Data, _) -> DDataCons cons+ (Newtype, [con]) -> DNewtypeCon con+ (Newtype, _) -> error "Newtype that doesn't have only one constructor"+ (Data, _) -> DDataCons cons+ (TypeData, _) -> error "Data family instance that is combined with `type data`" in dataInstDecToTH ndc cxt mtvbs lhs mk derivings #if __GLASGOW_HASKELL__ >= 807 decToTH (DTySynInstD eqn) = TySynInstD (snd $ tySynEqnToTH eqn)@@ -146,6 +241,15 @@ decToTH (DDefaultD{}) = error "Default declarations supported only in GHC 9.4+" #endif+#if __GLASGOW_HASKELL__ >= 906+decToTH (DDataD TypeData _cxt n tvbs mk cons _derivings) =+ -- NB: Due to the invariants on 'DDataD' and 'TypeData', _cxt and _derivings+ -- will be empty.+ TypeDataD n (map tvbToTH tvbs) (fmap typeToTH mk) (map conToTH cons)+#else+decToTH (DDataD TypeData _cxt _n _tvbs _mk _cons _derivings) =+ error "`type data` declarations supported only in GHC 9.6+"+#endif #if __GLASGOW_HASKELL__ < 801 patSynErr :: a@@ -199,7 +303,12 @@ letDecToTH (DFunD name clauses) = FunD name (map clauseToTH clauses) letDecToTH (DValD pat exp) = ValD (patToTH pat) (NormalB (expToTH exp)) [] letDecToTH (DSigD name ty) = SigD name (typeToTH ty)-letDecToTH (DInfixD f name) = InfixD f name+letDecToTH (DInfixD f _ns_spec name) =+ InfixD f+#if __GLASGOW_HASKELL__ >= 909+ _ns_spec+#endif+ name letDecToTH (DPragmaD prag) = PragmaD (pragmaToTH prag) conToTH :: DCon -> Con@@ -254,6 +363,22 @@ pragmaToTH (DOpaqueP n) = OpaqueP n #else pragmaToTH (DOpaqueP {}) = error "OPAQUE pragmas only supported in GHC 9.4+"+#endif+#if __GLASGOW_HASKELL__ >= 909+pragmaToTH (DSCCP nm mstr) = SCCP nm mstr+#else+pragmaToTH (DSCCP {}) = error "SCCP pragmas only supported in GHC 9.10+"+#endif+#if __GLASGOW_HASKELL__ >= 913+pragmaToTH (DSpecialiseEP mTyBndrs tmBndrs specE mInline phases) =+ SpecialiseEP+ (fmap (fmap tvbToTH) mTyBndrs)+ (map ruleBndrToTH tmBndrs)+ (expToTH specE)+ mInline+ phases+#else+pragmaToTH (DSpecialiseEP {}) = error "DSpecialiseEP pragmas only supported in GHC 9.14+" #endif ruleBndrToTH :: DRuleBndr -> RuleBndr
Language/Haskell/TH/Desugar/Util.hs view
@@ -6,9 +6,9 @@ Utility functions for th-desugar package. -} -{-# LANGUAGE CPP, DeriveDataTypeable, RankNTypes, ScopedTypeVariables,- TupleSections, AllowAmbiguousTypes, TemplateHaskellQuotes,- TypeApplications #-}+{-# LANGUAGE CPP, DeriveDataTypeable, DeriveGeneric, DeriveLift, RankNTypes,+ ScopedTypeVariables, TupleSections, AllowAmbiguousTypes,+ TemplateHaskellQuotes, TypeApplications, MagicHash #-} module Language.Haskell.TH.Desugar.Util ( newUniqueName,@@ -16,39 +16,71 @@ nameOccursIn, allNamesIn, mkTypeName, mkDataName, mkNameWith, isDataName, stripVarP_maybe, extractBoundNamesStmt, concatMapM, mapAccumLM, mapMaybeM, expectJustM,- stripPlainTV_maybe,+ stripPlainTV_maybe, extractTvbKind_maybe, thirdOf3, splitAtList, extractBoundNamesDec, extractBoundNamesPat,- tvbToType, tvbToTypeWithSig, tvbToTANormalWithSig,- nameMatches, thdOf3, liftFst, liftSnd, firstMatch,- unboxedSumDegree_maybe, unboxedSumNameDegree_maybe,- tupleDegree_maybe, tupleNameDegree_maybe, unboxedTupleDegree_maybe,- unboxedTupleNameDegree_maybe, splitTuple_maybe,+ tvbToType, tvbToTypeWithSig,+ nameMatches, thdOf3, liftFst, liftSnd, firstMatch, firstMatchM,+ tupleNameDegree_maybe,+ unboxedSumNameDegree_maybe, unboxedTupleNameDegree_maybe, splitTuple_maybe, topEverywhereM, isInfixDataCon, isTypeKindName, typeKindName, unSigType, unfoldType, ForallTelescope(..), FunArgs(..), VisFunArg(..), filterVisFunArgs, ravelType, unravelType, TypeArg(..), applyType, filterTANormals, probablyWrongUnTypeArg,- bindIP+ tyVarBndrVisToTypeArg, tyVarBndrVisToTypeArgWithSig,+ bindIP,+ DataFlavor(..),+ freeKindVariablesWellScoped,+ ForAllTyFlag(..), tvbForAllTyFlagsToSpecs, tvbForAllTyFlagsToBndrVis,+ matchUpSAKWithDecl ) where import Prelude hiding (mapM, foldl, concatMap, any) import Language.Haskell.TH hiding ( cxt )+import Language.Haskell.TH.Datatype import Language.Haskell.TH.Datatype.TyVarBndr import qualified Language.Haskell.TH.Desugar.OSet as OS import Language.Haskell.TH.Desugar.OSet (OSet)+import Language.Haskell.TH.Instances () import Language.Haskell.TH.Syntax import qualified Control.Monad.Fail as Fail import Data.Foldable+import Data.Function ( on )+import Data.Generics ( Data, Typeable, everything, extM, gmapM, mkQ ) import qualified Data.Kind as Kind-import Data.Generics hiding ( Fixity )-import Data.Traversable+import qualified Data.List as List+import qualified Data.Map as Map+import Data.Map ( Map ) import Data.Maybe+import qualified Data.Set as Set+import Data.Traversable import GHC.Classes ( IP )+import GHC.Generics ( Generic ) import Unsafe.Coerce ( unsafeCoerce ) +#if __GLASGOW_HASKELL__ >= 900+import Language.Haskell.TH.Ppr ( PprFlag(..) )+import qualified Language.Haskell.TH.PprLib as Ppr+#endif++#if __GLASGOW_HASKELL__ >= 906+import GHC.Tuple ( Solo(MkSolo) )+#elif __GLASGOW_HASKELL__ >= 900+import GHC.Tuple ( Solo(Solo) )+#endif++#if __GLASGOW_HASKELL__ >= 908+import GHC.Tuple ( Tuple0, Unit )+import Text.Read ( readMaybe )+#endif++#if __GLASGOW_HASKELL__ >= 910+import GHC.Types ( Solo#, Sum2#, Tuple0#, Unit# )+#endif+ ---------------------------------------- -- TH manipulations ----------------------------------------@@ -101,6 +133,11 @@ stripPlainTV_maybe :: TyVarBndr_ flag -> Maybe Name stripPlainTV_maybe = elimTV Just (\_ _ -> Nothing) +-- | Extracts the kind from a 'TyVarBndr'. Returns @'Just' k@ if the 'TyVarBndr'+-- is a 'KindedTV' and returns 'Nothing' if it is a 'PlainTV'.+extractTvbKind_maybe :: TyVarBndr_ flag -> Maybe Kind+extractTvbKind_maybe = elimTV (\_ -> Nothing) (\_ k -> Just k)+ -- | Report that a certain TH construct is impossible impossible :: Fail.MonadFail q => String -> q a impossible err = Fail.fail (err ++ "\n This should not happen in Haskell.\n Please email rae@cs.brynmawr.edu with your code if you see this.")@@ -115,11 +152,6 @@ tvbToTypeWithSig :: TyVarBndr_ flag -> Type tvbToTypeWithSig = elimTV VarT (\n k -> SigT (VarT n) k) --- | Convert a 'TyVarBndr' into a 'TypeArg' (specifically, a 'TANormal'),--- preserving the kind signature (if it has one).-tvbToTANormalWithSig :: TyVarBndr_ flag -> TypeArg-tvbToTANormalWithSig = TANormal . tvbToTypeWithSig- -- | Do two names name the same thing? nameMatches :: Name -> Name -> Bool nameMatches n1@(Name occ1 flav1) n2@(Name occ2 flav2)@@ -137,27 +169,103 @@ | otherwise = n1 == n2 --- | Extract the degree of a tuple-tupleDegree_maybe :: String -> Maybe Int-tupleDegree_maybe s = do- '(' : s1 <- return s- (commas, ")") <- return $ span (== ',') s1- let degree- | "" <- commas = 0- | otherwise = length commas + 1- return degree---- | Extract the degree of a tuple name+-- | Extract the degree of a tuple 'Name'.+--+-- In addition to recognizing tuple syntax (e.g., @''(,,)@), this also+-- recognizes the following:+--+-- * @''Unit@ (for 0-tuples)+--+-- * @''Solo@/@'MkSolo@ (for 1-tuples)+--+-- * @''Tuple<N>@ (for <N>-tuples)+--+-- In recent versions of GHC, @''()@ is a synonym for @''Unit@, @''(,)@ is a+-- synonym for @''Tuple2@, and so on. As a result, we must check for @''Unit@+-- and @''Tuple<N>@ in 'tupleDegree_maybe' to be thorough. (There is no special+-- tuple syntax for @''Solo@/@'MkSolo@, but we check them here as well for the+-- sake of completeness.) tupleNameDegree_maybe :: Name -> Maybe Int-tupleNameDegree_maybe = tupleDegree_maybe . nameBase+tupleNameDegree_maybe name+ -- First, check for Solo/MkSolo...+#if __GLASGOW_HASKELL__ >= 900+ | name == ''Solo = Just 1+#if __GLASGOW_HASKELL__ >= 906+ | name == 'MkSolo = Just 1+#else+ | name == 'Solo = Just 1+#endif+#endif+#if __GLASGOW_HASKELL__ >= 908+ -- ...then, check for Unit...+ | name == ''Unit = Just 0+ -- ...then, check for Tuple<N>. It is theoretically possible for the supplied+ -- Name to be a user-defined data type named Tuple<N>, rather than the actual+ -- tuple types defined in GHC.Tuple. As such, we check that the package and+ -- module for the supplied Name does in fact come from ghc-prim:GHC.Tuple as+ -- a sanity check.+ | -- We use Tuple0 here simply because it is a convenient identifier from+ -- GHC.Tuple. We could just as well use any other identifier from GHC.Tuple,+ -- however.+ namePackage name == namePackage ''Tuple0+ , nameModule name == nameModule ''Tuple0+ , 'T':'u':'p':'l':'e':n <- nameBase name+ -- This relies on the Read Int instance. This is more permissive than what+ -- we need, since there are valid Int strings (e.g., "-1") that do not have+ -- corresponding Tuple<N> names (e.g., "Tuple-1" is not a data type in+ -- GHC.Tuple). As such, we depend on the assumption that the input string+ -- does in fact come from GHC.Tuple, which we check above.+ = readMaybe n+#endif+ -- ...otherwise, fall back on tuple syntax.+ | otherwise+ = tuple_syntax_degree_maybe (nameBase name)+ where+ -- Extract the degree of a string using tuple syntax (e.g., @''(,,)@).+ tuple_syntax_degree_maybe :: String -> Maybe Int+ tuple_syntax_degree_maybe s = do+ '(' : s1 <- return s+ (commas, ")") <- return $ span (== ',') s1+ let degree+ | "" <- commas = 0+ | otherwise = length commas + 1+ return degree -- | Extract the degree of an unboxed sum unboxedSumDegree_maybe :: String -> Maybe Int unboxedSumDegree_maybe = unboxedSumTupleDegree_maybe '|' --- | Extract the degree of an unboxed sum name+-- | Extract the degree of an unboxed sum 'Name'.+--+-- In addition to recognizing unboxed sum syntax (e.g., @''(#||#)@), this also+-- recognizes @''Sum<N>#@ (for unboxed <N>-ary sum type constructors). In recent+-- versions of GHC, @''Sum2#@ is a synonym for @''(#|#)@, @''Sum3#@ is a synonym+-- for @''(#||#)@, and so on. As a result, we must check for @''Sum<N>#@ in+-- 'unboxedSumNameDegree_maybe' to be thorough. unboxedSumNameDegree_maybe :: Name -> Maybe Int-unboxedSumNameDegree_maybe = unboxedSumDegree_maybe . nameBase+unboxedSumNameDegree_maybe name+#if __GLASGOW_HASKELL__ >= 910+ -- Check for Sum<N>#. It is theoretically possible for the supplied+ -- Name to be a user-defined data type named Sum<N>#, rather than the actual+ -- unboxed sum types defined in GHC.Types. As such, we check that the package+ -- and module for the supplied Name does in fact come from ghc-prim:GHC.Types+ -- as a sanity check.+ | -- We use Sum2# here simply because it is a convenient identifier from+ -- GHC.Types. We could just as well use any other identifier from GHC.Types,+ -- however.+ namePackage name == namePackage ''Sum2#+ , nameModule name == nameModule ''Sum2#+ , 'S':'u':'m':n:"#" <- nameBase name+ -- This relies on the Read Int instance. This is more permissive than what+ -- we need, since there are valid Int strings (e.g., "-1") that do not have+ -- corresponding Sum<N># names (e.g., "Sum-1#" is not a data type in+ -- GHC.Types). As such, we depend on the assumption that the input string+ -- does in fact come from GHC.Types, which we check above.+ = readMaybe [n]+#endif+ -- ...otherwise, fall back on unboxed sum syntax.+ | otherwise+ = unboxedSumDegree_maybe (nameBase name) -- | Extract the degree of an unboxed tuple unboxedTupleDegree_maybe :: String -> Maybe Int@@ -173,9 +281,50 @@ | otherwise = length seps + 1 return degree --- | Extract the degree of an unboxed tuple name+-- | Extract the degree of an unboxed tuple 'Name'.+--+-- In addition to recognizing unboxed tuple syntax (e.g., @''(#,,#)@), this also+-- recognizes the following:+--+-- * @''Unit#@ (for unboxed 0-tuples)+--+-- * @''Solo#@/@'Solo#@ (for unboxed 1-tuples)+--+-- * @''Tuple<N>#@ (for unboxed <N>-tuples)+--+-- In recent versions of GHC, @''(##)@ is a synonym for @''Unit#@, @''(#,#)@ is+-- a synonym for @''Tuple2#@, and so on. As a result, we must check for+-- @''Unit#@, and @''Tuple<N>@ in 'unboxedTupleNameDegree_maybe' to be thorough.+-- (There is no special unboxed tuple type constructor for @''Solo#@/@'Solo#@,+-- but we check them here as well for the sake of completeness.) unboxedTupleNameDegree_maybe :: Name -> Maybe Int-unboxedTupleNameDegree_maybe = unboxedTupleDegree_maybe . nameBase+unboxedTupleNameDegree_maybe name+#if __GLASGOW_HASKELL__ >= 910+ -- First, check for Solo#...+ | name == ''Solo# = Just 1+ -- ...then, check for Unit#...+ | name == ''Unit# = Just 0+ -- ...then, check for Tuple<N>#. It is theoretically possible for the supplied+ -- Name to be a user-defined data type named Tuple<N>#, rather than the actual+ -- unboxed tuple types defined in GHC.Types. As such, we check that the+ -- package and module for the supplied Name does in fact come from+ -- ghc-prim:GHC.Types as a sanity check.+ | -- We use Tuple0# here simply because it is a convenient identifier from+ -- GHC.Types. We could just as well use any other identifier from GHC.Types,+ -- however.+ namePackage name == namePackage ''Tuple0#+ , nameModule name == nameModule ''Tuple0#+ , 'T':'u':'p':'l':'e':n:"#" <- nameBase name+ -- This relies on the Read Int instance. This is more permissive than what+ -- we need, since there are valid Int strings (e.g., "-1") that do not have+ -- corresponding Tuple<N># names (e.g., "Tuple-1#" is not a data type in+ -- GHC.Types). As such, we depend on the assumption that the input string+ -- does in fact come from GHC.Types, which we check above.+ = readMaybe [n]+#endif+ -- ...otherwise, fall back on unboxed tuple syntax.+ | otherwise+ = unboxedTupleDegree_maybe (nameBase name) -- | If the argument is a tuple type, return the components splitTuple_maybe :: Type -> Maybe [Type]@@ -308,18 +457,40 @@ -- @ -- ('ConT' ''Proxy, ['TyArg' ('ConT' ''Type), 'TANormal' ('ConT' ''Char)]) -- @+--+-- This process forgets about infix application, so both of these types:+--+-- @+-- Int :++: Int+-- (:++:) Int Int+-- @+--+-- will be unfolded to this:+--+-- @+-- ('ConT' ''(:+:), ['TANormal' ('ConT' ''Int), 'TANormal' ('ConT' ''Int)])+-- @+--+-- This function should only be used after all 'UInfixT' and 'PromotedUInfixT'+-- types have been resolved (e.g., via @th-abstraction@'s+-- @<https://hackage.haskell.org/package/th-abstraction-0.5.0.0/docs/Language-Haskell-TH-Datatype.html#v:resolveInfixT resolveInfixT>@+-- function). unfoldType :: Type -> (Type, [TypeArg]) unfoldType = go [] where go :: [TypeArg] -> Type -> (Type, [TypeArg])- go acc (ForallT _ _ ty) = go acc ty- go acc (AppT ty1 ty2) = go (TANormal ty2:acc) ty1- go acc (SigT ty _) = go acc ty- go acc (ParensT ty) = go acc ty+ go acc (ForallT _ _ ty) = go acc ty+ go acc (AppT ty1 ty2) = go (TANormal ty2:acc) ty1+ go acc (SigT ty _) = go acc ty+ go acc (ParensT ty) = go acc ty+ go acc (InfixT ty1 n ty2) = go (TANormal ty1:TANormal ty2:acc) (ConT n) #if __GLASGOW_HASKELL__ >= 807- go acc (AppKindT ty ki) = go (TyArg ki:acc) ty+ go acc (AppKindT ty ki) = go (TyArg ki:acc) ty #endif- go acc ty = (ty, acc)+#if __GLASGOW_HASKELL__ >= 904+ go acc (PromotedInfixT ty1 n ty2) = go (TANormal ty1:TANormal ty2:acc) (PromotedT n)+#endif+ go acc ty = (ty, acc) -- | An argument to a type, either a normal type ('TANormal') or a visible -- kind application ('TyArg').@@ -354,6 +525,36 @@ getTANormal (TANormal t) = Just t getTANormal (TyArg {}) = Nothing +-- | Convert a 'TyVarBndrVis' to a 'TypeArg'. That is, convert a binder with a+-- 'BndrReq' visibility to a 'TANormal' and a binder with 'BndrInvis'+-- visibility to a 'TyArg'.+--+-- If given a 'KindedTV', the resulting 'TypeArg' will omit the kind signature.+-- Use 'tyVarBndrVisToTypeArgWithSig' if you want to preserve the kind+-- signature.+tyVarBndrVisToTypeArg :: TyVarBndrVis -> TypeArg+tyVarBndrVisToTypeArg bndr =+ case tvFlag bndr of+ BndrReq -> TANormal bndr_ty+ BndrInvis -> TyArg bndr_ty+ where+ bndr_ty = tvbToType bndr++-- | Convert a 'TyVarBndrVis' to a 'TypeArg'. That is, convert a binder with a+-- 'BndrReq' visibility to a 'TANormal' and a binder with 'BndrInvis'+-- visibility to a 'TyArg'.+--+-- If given a 'KindedTV', the resulting 'TypeArg' will preserve the kind+-- signature. Use 'tyVarBndrVisToTypeArg' if you want to omit the kind+-- signature.+tyVarBndrVisToTypeArgWithSig :: TyVarBndrVis -> TypeArg+tyVarBndrVisToTypeArgWithSig bndr =+ case tvFlag bndr of+ BndrReq -> TANormal bndr_ty+ BndrInvis -> TyArg bndr_ty+ where+ bndr_ty = tvbToTypeWithSig bndr+ -- | Extract the underlying 'Type' or 'Kind' from a 'TypeArg'. This forgets -- information about whether a type is a normal argument or not, so use with -- caution.@@ -361,6 +562,487 @@ probablyWrongUnTypeArg (TANormal t) = t probablyWrongUnTypeArg (TyArg k) = k +-------------------------------------------------------------------------------+-- Matching standalone kind signatures with binders in type-level declarations+-------------------------------------------------------------------------------++-- @'matchUpSAKWithDecl' decl_sak decl_bndrs@ produces @TyVarBndr'+-- 'ForAllTyFlag'@s for a declaration, using the original declaration's+-- standalone kind signature (@decl_sak@) and its user-written binders+-- (@decl_bndrs@) as a template. For this example:+--+-- @+-- type D :: forall j k. k -> j -> Type+-- data D \@j \@l (a :: l) b = ...+-- @+--+-- We would produce the following @'TyVarBndr' 'ForAllTyFlag'@s:+--+-- @+-- \@j \@l (a :: l) (b :: j)+-- @+--+-- From here, these @'TyVarBndr' 'ForAllTyFlag'@s can be converted into other+-- forms of 'TyVarBndr's:+--+-- * They can be converted to 'TyVarBndrSpec's using 'tvbForAllTyFlagsToSpecs'.+--+-- * They can be converted to 'TyVarBndrVis'es using 'tvbForAllTyFlagsToVis'.+--+-- Note that:+--+-- * This function has a precondition that the length of @decl_bndrs@ must+-- always be equal to the number of visible quantifiers (i.e., the number of+-- function arrows plus the number of visible @forall@–bound variables) in+-- @decl_sak@.+--+-- * Whenever possible, this function reuses type variable names from the+-- declaration's user-written binders. This is why the @'TyVarBndr'+-- 'ForAllTyFlag'@ use @\@j \@l@ instead of @\@j \@k@, since the @(a :: l)@+-- binder uses @l@ instead of @k@. We could have just as well chose the other+-- way around, but we chose to pick variable names from the user-written+-- binders since they scope over other parts of the declaration. (For example,+-- the user-written binders of a @data@ declaration scope over the type+-- variables mentioned in a @deriving@ clause.) As such, keeping these names+-- avoids having to perform some alpha-renaming.+--+-- This function's implementation was heavily inspired by parts of GHC's+-- kcCheckDeclHeader_sig function:+-- https://gitlab.haskell.org/ghc/ghc/-/blob/1464a2a8de082f66ae250d63ab9d94dbe2ef8620/compiler/GHC/Tc/Gen/HsType.hs#L2524-2643+matchUpSAKWithDecl ::+ forall q.+ Fail.MonadFail q+ => Kind+ -- ^ The declaration's standalone kind signature+ -> [TyVarBndrVis]+ -- ^ The user-written binders in the declaration+ -> q [TyVarBndr_ ForAllTyFlag]+matchUpSAKWithDecl decl_sak decl_bndrs = do+ -- (1) First, explicitly quantify any free kind variables in `decl_sak` using+ -- an invisible @forall@. This is done to ensure that precondition (2) in+ -- `matchUpSigWithDecl` is upheld. (See the Haddocks for that function).+ let decl_sak_free_tvbs =+ changeTVFlags SpecifiedSpec $ freeVariablesWellScoped [decl_sak]+ decl_sak' = ForallT decl_sak_free_tvbs [] decl_sak++ -- (2) Next, compute type variable binders using `matchUpSigWithDecl`. Note+ -- that these can be biased towards type variable names mention in `decl_sak`+ -- over names mentioned in `decl_bndrs`, but we will fix that up in the next+ -- step.+ let (decl_sak_args, _) = unravelType decl_sak'+ sing_sak_tvbs <- matchUpSigWithDecl decl_sak_args decl_bndrs++ -- (3) Finally, swizzle the type variable names so that names in `decl_bndrs`+ -- are preferred over names in `decl_sak`.+ --+ -- This is heavily inspired by similar code in GHC:+ -- https://gitlab.haskell.org/ghc/ghc/-/blob/cec903899234bf9e25ea404477ba846ac1e963bb/compiler/GHC/Tc/Gen/HsType.hs#L2607-2616+ let invis_decl_sak_args = filterInvisTvbArgs decl_sak_args+ invis_decl_sak_arg_nms = map tvName invis_decl_sak_args++ invis_decl_bndrs = freeKindVariablesWellScoped decl_bndrs+ invis_decl_bndr_nms = map tvName invis_decl_bndrs++ swizzle_env =+ Map.fromList $ zip invis_decl_sak_arg_nms invis_decl_bndr_nms+ (_, swizzled_sing_sak_tvbs) =+ List.mapAccumL (swizzleTvb swizzle_env) Map.empty sing_sak_tvbs+ pure swizzled_sing_sak_tvbs++-- Match the quantifiers in a type-level declaration's standalone kind signature+-- with the user-written binders in the declaration. This function assumes the+-- following preconditions:+--+-- 1. The number of required binders in the declaration's user-written binders+-- is equal to the number of visible quantifiers (i.e., the number of+-- function arrows plus the number of visible @forall@–bound variables) in+-- the standalone kind signature.+--+-- 2. The number of invisible \@-binders in the declaration's user-written+-- binders is less than or equal to the number of invisible quantifiers+-- (i.e., the number of invisible @forall@–bound variables) in the+-- standalone kind signature.+--+-- The implementation of this function is heavily based on a GHC function of+-- the same name:+-- https://gitlab.haskell.org/ghc/ghc/-/blob/1464a2a8de082f66ae250d63ab9d94dbe2ef8620/compiler/GHC/Tc/Gen/HsType.hs#L2645-2715+matchUpSigWithDecl ::+ forall q.+ Fail.MonadFail q+ => FunArgs+ -- ^ The quantifiers in the declaration's standalone kind signature+ -> [TyVarBndrVis]+ -- ^ The user-written binders in the declaration+ -> q [TyVarBndr_ ForAllTyFlag]+matchUpSigWithDecl = go_fun_args Map.empty+ where+ go_fun_args ::+ Map Name Type+ -- ^ A substitution from the names of @forall@-bound variables in the+ -- standalone kind signature to corresponding binder names in the+ -- user-written binders. This is because we want to reuse type variable+ -- names from the user-written binders whenever possible. For example:+ --+ -- @+ -- type T :: forall a. forall b -> Maybe (a, b) -> Type+ -- data T @x y z+ -- @+ --+ -- After matching up the @a@ in @forall a.@ with @x@ and+ -- the @b@ in @forall b ->@ with @y@, this substitution will be+ -- extended with @[a :-> x, b :-> y]@. This ensures that we will+ -- produce @Maybe (x, y)@ instead of @Maybe (a, b)@ in+ -- the kind for @z@.+ -> FunArgs -> [TyVarBndrVis] -> q [TyVarBndr_ ForAllTyFlag]+ go_fun_args _ FANil [] =+ pure []+ -- This should not happen, per precondition (1).+ go_fun_args _ FANil decl_bndrs =+ fail $ "matchUpSigWithDecl.go_fun_args: Too many binders: " ++ show decl_bndrs+ -- GHC now disallows kind-level constraints, per this GHC proposal:+ -- https://github.com/ghc-proposals/ghc-proposals/blob/b0687d96ce8007294173b7f628042ac4260cc738/proposals/0547-no-kind-equalities.rst+ -- As such, we reject non-empty kind contexts. Empty contexts (which are+ -- benign) can sometimes arise due to @ForallT@, so we add a special case+ -- to allow them.+ go_fun_args subst (FACxt [] args) decl_bndrs =+ go_fun_args subst args decl_bndrs+ go_fun_args _ (FACxt (_:_) _) _ =+ fail "matchUpSigWithDecl.go_fun_args: Unexpected kind-level constraint"+ go_fun_args subst (FAForalls (ForallInvis tvbs) sig_args) decl_bndrs =+ go_invis_tvbs subst tvbs sig_args decl_bndrs+ go_fun_args subst (FAForalls (ForallVis tvbs) sig_args) decl_bndrs =+ go_vis_tvbs subst tvbs sig_args decl_bndrs+ go_fun_args subst (FAAnon anon sig_args) (decl_bndr:decl_bndrs) =+ case tvFlag decl_bndr of+ -- If the next decl_bndr is required, then we must match its kind (if+ -- one is provided) against the anonymous kind argument.+ BndrReq -> do+ let decl_bndr_name = tvName decl_bndr+ mb_decl_bndr_kind = extractTvbKind_maybe decl_bndr+ anon' = applySubstitution subst anon++ anon'' =+ case mb_decl_bndr_kind of+ Nothing -> anon'+ Just decl_bndr_kind -> do+ let mb_match_subst = matchTy decl_bndr_kind anon'+ maybe decl_bndr_kind (`applySubstitution` decl_bndr_kind) mb_match_subst+ sig_args' <- go_fun_args subst sig_args decl_bndrs+ pure $ kindedTVFlag decl_bndr_name Required anon'' : sig_args'+ -- We have a visible, anonymous argument in the kind, but an invisible+ -- @-binder as the next decl_bndr. This is ill kinded, so throw an+ -- error.+ --+ -- This should not happen, per precondition (2).+ BndrInvis ->+ fail $ "dMatchUpSigWithDecl.go_fun_args: Expected visible binder, encountered invisible binder: "+ ++ show decl_bndr+ -- This should not happen, per precondition (1).+ go_fun_args _ _ [] =+ fail "matchUpSigWithDecl.go_fun_args: Too few binders"++ go_invis_tvbs ::+ Map Name Type+ -> [TyVarBndrSpec]+ -> FunArgs+ -> [TyVarBndrVis]+ -> q [TyVarBndr_ ForAllTyFlag]+ go_invis_tvbs subst [] sig_args decl_bndrs =+ go_fun_args subst sig_args decl_bndrs+ go_invis_tvbs subst (invis_tvb:invis_tvbs) sig_args decl_bndrss =+ case decl_bndrss of+ [] -> skip_invis_bndr+ decl_bndr:decl_bndrs ->+ case tvFlag decl_bndr of+ BndrReq -> skip_invis_bndr+ -- If the next decl_bndr is an invisible @-binder, then we must match it+ -- against the invisible forall–bound variable in the kind.+ BndrInvis -> do+ let (subst', sig_tvb) = match_tvbs subst invis_tvb decl_bndr+ sig_args' <- go_invis_tvbs subst' invis_tvbs sig_args decl_bndrs+ pure (mapTVFlag Invisible sig_tvb : sig_args')+ where+ -- There is an invisible forall in the kind without a corresponding+ -- invisible @-binder, which is allowed. In this case, we simply apply+ -- the substitution and recurse.+ skip_invis_bndr :: q [TyVarBndr_ ForAllTyFlag]+ skip_invis_bndr = do+ let (subst', invis_tvb') = substTvb subst invis_tvb+ sig_args' <- go_invis_tvbs subst' invis_tvbs sig_args decl_bndrss+ pure $ mapTVFlag Invisible invis_tvb' : sig_args'++ go_vis_tvbs ::+ Map Name Type+ -> [TyVarBndrUnit]+ -> FunArgs+ -> [TyVarBndrVis]+ -> q [TyVarBndr_ ForAllTyFlag]+ go_vis_tvbs subst [] sig_args decl_bndrs =+ go_fun_args subst sig_args decl_bndrs+ -- This should not happen, per precondition (1).+ go_vis_tvbs _ (_:_) _ [] =+ fail "matchUpSigWithDecl.go_vis_tvbs: Too few binders"+ go_vis_tvbs subst (vis_tvb:vis_tvbs) sig_args (decl_bndr:decl_bndrs) = do+ case tvFlag decl_bndr of+ -- If the next decl_bndr is required, then we must match it against the+ -- visible forall–bound variable in the kind.+ BndrReq -> do+ let (subst', sig_tvb) = match_tvbs subst vis_tvb decl_bndr+ sig_args' <- go_vis_tvbs subst' vis_tvbs sig_args decl_bndrs+ pure (mapTVFlag (const Required) sig_tvb : sig_args')+ -- We have a visible forall in the kind, but an invisible @-binder as+ -- the next decl_bndr. This is ill kinded, so throw an error.+ --+ -- This should not happen, per precondition (2).+ BndrInvis ->+ fail $ "matchUpSigWithDecl.go_vis_tvbs: Expected visible binder, encountered invisible binder: "+ ++ show decl_bndr++ -- @match_tvbs subst sig_tvb decl_bndr@ will match the kind of @decl_bndr@+ -- against the kind of @sig_tvb@ to produce a new kind. This function+ -- produces two values as output:+ --+ -- 1. A new @subst@ that has been extended such that the name of @sig_tvb@+ -- maps to the name of @decl_bndr@. (See the Haddocks for the @Map Name+ -- Type@ argument to @go_fun_args@ for an explanation of why we do this.)+ --+ -- 2. A 'TyVarBndrSpec' that has the name of @decl_bndr@, but with the new+ -- kind resulting from matching.+ match_tvbs ::+ Map Name Type+ -> TyVarBndr_ flag+ -> TyVarBndrVis+ -> (Map Name Type, TyVarBndr_ flag)+ match_tvbs subst sig_tvb decl_bndr =+ let decl_bndr_name = tvName decl_bndr+ mb_decl_bndr_kind = extractTvbKind_maybe decl_bndr++ sig_tvb_name = tvName sig_tvb+ sig_tvb_flag = tvFlag sig_tvb+ mb_sig_tvb_kind = applySubstitution subst <$> extractTvbKind_maybe sig_tvb++ mb_kind :: Maybe Kind+ mb_kind =+ case (mb_decl_bndr_kind, mb_sig_tvb_kind) of+ (Nothing, Nothing) -> Nothing+ (Just decl_bndr_kind, Nothing) -> Just decl_bndr_kind+ (Nothing, Just sig_tvb_kind) -> Just sig_tvb_kind+ (Just decl_bndr_kind, Just sig_tvb_kind) -> do+ match_subst <- matchTy decl_bndr_kind sig_tvb_kind+ Just $ applySubstitution match_subst decl_bndr_kind++ subst' = Map.insert sig_tvb_name (VarT decl_bndr_name) subst+ sig_tvb' = case mb_kind of+ Nothing -> plainTVFlag decl_bndr_name sig_tvb_flag+ Just kind -> kindedTVFlag decl_bndr_name sig_tvb_flag kind in++ (subst', sig_tvb')++-- Collect the invisible type variable binders from a sequence of FunArgs.+filterInvisTvbArgs :: FunArgs -> [TyVarBndrSpec]+filterInvisTvbArgs FANil = []+filterInvisTvbArgs (FACxt _ args) = filterInvisTvbArgs args+filterInvisTvbArgs (FAAnon _ args) = filterInvisTvbArgs args+filterInvisTvbArgs (FAForalls tele args) =+ let res = filterInvisTvbArgs args in+ case tele of+ ForallVis _ -> res+ ForallInvis tvbs' -> tvbs' ++ res++-- | Take a telescope of 'TyVarBndr's, find the free variables in their kinds,+-- and sort them in reverse topological order to ensure that they are well+-- scoped. Because the argument list is assumed to be telescoping, kind+-- variables that are bound earlier in the list are not returned. For example,+-- this:+--+-- @+-- 'freeKindVariablesWellScoped' [a :: k, b :: Proxy a]+-- @+--+-- Will return @[k]@, not @[k, a]@, since @a@ is bound earlier by @a :: k@.+freeKindVariablesWellScoped :: [TyVarBndr_ flag] -> [TyVarBndrUnit]+freeKindVariablesWellScoped tvbs =+ foldr (\tvb kvs ->+ foldMap (\t -> freeVariablesWellScoped [t]) (extractTvbKind_maybe tvb) `List.union`+ List.deleteBy ((==) `on` tvName) tvb kvs)+ []+ (changeTVFlags () tvbs)++-- | @'matchTy' tmpl targ@ matches a type template @tmpl@ against a type target+-- @targ@. This returns a Map from names of type variables in the type template+-- to types if the types indeed match up, or @Nothing@ otherwise. In the @Just@+-- case, it is guaranteed that every type variable mentioned in the template is+-- mapped by the returned substitution.+--+-- Note that this function will always return @Nothing@ if the template contains+-- an explicit kind signature or visible kind application.+--+-- This is heavily inspired by the function of the same name in+-- "Language.Haskell.TH.Desugar.Subst", which works over 'DType's instead of+-- 'Type's.+matchTy :: Type -> Type -> Maybe (Map Name Type)+matchTy (VarT var_name) arg = Just $ Map.singleton var_name arg+matchTy (SigT {}) _ = Nothing+matchTy pat (SigT ty _ki) = matchTy pat ty+#if __GLASGOW_HASKELL__ >= 807+matchTy (AppKindT {}) _ = Nothing+matchTy pat (AppKindT ty _ki) = matchTy pat ty+#endif+matchTy (ForallT {}) _ =+ error "Cannot match a forall in a pattern"+matchTy _ (ForallT {}) =+ error "Cannot match a forall in a target"+matchTy (AppT pat1 pat2) (AppT arg1 arg2) =+ unionMaybeSubsts [matchTy pat1 arg1, matchTy pat2 arg2]+matchTy (ConT pat_con) (ConT arg_con)+ | pat_con == arg_con+ = Just Map.empty+ | otherwise+ = Nothing+matchTy ArrowT ArrowT = Just Map.empty+matchTy (LitT pat_lit) (LitT arg_lit)+ | pat_lit == arg_lit+ = Just Map.empty+ | otherwise+ = Nothing+matchTy _ _ = Nothing++-- | This is inspired by the function of the same name in+-- "Language.Haskell.TH.Desugar.Subst".+unionMaybeSubsts :: [Maybe (Map Name Type)] -> Maybe (Map Name Type)+unionMaybeSubsts = List.foldl' union_subst1 (Just Map.empty)+ where+ union_subst1 ::+ Maybe (Map Name Type) -> Maybe (Map Name Type) -> Maybe (Map Name Type)+ union_subst1 ma mb = do+ a <- ma+ b <- mb+ unionSubsts a b++-- | Computes the union of two substitutions. Fails if both subsitutions map+-- the same variable to different types.+--+-- This is inspired by the function of the same name in+-- "Language.Haskell.TH.Desugar.Subst".+unionSubsts :: Map Name Type -> Map Name Type -> Maybe (Map Name Type)+unionSubsts a b =+ let shared_key_set = Map.keysSet a `Set.intersection` Map.keysSet b+ matches_up = Set.foldr (\name -> ((a Map.! name) == (b Map.! name) &&))+ True shared_key_set+ in+ if matches_up then return (a `Map.union` b) else Nothing++-- | This is inspired by the function of the same name in+-- "Language.Haskell.TH.Desugar.Subst.Capturing".+substTvb :: Map Name Kind -> TyVarBndr_ flag -> (Map Name Kind, TyVarBndr_ flag)+substTvb s tvb = (Map.delete (tvName tvb) s, mapTVKind (applySubstitution s) tvb)++-- This is heavily inspired by the `swizzleTcb` function in GHC:+-- https://gitlab.haskell.org/ghc/ghc/-/blob/cec903899234bf9e25ea404477ba846ac1e963bb/compiler/GHC/Tc/Gen/HsType.hs#L2741-2755+swizzleTvb ::+ Map Name Name+ -- ^ A \"swizzle environment\" (i.e., a map from binder names in a+ -- standalone kind signature to binder names in the corresponding+ -- type-level declaration).+ -> Map Name Type+ -- ^ Like the swizzle environment, but as a full-blown substitution.+ -> TyVarBndr_ flag+ -> (Map Name Type, TyVarBndr_ flag)+swizzleTvb swizzle_env subst tvb =+ (subst', tvb2)+ where+ subst' = Map.insert tvb_name (VarT (tvName tvb2)) subst+ tvb_name = tvName tvb+ tvb1 = mapTVKind (applySubstitution subst) tvb+ tvb2 =+ case Map.lookup tvb_name swizzle_env of+ Just user_name -> mapTVName (const user_name) tvb1+ Nothing -> tvb1++-- The visibility of a binder in a type-level declaration. This generalizes+-- 'Specificity' (which lacks an equivalent to 'Required') and 'BndrVis' (which+-- lacks an equivalent to @'Invisible' 'Inferred'@).+--+-- This is heavily inspired by a data type of the same name in GHC:+-- https://gitlab.haskell.org/ghc/ghc/-/blob/98597ad5fca81544d74f721fb508295fd2650232/compiler/GHC/Types/Var.hs#L458-465+data ForAllTyFlag+ = Invisible !Specificity+ -- ^ If the 'Specificity' value is 'SpecifiedSpec', then the binder is+ -- permitted by request (e.g., @\@a@). If the 'Specificity' value is+ -- 'InferredSpec', then the binder is prohibited from appearing in source+ -- Haskell (e.g., @\@{a}@).+ | Required+ -- ^ The binder is required to appear in source Haskell (e.g., @a@).+ deriving (Show, Eq, Ord, Data, Generic, Lift)++instance DefaultBndrFlag ForAllTyFlag where+ defaultBndrFlag = Required++#if __GLASGOW_HASKELL__ >= 900+instance PprFlag ForAllTyFlag where+ pprTyVarBndr (PlainTV nm vis) =+ pprForAllTyFlag vis (ppr nm)+ pprTyVarBndr (KindedTV nm vis k) =+ pprForAllTyFlag vis (Ppr.parens (ppr nm Ppr.<+> Ppr.dcolon Ppr.<+> ppr k))++pprForAllTyFlag :: ForAllTyFlag -> Ppr.Doc -> Ppr.Doc+pprForAllTyFlag (Invisible SpecifiedSpec) d = Ppr.char '@' Ppr.<> d+pprForAllTyFlag (Invisible InferredSpec) d = Ppr.braces d+pprForAllTyFlag Required d = d+#endif++-- | Convert a list of @'TyVarBndr' 'ForAllTyFlag'@s to a list of+-- 'TyVarBndrSpec's, which is suitable for use in an invisible @forall@.+-- Specifically:+--+-- * Variable binders that use @'Invisible' spec@ are converted to @spec@.+--+-- * Variable binders that are 'Required' are converted to 'SpecifiedSpec',+-- as all of the 'TyVarBndrSpec's are invisible. As an example of how this+-- is used, consider what would happen when singling this data type:+--+-- @+-- type T :: forall k -> k -> Type+-- data T k (a :: k) where ...+-- @+--+-- Here, the @k@ binder is 'Required'. When we produce the standalone kind+-- signature for the singled data type, we use 'tvbForAllTyFlagsToSpecs' to+-- produce the type variable binders in the outermost @forall@:+--+-- @+-- type ST :: forall k (a :: k). T k a -> Type+-- data ST z where ...+-- @+--+-- Note that the @k@ is bound visibily (i.e., using 'SpecifiedSpec') in the+-- outermost, invisible @forall@.+tvbForAllTyFlagsToSpecs :: [TyVarBndr_ ForAllTyFlag] -> [TyVarBndrSpec]+tvbForAllTyFlagsToSpecs = map (mapTVFlag to_spec)+ where+ to_spec :: ForAllTyFlag -> Specificity+ to_spec (Invisible spec) = spec+ to_spec Required = SpecifiedSpec++-- | Convert a list of @'TyVarBndr' 'ForAllTyFlag'@s to a list of+-- 'TyVarBndrVis'es, which is suitable for use in a type-level declaration+-- (e.g., the @var_1 ... var_n@ in @class C var_1 ... var_n@). Specifically:+--+-- * Variable binders that use @'Invisible' 'InferredSpec'@ are dropped+-- entirely. Such binders cannot be represented in source Haskell.+--+-- * Variable binders that use @'Invisible' 'SpecifiedSpec'@ are converted to+-- 'BndrInvis'.+--+-- * Variable binders that are 'Required' are converted to 'BndrReq'.+tvbForAllTyFlagsToBndrVis :: [TyVarBndr_ ForAllTyFlag] -> [TyVarBndrVis]+tvbForAllTyFlagsToBndrVis = catMaybes . map (traverseTVFlag to_spec_maybe)+ where+ to_spec_maybe :: ForAllTyFlag -> Maybe BndrVis+ to_spec_maybe (Invisible InferredSpec) = Nothing+ to_spec_maybe (Invisible SpecifiedSpec) = Just bndrInvis+ to_spec_maybe Required = Just BndrReq+ ---------------------------------------- -- Free names, etc. ----------------------------------------@@ -373,7 +1055,10 @@ allNamesIn :: Data a => a -> [Name] allNamesIn = everything (++) $ mkQ [] (:[]) --- | Extract the names bound in a @Stmt@+-- | Extract the names bound in a @Stmt@.+--+-- This does /not/ extract any type variables bound by pattern signatures,+-- constructor patterns, or type patterns. extractBoundNamesStmt :: Stmt -> OSet Name extractBoundNamesStmt (BindS pat _) = extractBoundNamesPat pat extractBoundNamesStmt (LetS decs) = foldMap extractBoundNamesDec decs@@ -384,12 +1069,18 @@ #endif -- | Extract the names bound in a @Dec@ that could appear in a @let@ expression.+--+-- This does /not/ extract any type variables bound by pattern signatures,+-- constructor patterns, or type patterns. extractBoundNamesDec :: Dec -> OSet Name extractBoundNamesDec (FunD name _) = OS.singleton name extractBoundNamesDec (ValD pat _ _) = extractBoundNamesPat pat extractBoundNamesDec _ = OS.empty --- | Extract the names bound in a @Pat@+-- | Extract the names bound in a @Pat@.+--+-- This does /not/ extract any type variables bound by pattern signatures,+-- constructor patterns, or type patterns. extractBoundNamesPat :: Pat -> OSet Name extractBoundNamesPat (LitP _) = OS.empty extractBoundNamesPat (VarP name) = OS.singleton name@@ -418,6 +1109,13 @@ #if __GLASGOW_HASKELL__ >= 801 extractBoundNamesPat (UnboxedSumP pat _ _) = extractBoundNamesPat pat #endif+#if __GLASGOW_HASKELL__ >= 909+extractBoundNamesPat (TypeP _) = OS.empty+extractBoundNamesPat (InvisP _) = OS.empty+#endif+#if __GLASGOW_HASKELL__ >= 911+extractBoundNamesPat (OrP pats) = foldMap extractBoundNamesPat pats+#endif ---------------------------------------- -- General utility@@ -492,6 +1190,9 @@ firstMatch :: (a -> Maybe b) -> [a] -> Maybe b firstMatch f xs = listToMaybe $ mapMaybe f xs +firstMatchM :: Monad m => (a -> m (Maybe b)) -> [a] -> m (Maybe b)+firstMatchM f xs = listToMaybe <$> mapMaybeM f xs+ -- | Semi-shallow version of 'everywhereM' - does not recurse into children of nodes of type @a@ (only applies the handler to them). -- -- >>> topEverywhereM (pure . fmap (*10) :: [Integer] -> Identity [Integer]) ([1,2,3] :: [Integer], "foo" :: String)@@ -532,3 +1233,11 @@ uniStarKindName :: Name uniStarKindName = ''(Kind.★) #endif++-- | Is a data type or data instance declaration a @newtype@ declaration, a+-- @data@ declaration, or a @type data@ declaration?+data DataFlavor+ = Newtype -- ^ @newtype@+ | Data -- ^ @data@+ | TypeData -- ^ @type data@+ deriving (Eq, Show, Data, Generic, Lift)
README.md view
@@ -31,6 +31,46 @@ Known limitations ----------------- +## Desugaring depends on language extensions of use sites++Suppose you quote some Template Haskell declarations in module `A`:++```hs+{-# LANGUAGE ... #-}+module A where++decs :: Q [Dec]+decs = [d| ... |]+```++And later desugar the declarations with `th-desugar` in module `B`:++```hs+{-# LANGUAGE ... #-}+module B where++import A (decs)+import Language.Haskell.TH.Desugar (dsDecs)++$(do desugaredDecs <- dsDecs decs+ ...)+```++There are some situations where `th-desugar`'s desugaring depends on which+language extensions are enabled, such as:++* `MonadFailDesugaring` (for desugaring partial pattern matches in `do`+ notation)+* `NoFieldSelectors` (for determining if a record field can be reified as a+ field selector with `lookupValueNameWithLocals`)++Somewhat counterintuitively, `th-desugar` will consult the language extensions+in module `B` (the site where the `decs` are used) for this process, not module+`A` (where the `decs` were defined). This is really a Template Haskell+limitation, since Template Haskell does not offer any way to reify which+language extensions were enabled at the time the declarations were defined. As a+result, `th-desugar` can only check for language extensions at use sites.+ ## Limited support for kind inference `th-desugar` sometimes has to construct types for certain Haskell entities.@@ -104,3 +144,268 @@ way that linear types interact with Template Haskell, which sometimes make it impossible to tell whether a reified function type is linear or not. See, for instance, [GHC#18378](https://gitlab.haskell.org/ghc/ghc/-/issues/18378).++## Limitations of support for desugaring guards++`th-desugar` supports guards in the sense that it will desugar guards to+equivalent code that instead uses `case` expressions. For example, this code:++```hs+f (x, y)+ | x == "hello" = x+ | otherwise = y+```++Will be desugared to this code:++```hs+f arg =+ case arg of+ (x, y) ->+ case x2 == "hello" of+ True -> x+ False -> y+```++This has the advantage that it saves users from needing to care about the+complexities of guards. It does have some drawbacks, however, which we describe+below.++### Desugaring guards can result in quadratic code size++If you desugar this program involving guards:++```hs+data T = A Int | B Int | C Int++f :: T -> T -> Maybe Int+f (A x1) (A x2)+ | x1 == x2+ = Just x1+f (B x1) (B x2)+ | x1 == x2+ = Just x1+f (C x1) (C x2)+ | x1 == x2+ = Just x1+f _ _ = Nothing+```++You will end up with:++```hs+f :: T -> T -> Maybe Int+f arg1 arg2 =+ case (# arg1, arg2 #) of+ (# A x1, A x2 #) ->+ case x1 == x2 of+ True ->+ Just x1+ False ->+ case (# arg1, arg2 #) of+ (# B y1, B y2 #) ->+ case y1 == y2 of+ True ->+ Just y1+ False ->+ case (# arg1, arg2 #) of+ (# C z1, C z2 #) ->+ case z1 == z2 of+ True ->+ Just z1+ False ->+ case (# arg1, arg2 #) of+ (# _, _ #) ->+ Nothing+ (# _, _ #) ->+ Nothing+ (# C y1, C y2 #) ->+ case y1 == y2 of+ True ->+ Just y1+ False ->+ case (# arg1, arg2 #) of+ (# _, _ #) ->+ Nothing+ (# _, _ #) ->+ Nothing+ (# B x1, B x2 #) ->+ case x1 == x2 of+ True ->+ Just x1+ False ->+ case (# arg1, arg2 #) of+ (# C y1, C y2 #) ->+ case y1 == y2 of+ True ->+ Just y1+ False ->+ case (# arg1, arg2 #) of+ (# _, _ #) ->+ Nothing+ (# _, _ #) ->+ Nothing+ (# C x1, C x2 #) ->+ case x1 == x2 of+ True ->+ Just x1+ False ->+ case (# arg1, arg2 #) of+ (# _, _ #) ->+ Nothing+ (# _, _ #) ->+ Nothing+```++That is signficantly more code. In the worst case, the algorithm that+`th-desugar` uses for desugaring guards can lead to a quadratic increase in+code size. One way to avoid this is avoid having incomplete guards that fall+through to later clauses. That is, if you rewrite the original code to this:++```hs+f :: T -> T -> Maybe Int+f (A x1) (A x2)+ | x1 == x2+ = Just x1+ | otherwise+ = Nothing+f (B x1) (B x2)+ | x1 == x2+ = Just x1+ | otherwise+ = Nothing+f (C x1) (C x2)+ | x1 == x2+ = Just x1+ | otherwise+ = Nothing+```++Then `th-desugar` will desugar it to:++```hs+f :: T -> T -> Maybe Int+f arg1 arg2 =+ case (# arg1, arg2 #) of+ (# A x1, A x2 #) ->+ case x1 == x2 of+ True ->+ Just x1+ False ->+ Nothing+ (# B x1, B x2 #) ->+ case x1 == x2 of+ True ->+ Just x1+ False ->+ Nothing+ (# C x1, C x2 #) ->+ case x1 == x2 of+ True ->+ Just x1+ False ->+ Nothing+```++This code, while still more verbose than the original, uses a constant amount+of extra code per clause.++### Desugaring guards can produce more warnings than the original code++The approach that `th-desugar` uses to desugar guards can result in code that+produces GHC compiler warnings (if `-fenable-th-splice-warnings` is enabled)+where the original code does not. For example, consider the example from above:++```hs+data T = A Int | B Int | C Int++f :: T -> T -> Maybe Int+f (A x1) (A x2)+ | x1 == x2+ = Just x1+f (B x1) (B x2)+ | x1 == x2+ = Just x1+f (C x1) (C x2)+ | x1 == x2+ = Just x1+f _ _ = Nothing+```++This code compiles without any GHC warnings. If you desugar this code using+`th-desugar`, however, it will produce these warnings:++```+warning: [-Woverlapping-patterns]+ Pattern match is redundant+ In a case alternative: (# B y1, B y2 #) -> ...+ |+ | (# B y1, B y2 #) ->+ | ^^^^^^^^^^^^^^^^^^^...++warning: [-Woverlapping-patterns]+ Pattern match is redundant+ In a case alternative: (# C y1, C y2 #) -> ...+ |+ | (# C y1, C y2 #) ->+ | ^^^^^^^^^^^^^^^^^^^...++warning: [-Woverlapping-patterns]+ Pattern match is redundant+ In a case alternative: (# C y1, C y2 #) -> ...+ |+ | (# C y1, C y2 #) ->+ | ^^^^^^^^^^^^^^^^^^^...+```++GHC is correct here: these matches are wholly redundant. `th-desugar` could+potentially recognize this and perform a more sophisticated analysis to detect+and remove such matches when desugaring guards, but it currently doesn't do+such an analysis.++## No support for view patterns++`th-desugar` does not support desugaring view patterns. An alternative to using+view patterns in the patterns of a function is to use pattern guards.+Currently, there is not a viable workaround for using view patterns in pattern+synonym definitions—see [this `th-desugar`+issue](https://github.com/goldfirere/th-desugar/issues/174).++## No support for or-patterns++`th-desugar` does not support desugaring+[or-patterns](https://github.com/ghc-proposals/ghc-proposals/blob/c9401f037cb22d1661931b2ec621925101052997/proposals/0522-or-patterns.rst).+See [this `th-desugar`+issue](https://github.com/goldfirere/th-desugar/issues/232).++## No support for `ApplicativeDo`++`th-desugar` does not take the `ApplicativeDo` extension into account when+desugaring `do` notation. For example, if you desugar this:++```hs+{-# LANGUAGE ApplicativeDo #-}++f x y = do+ x' <- x+ y' <- y+ return (x' ++ y')+```++Then `th-desugar` will translate the uses of `<-` in the `do` block to uses of+`Monad` operations (e.g., `(>>=)`) rather than `Applicative` operations (e.g.,+`(<*>)`). See [this `th-desugar`+issue](https://github.com/goldfirere/th-desugar/issues/138).++## No support for `RecursiveDo`++`th-desugar` does not support the `RecursiveDo` extension at all, so it cannot+desugar any uses of `mdo` expressions or `rec` statements.++## No support for unresolved infix operators++`th-desugar` does not support desugaring unresolved infix operators, such as+`UInfixE`. You are unlikely to encounter this limitation when dealing with+Template Haskell quotes, since quoted infix operators will translate to uses of+`InfixE` rather than `UInfixE`. Rather, this limitation would only be+encountered if you manually construct a Template Haskell `Exp` using `UInfixE`.
Test/Dec.hs view
@@ -9,6 +9,12 @@ FlexibleInstances, DataKinds, CPP, RankNTypes, StandaloneDeriving, DefaultSignatures, ConstraintKinds, RoleAnnotations, DeriveAnyClass #-}+#if __GLASGOW_HASKELL__ >= 810+{-# LANGUAGE StandaloneKindSignatures #-}+#endif+#if __GLASGOW_HASKELL__ >= 907+{-# LANGUAGE TypeAbstractions #-}+#endif {-# OPTIONS_GHC -Wno-orphans -Wno-name-shadowing -Wno-redundant-constraints #-}@@ -42,6 +48,15 @@ #if __GLASGOW_HASKELL__ >= 809 $(S.dectest18)+#endif++#if __GLASGOW_HASKELL__ >= 907+$(S.dectest19)+#endif++#if __GLASGOW_HASKELL__ >= 909+$(S.dectest20)+$(S.dectest21) #endif $(fmap unqualify S.instance_test)
Test/DsDec.hs view
@@ -8,10 +8,17 @@ MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, DataKinds, CPP, RankNTypes, StandaloneDeriving, DefaultSignatures,- ConstraintKinds, RoleAnnotations, DeriveAnyClass #-}+ ConstraintKinds, RoleAnnotations, DeriveAnyClass,+ TypeApplications #-} #if __GLASGOW_HASKELL__ >= 801 {-# LANGUAGE DerivingStrategies #-} #endif+#if __GLASGOW_HASKELL__ >= 810+{-# LANGUAGE StandaloneKindSignatures #-}+#endif+#if __GLASGOW_HASKELL__ >= 907+{-# LANGUAGE TypeAbstractions #-}+#endif {-# OPTIONS_GHC -Wno-orphans -Wno-incomplete-patterns -Wno-name-shadowing -Wno-redundant-constraints #-}@@ -21,6 +28,7 @@ import qualified Splices as S import Splices ( dsDecSplice, unqualify ) +import qualified Language.Haskell.TH.Datatype.TyVarBndr as THAbs import Language.Haskell.TH.Desugar import Language.Haskell.TH.Syntax ( qReport ) @@ -67,9 +75,18 @@ $(dsDecSplice S.dectest18) #endif +#if __GLASGOW_HASKELL__ >= 907+$(dsDecSplice S.dectest19)+#endif++#if __GLASGOW_HASKELL__ >= 909+$(dsDecSplice S.dectest20)+$(dsDecSplice S.dectest21)+#endif+ $(do decs <- S.rec_sel_test withLocalDeclarations decs $ do- [DDataD nd [] name [DPlainTV tvbName ()] k cons []] <- dsDecs decs+ [DDataD nd [] name [DPlainTV tvbName THAbs.BndrReq] k cons []] <- dsDecs decs recsels <- getRecordSelectors cons let num_sels = length recsels `div` 2 -- ignore type sigs when (num_sels /= S.rec_sel_test_num_sels) $@@ -82,5 +99,5 @@ fields' = zip stricts types in DCon tvbs cxt con_name (DNormalC False fields') rty- plaindata = [DDataD nd [] name [DPlainTV tvbName ()] k (map unrecord cons) []]+ plaindata = [DDataD nd [] name [DPlainTV tvbName THAbs.BndrReq] k (map unrecord cons) []] return (decsToTH plaindata ++ map letDecToTH recsels))
+ Test/FakeSums.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE MagicHash #-}++-- | Defines data types with names identical to those found in "GHC.Types".+-- This is used as part of a series of unit tests for the+-- @unboxedSumNameDegree_maybe@ function, which should only return 'Just' when the+-- argument 'Name' is actually an unboxed sum from "GHC.Types", not a user-defined+-- type.+module FakeSums+ ( Sum2#, Sum3#, Sum4#+ ) where++data Sum2# a b+data Sum3# a b c+data Sum4# a b c
+ Test/FakeTuples.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE MagicHash #-}++-- | Defines data types with names identical to those found in "GHC.Tuple".+-- This is used as part of a series of unit tests for the+-- @tupleNameDegree_maybe@ and @unboxedTupleNameDegree_maybe@ functions, which+-- should only return 'Just' when the argument 'Name' is actually a tuple from+-- "GHC.Tuple", not a user-defined type.+module FakeTuples+ ( Tuple0, Tuple1, Tuple2, Tuple3+ , Tuple0#, Tuple1#, Tuple2#, Tuple3#+ ) where++data Tuple0+data Tuple1 a+data Tuple2 a b+data Tuple3 a b c++data Tuple0#+data Tuple1# a+data Tuple2# a b+data Tuple3# a b c
Test/ReifyTypeCUSKs.hs view
@@ -1,9 +1,12 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-}+#if __GLASGOW_HASKELL__ < 806 {-# LANGUAGE TypeInType #-}+#endif #if __GLASGOW_HASKELL__ >= 809 {-# LANGUAGE CUSKs #-} #endif
Test/Run.hs view
@@ -10,7 +10,7 @@ FlexibleInstances, ExistentialQuantification, ScopedTypeVariables, GADTs, ViewPatterns, TupleSections, TypeOperators, PartialTypeSignatures, PatternSynonyms,- TypeApplications #-}+ TypeApplications, MagicHash #-} {-# OPTIONS -Wno-incomplete-patterns -Wno-overlapping-patterns -Wno-unused-matches -Wno-type-defaults -Wno-missing-signatures -Wno-unused-do-bind@@ -22,10 +22,30 @@ {-# LANGUAGE QuantifiedConstraints #-} #endif +#if __GLASGOW_HASKELL__ < 806+{-# LANGUAGE TypeInType #-}+#endif+ #if __GLASGOW_HASKELL__ >= 809 {-# LANGUAGE StandaloneKindSignatures #-} #endif +#if __GLASGOW_HASKELL__ >= 906+{-# LANGUAGE TypeData #-}+#endif++#if __GLASGOW_HASKELL__ >= 907+{-# LANGUAGE TypeAbstractions #-}+#endif++#if __GLASGOW_HASKELL__ >= 909+{-# LANGUAGE RequiredTypeArguments #-}+#endif++#if __GLASGOW_HASKELL__ >= 911+{-# LANGUAGE ImpredicativeTypes #-}+#endif+ module Main where import Prelude hiding ( exp )@@ -41,11 +61,13 @@ import ReifyTypeCUSKs import ReifyTypeSigs import T159Decs ( t159A, t159B )+import T183 ( t183 )+import qualified Language.Haskell.TH.Datatype.TyVarBndr as THAbs import Language.Haskell.TH.Desugar import qualified Language.Haskell.TH.Desugar.OSet as OS import Language.Haskell.TH.Desugar.Expand ( expandUnsoundly ) import Language.Haskell.TH-import qualified Language.Haskell.TH.Syntax as Syn ( lift )+import qualified Language.Haskell.TH.Syntax as Syn import Control.Exception ( ErrorCall ) import Control.Monad@@ -54,9 +76,26 @@ import Data.Proxy #if __GLASGOW_HASKELL__ >= 900+import Data.Kind (Constraint) import Prelude as P #endif +#if __GLASGOW_HASKELL__ >= 906+import GHC.Tuple ( Solo(MkSolo) )+#elif __GLASGOW_HASKELL__ >= 900+import GHC.Tuple ( Solo(Solo) )+#endif++#if __GLASGOW_HASKELL__ >= 908+import qualified FakeTuples+import GHC.Tuple ( Tuple0, Tuple1, Tuple2, Tuple3, Unit )+#endif++#if __GLASGOW_HASKELL__ >= 910+import qualified FakeSums+import GHC.Types (Solo#, Sum2#, Sum3#, Sum4#, Tuple0#, Tuple1#, Tuple2#, Tuple3#, Unit#)+#endif+ -- | -- Convert a HUnit test suite to a spec. This can be used to run existing -- HUnit tests with Hspec.@@ -151,6 +190,31 @@ , "opaque_pragma" ~: $test55_opaque_pragma @=? $(dsSplice test55_opaque_pragma) , "lambda_cases" ~: $test56_lambda_cases @=? $(dsSplice test56_lambda_cases) #endif+#if __GLASGOW_HASKELL__ >= 907+ , "typed_th_bracket" ~: $$($test57_typed_th_bracket) @=? $$($(dsSplice test57_typed_th_bracket))+ , "typed_th_splice" ~: $test58_typed_th_splice @=? $(dsSplice test58_typed_th_splice)+#endif+#if __GLASGOW_HASKELL__ >= 909+ , "embedded_types_keyword" ~: $test59_embedded_types_keyword @=? $(dsSplice test59_embedded_types_keyword)+ , "embedded_types_no_keyword" ~: $test60_embedded_types_no_keyword @=? $(dsSplice test60_embedded_types_no_keyword)+ , "invis_type_pat" ~: $test61_invis_type_pat @=? $(dsSplice test61_invis_type_pat)+ , "embedded_types_lambda_keyword" ~: $test62_embedded_types_lambda_keyword @=? $(dsSplice test62_embedded_types_lambda_keyword)+ , "embedded_types_case_keyword" ~: $test63_embedded_types_case_keyword @=? $(dsSplice test63_embedded_types_case_keyword)+ , "embedded_types_cases_keyword" ~: $test64_embedded_types_cases_keyword @=? $(dsSplice test64_embedded_types_cases_keyword)+ , "embedded_types_lambda_no_keyword" ~: $test65_embedded_types_lambda_no_keyword @=? $(dsSplice test65_embedded_types_lambda_no_keyword)+ , "embedded_types_case_no_keyword" ~: $test66_embedded_types_case_no_keyword @=? $(dsSplice test66_embedded_types_case_no_keyword)+ , "embedded_types_cases_no_keyword" ~: $test67_embedded_types_cases_no_keyword @=? $(dsSplice test67_embedded_types_cases_no_keyword)+ , "invis_type_pat_lambda" ~: $test68_invis_type_pat_lambda @=? $(dsSplice test68_invis_type_pat_lambda)+ , "invis_type_pat_cases" ~: $test69_invis_type_pat_cases @=? $(dsSplice test69_invis_type_pat_cases)+#endif+#if __GLASGOW_HASKELL__ >= 911+ , "embedded_forall_invis" ~: $(test70_embedded_forall_invis) @=? $(dsSplice test70_embedded_forall_invis)+ , "embedded_forall_vis" ~: $(test71_embedded_forall_vis) @=? $(dsSplice test71_embedded_forall_vis)+ , "embedded_constraint" ~: $(test72_embedded_constraint) @=? $(dsSplice test72_embedded_constraint)+#endif+#if __GLASGOW_HASKELL__ >= 913+ , "specialise_exp_pragma" ~: $(test73_specialise_exp_pragma) @=? $(dsSplice test73_specialise_exp_pragma)+#endif ] test35a = $test35_expand@@ -272,7 +336,7 @@ (decsToTH [ -- type family F (x :: k) :: k DOpenTypeFamilyD (DTypeFamilyHead fam_name- [DKindedTV x () (DVarT k)]+ [DKindedTV x THAbs.BndrReq (DVarT k)] (DKindSig (DVarT k)) Nothing) -- type instance F (x :: ()) = x@@ -325,10 +389,11 @@ 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)+ (_, tvbs, _) <-+ withLocalDeclarations+ [decToTH (DDataD Data [] data_name [DPlainTV a THAbs.BndrReq]+ (Just data_kind_sig) [] [])]+ (getDataD "th-desugar: Impossible" data_name) [| $(Syn.lift (length tvbs)) |]) test_t100 :: Bool@@ -405,8 +470,8 @@ -- m :: a -- -- We define this by hand to avoid GHC#17608 on pre-9.0 GHCs.- decs = sweeten [ DClassD [] c [DPlainTV a ()] []- [ DLetDec (DInfixD fixity m)+ decs = sweeten [ DClassD [] c [DPlainTV a THAbs.BndrReq] []+ [ DLetDec (DInfixD fixity NoNamespaceSpecifier m) , DLetDec (DSigD m (DVarT a)) ] ]@@ -414,6 +479,98 @@ actual <- withLocalDeclarations decs (reifyFixityWithLocals m) expected `eqTHSplice` actual) +#if __GLASGOW_HASKELL__ >= 801+-- Test local reification of pattern synonym record selectors.+test_t137 :: [Bool]+test_t137 =+ $(do a <- newName "a"+ b <- newName "b"+ let aVarT = DVarT a+ aVarP = DVarP a+ bVarT = DVarT b+ bVarP = DVarP b+ aTvb = DPlainTV a SpecifiedSpec+ bTvb = DPlainTV b SpecifiedSpec++ p1 = mkName "P1"+ unP1a = mkName "unP1a"+ unP1b = mkName "unP1b"+ p2 = mkName "P2"+ unP2a = mkName "unP2a"+ unP2b = mkName "unP2b"+ p3 = mkName "P3"+ unP3a = mkName "unP3a"+ unP3b = mkName "unP3b"++ tupleTy = DConT (tupleTypeName 2) `DAppT` aVarT `DAppT` bVarT+ showCxt = [DConT ''Show `DAppT` aVarT]+ patSynSigDBodyTy =+ DArrowT `DAppT` aVarT `DAppT` (DArrowT `DAppT` bVarT `DAppT` tupleTy)++ -- pattern P{unPa, unPb} = (unPa, unPb)+ mkPatSynD :: Name -> Name -> Name -> DDec+ mkPatSynD p unPa unPb =+ DPatSynD+ p+ (RecordPatSyn [unPa, unPb])+ DImplBidir+ (DConP (tupleDataName 2) [] [aVarP, bVarP])++ decs :: [Dec]+ decs = sweeten+ [ -- pattern P1 :: a -> b -> (a, b)+ DPatSynSigD p1 patSynSigDBodyTy+ , mkPatSynD p1 unP1a unP1b++ -- pattern P2 :: Show a => a -> b -> (a, b)+ , DPatSynSigD p2 $ DConstrainedT showCxt patSynSigDBodyTy+ , mkPatSynD p2 unP2a unP2b++ -- pattern P3 :: forall b a. Show a => a -> b -> (a, b)+ , DPatSynSigD p3 $+ DForallT (DForallInvis [bTvb, aTvb]) $+ DConstrainedT showCxt patSynSigDBodyTy+ , mkPatSynD p3 unP3a unP3b+ ]++ -- Pair each pattern synonym record selector name with the type that+ -- local reification should produce.+ expecteds :: [(Name, DType)]+ expecteds =+ [ (unP1a, DForallT (DForallInvis [aTvb, bTvb]) $+ DArrowT `DAppT` tupleTy `DAppT` aVarT)+ , (unP1b, DForallT (DForallInvis [aTvb, bTvb]) $+ DArrowT `DAppT` tupleTy `DAppT` bVarT)++ -- The reified types below use (DForallInvis []) due to the way+ -- that ForallT is desugared.+ -- See Note [Desugaring and sweetening ForallT] in+ -- Language.Haskell.TH.Desugar.Core.+ , (unP2a, DForallT (DForallInvis []) $+ DConstrainedT showCxt $+ DArrowT `DAppT` tupleTy `DAppT` aVarT)+ , (unP2b, DForallT (DForallInvis []) $+ DConstrainedT showCxt $+ DArrowT `DAppT` tupleTy `DAppT` bVarT)++ , (unP3a, DForallT (DForallInvis [bTvb, aTvb]) $+ DConstrainedT showCxt $+ DArrowT `DAppT` tupleTy `DAppT` aVarT)+ , (unP3b, DForallT (DForallInvis [bTvb, aTvb]) $+ DConstrainedT showCxt $+ DArrowT `DAppT` tupleTy `DAppT` bVarT)+ ]++ expected_eq_actual :: (Name, DType) -> DsM Q Bool+ expected_eq_actual (sel_name, expected_ty) = do+ let expected_info = Just $ DVarI sel_name expected_ty Nothing+ actual_info <- dsReify sel_name+ pure $ expected_info `eqTH` actual_info++ bs <- withLocalDeclarations decs $ mapM expected_eq_actual expecteds+ Syn.lift bs)+#endif+ test_t154 :: Bool test_t154 = $(do decs <- [d| data T where@@ -436,6 +593,251 @@ testOne t159A testOne t159B +#if __GLASGOW_HASKELL__ >= 906+test_t170 :: [Bool]+test_t170 =+ $(do decs <- [d| type data TyData = MkTyData |]++ let test_TypeData_NameSpace nameStr =+ withLocalDeclarations decs $ do+ Just name <- lookupTypeNameWithLocals nameStr+ mbNS <- reifyNameSpace name+ mbNS `eqTHSplice` Just Syn.TcClsName++ let b1 = test_TypeData_NameSpace "TyData"+ let b2 = test_TypeData_NameSpace "MkTyData"+ [| [$b1, $b2] |])+#endif++test_t171 :: Bool+test_t171 =+ $(do a <- newName "a"+ b <- newName "b"+ c <- newName "c"+ x <- newName "x"+ y <- newName "y"++ let aVarT = DVarT a+ bVarT = DVarT b+ cVarT = DVarT c+ aTvb = DPlainTV a SpecifiedSpec+ bTvb = DPlainTV b SpecifiedSpec+ cTvb = DPlainTV c SpecifiedSpec+ t = mkName "T"+ mkT = mkName "mkT"+ getT1 = mkName "getT1"+ getT2 = mkName "getT2"++ dec = -- data T x y where+ -- MkT :: forall b a c. { getT1 :: b, getT2 :: c } -> T a b+ DDataD+ Data+ []+ t+ [DPlainTV x THAbs.BndrReq, DPlainTV y THAbs.BndrReq]+ Nothing+ [ DCon+ [bTvb, aTvb, cTvb]+ []+ mkT+ (DRecC [ ( getT1+ , Bang NoSourceUnpackedness NoSourceStrictness+ , bVarT+ )+ , ( getT2+ , Bang NoSourceUnpackedness NoSourceStrictness+ , cVarT+ )+ ])+ res_ty+ ]+ []+ res_ty = DConT t `DAppT` aVarT `DAppT` bVarT+ expected_ty = DForallT (DForallInvis [bTvb, aTvb]) $+ DArrowT `DAppT` res_ty `DAppT` bVarT++ withLocalDeclarations (sweeten [dec]) $ do+ Just (DVarI _ actual_ty _) <- dsReify getT1+ expected_ty `eqTHSplice` actual_ty)++-- Unit tests for tupleNameDegree_maybe. These also act as a regression test for+-- #187.+test_t187 :: [Bool]+test_t187 =+ map (\(s, expected) -> tupleNameDegree_maybe s == expected)+ [ (''(), Just 0)+ , (''(,), Just 2)+ , (''(,,), Just 3)+ , (''Maybe, Nothing)+ , (tupleTypeName 0, Just 0)+ , (tupleTypeName 2, Just 2)+ , (tupleTypeName 3, Just 3)+#if __GLASGOW_HASKELL__ >= 900+ , (''Solo, Just 1)+#if __GLASGOW_HASKELL__ >= 906+ , ('MkSolo, Just 1)+#else+ , ('Solo, Just 1)+#endif+#endif+#if __GLASGOW_HASKELL__ >= 908+ , (''Unit, Just 0)+ , (''Tuple0, Just 0)+ , (''Tuple1, Just 1)+ , (''Tuple2, Just 2)+ , (''Tuple3, Just 3)+ , (''FakeTuples.Tuple0, Nothing)+ , (''FakeTuples.Tuple1, Nothing)+ , (''FakeTuples.Tuple2, Nothing)+ , (''FakeTuples.Tuple3, Nothing)+#endif+ ]++-- A regression test for #188, which ensures that it produces the correct answer+-- for an unusual telescope like:+--+-- ... forall (a1 :: a2). forall (a2 :: a1). ...+--+-- Here, a2 is free in the kind of a1 (the first `forall`), but then the second+-- `forall` binds another a2 that shadows what was already in scope. In this+-- example, `toposortKindVarsOfTvbs [(a1 :: a2), (a2 :: a1)]` should return+-- [a2].+test_t188 :: Bool+test_t188 =+ let a1 = mkName "a1"+ a2 = mkName "a2" in+ toposortKindVarsOfTvbs [DKindedTV a1 () (DVarT a2), DKindedTV a2 () (DVarT a1)]+ == [DPlainTV a2 ()]++#if __GLASGOW_HASKELL__ >= 900+-- A regression test for #199, which ensures that a locally reified data+-- constructor is given a type signature that takes into account the fact that+-- its parent data type's standalone kind signature marks `k` as inferred.+test_t199 :: [Bool]+test_t199 =+ $(do decs <- [d| type P :: forall {k}. k -> Type+ data P (a :: k) = MkP |]++ withLocalDeclarations decs $ do+ let k = mkName "k"+ a = mkName "a"+ kTvb = DPlainTV k InferredSpec+ aTvb = DKindedTV a SpecifiedSpec (DVarT k)+ p = mkName "P"+ mkP = mkName "MkP"+ pTy = DConT p `DAppT` DVarT a+ mbPInfo <- dsReify p+ let b1 =+ case mbPInfo of+ Just (DTyConI (DDataD _ _ _ _ _ [conActual] _) _) ->+ let conExpected =+ DCon [kTvb, aTvb] [] mkP (DNormalC False []) pTy in+ conExpected `eqTH` conActual+ _ ->+ False++ mbMkPInfo <- dsReify mkP+ let b2 =+ case mbMkPInfo of+ Just (DVarI _ conTyActual _) ->+ let conTyExpected =+ DForallT (DForallInvis [kTvb, aTvb]) pTy in+ conTyExpected `eqTH` conTyActual+ _ ->+ False++ [| [b1, b2] |])+#endif++-- Unit tests for unboxedTupleNameDegree_maybe and unboxedSumNameDegree_maybe.+-- These also act as a regression test for #213.+test_t213 :: [Bool]+test_t213 =+ map (\(s, expected) -> unboxedTupleNameDegree_maybe s == expected)+ [ (''(##), Just 0)+ , (''(#,#), Just 2)+ , (''(#,,#), Just 3)+ , (''Maybe, Nothing)+#if __GLASGOW_HASKELL__ >= 802+ , (unboxedTupleTypeName 0, Just 0)+#endif+ , (unboxedTupleTypeName 2, Just 2)+ , (unboxedTupleTypeName 3, Just 3)+#if __GLASGOW_HASKELL__ >= 910+ , (''Unit#, Just 0)+ , (''Tuple0#, Just 0)+ , (''Solo#, Just 1)+ , (''Tuple1#, Just 1)+ , (''Tuple2#, Just 2)+ , (''Tuple3#, Just 3)+ , (''FakeTuples.Tuple0#, Nothing)+ , (''FakeTuples.Tuple1#, Nothing)+ , (''FakeTuples.Tuple2#, Nothing)+ , (''FakeTuples.Tuple3#, Nothing)+#endif+ ]+#if __GLASGOW_HASKELL__ >= 802+ +++ map (\(s, expected) -> unboxedSumNameDegree_maybe s == expected)+ [ (unboxedSumTypeName 2, Just 2)+ , (unboxedSumTypeName 3, Just 3)+ , (unboxedSumTypeName 4, Just 4)+#if __GLASGOW_HASKELL__ >= 910+ , (''Sum2#, Just 2)+ , (''Sum3#, Just 3)+ , (''Sum4#, Just 4)+ , (''FakeSums.Sum2#, Nothing)+ , (''FakeSums.Sum3#, Nothing)+ , (''FakeSums.Sum4#, Nothing)+#endif+ ]+#endif++#if __GLASGOW_HASKELL__ >= 900+-- A regression test for #220, which ensures that a locally reified class method+-- is given a type signature that takes into account the fact that its parent+-- class's standalone kind signature marks `k` as inferred.+test_t220 :: Bool+test_t220 =+ $(do decs <- [d| type C :: forall {k}. k -> Constraint+ class C (a :: k) where+ m :: Proxy a |]++ withLocalDeclarations decs $ do+ let k = mkName "k"+ a = mkName "a"+ kTvb = DPlainTV k InferredSpec+ aTvb = DKindedTV a SpecifiedSpec (DVarT k)+ c = mkName "C"+ m = mkName "m"+ cTy = DConT c `DAppT` DVarT a+ mbMInfo <- dsReify m+ case mbMInfo of+ Just (DVarI _ mTyActual _) ->+ let mTyExpected =+ DForallT (DForallInvis [kTvb, aTvb]) $+ DConstrainedT [cTy] $+ DConT ''Proxy `DAppT` DVarT a in+ mTyExpected `eqTHSplice` mTyActual+ _ ->+ [| False |])+#endif++-- A regression test for #228, which ensures that dMatchUpSAKWithDecl behaves+-- as expected on code that looks like this:+--+-- @+-- type D :: forall (a :: Type). Type+-- data D+-- @+test_t228 :: Bool+test_t228 =+ let sak = DForallT (DForallInvis [DKindedTV (mkName "a") SpecifiedSpec (DConT ''Type)]) (DConT ''Type)+ expected_bndrs = [DKindedTV (mkName "a") (Invisible SpecifiedSpec) (DConT ''Type)] in+ case dMatchUpSAKWithDecl sak [] of+ Nothing -> False+ Just actual_bndrs -> expected_bndrs `eqTH` actual_bndrs+ -- Unit tests for functions that compute free variables (e.g., fvDType) test_fvs :: [Bool] test_fvs =@@ -576,9 +978,17 @@ , matchTy NoIgnore (DConT ''Int) (DConT ''Bool) == Nothing , matchTy NoIgnore (DConT ''Int) (DConT ''Int) == Just M.empty , matchTy NoIgnore (DConT ''Int) (DVarT a) == Nothing+ -- Test `DSigT` with both `IgnoreKinds` options , matchTy NoIgnore (DVarT a `DSigT` DConT ''Bool) (DConT ''Int) == Nothing , matchTy YesIgnore (DVarT a `DSigT` DConT ''Bool) (DConT ''Int) == Just (M.singleton a (DConT ''Int))+ -- Test `DAppKindT` with both `IgnoreKinds` options+ , matchTy NoIgnore (DConT ''Proxy `DAppKindT` DConT ''Bool `DAppT` DVarT a)+ (DConT ''Proxy `DAppT` DConT ''Int)+ == Nothing+ , matchTy YesIgnore (DConT ''Proxy `DAppKindT` DConT ''Bool `DAppT` DVarT a)+ (DConT ''Proxy `DAppT` DConT ''Int)+ == Just (M.singleton a (DConT ''Int)) ] where a = mkName "a"@@ -640,6 +1050,11 @@ it "reifies fixity declarations inside of classes" $ test_t132 +#if __GLASGOW_HASKELL__ >= 801+ zipWithM (\b n -> it ("reifies local pattern synonym record selectors " ++ show n) b)+ test_t137 [1..]+#endif+ zipWithM (\b n -> it ("computes free variables correctly " ++ show n) b) test_fvs [1..] @@ -647,6 +1062,35 @@ it "desugars non-exhaustive expressions into code that errors at runtime" $ test_t159 +#if __GLASGOW_HASKELL__ >= 906+ zipWithM (\b n -> it ("looks up TypeData names in the type namespace correctly " ++ show n) b)+ test_t170 [1..]+#endif++ it "locally reifies GADT record selector types with explicit foralls correctly" $ test_t171++ it "doesn't reify a field selector with lookupValueNameWithLocals when NoFieldSelectors is set" $+ t183 == Nothing++ zipWithM (\b n -> it ("recognizes tuple names with tupleDegree_maybe correctly " ++ show n) b)+ test_t187 [1..]++ it "computes free kind variables correctly in a telescope that uses shadowing" $ test_t188++#if __GLASGOW_HASKELL__ >= 900+ zipWithM (\b n -> it ("correctly reifies the type of a data constructor with an inferred type variable binder " ++ show n) b)+ test_t199 [1..]+#endif++ zipWithM (\b n -> it ("recognizes unboxed {tuple,sum} names with unboxed{Tuple,Sum}Degree_maybe correctly " ++ show n) b)+ test_t213 [1..]++#if __GLASGOW_HASKELL__ >= 900+ it "correctly reifies the type of a class method with an inferred type variable binder" $ test_t220+#endif++ it "correctly matches up an invisible forall without a corresponding @-binder" $ test_t228+ -- Remove map pprints here after switch to th-orphans zipWithM (\t t' -> it ("can do Type->DType->Type of " ++ t) $ t == t') $(sequence round_trip_types >>= Syn.lift . map pprint)@@ -654,8 +1098,8 @@ mapM (\ t -> withLocalDeclarations [] (dsType t >>= expandType >>= return . typeToTH)) >>= Syn.lift . map pprint) - zipWith3M (\a b n -> it ("reifies local definition " ++ show n) $ a == b)- local_reifications normal_reifications [1..]+ zipWith3M (\a b nm -> it ("reifies local definition " ++ nameBase nm) $ a == b)+ local_reifications normal_reifications reifyDecsNames zipWithM (\b n -> it ("works on simplCase test " ++ show n) b) simplCase [1..]
Test/Splices.hs view
@@ -29,6 +29,10 @@ {-# LANGUAGE QuantifiedConstraints #-} #endif +#if __GLASGOW_HASKELL__ < 806+{-# LANGUAGE TypeInType #-}+#endif+ #if __GLASGOW_HASKELL__ >= 807 {-# LANGUAGE ImplicitParams #-} #endif@@ -45,12 +49,26 @@ {-# LANGUAGE OverloadedRecordDot #-} #endif +#if __GLASGOW_HASKELL__ >= 906+{-# LANGUAGE TypeData #-}+#endif++#if __GLASGOW_HASKELL__ >= 907+{-# LANGUAGE TypeAbstractions #-}+#endif++#if __GLASGOW_HASKELL__ >= 909+{-# LANGUAGE RequiredTypeArguments #-}+#endif+ {-# OPTIONS_GHC -Wno-missing-signatures -Wno-type-defaults -Wno-name-shadowing #-} module Splices where import qualified Data.List as L+import qualified Data.List.NonEmpty as NE+import Data.List.NonEmpty (NonEmpty(..)) import Data.Char import qualified Data.Kind as Kind (Type) import GHC.Exts@@ -90,16 +108,33 @@ unqualify = everywhere (mkT (mkName . nameBase)) assumeStarT :: Data a => a -> a-assumeStarT = everywhere (mkT assume_spec . mkT assume_unit)+assumeStarT = everywhere (assume_spec_t . assume_vis_t . assume_unit_t) where- assume_spec :: TyVarBndrSpec -> TyVarBndrSpec+ assume_spec_t :: Typeable a => a -> a #if __GLASGOW_HASKELL__ >= 900+ assume_spec_t = mkT assume_spec++ assume_spec :: TyVarBndrSpec -> TyVarBndrSpec assume_spec (PlainTV n spec) = KindedTV n spec StarT assume_spec (KindedTV n spec k) = KindedTV n spec (assumeStarT k) #else- assume_spec = assume_unit+ assume_spec_t = id #endif + assume_vis_t :: Typeable a => a -> a+#if __GLASGOW_HASKELL__ >= 907+ assume_vis_t = mkT assume_vis++ assume_vis :: TyVarBndrVis -> TyVarBndrVis+ assume_vis (PlainTV n vis) = KindedTV n vis StarT+ assume_vis (KindedTV n vis k) = KindedTV n vis (assumeStarT k)+#else+ assume_vis_t = id+#endif++ assume_unit_t :: Typeable a => a -> a+ assume_unit_t = mkT assume_unit+ assume_unit :: TyVarBndrUnit -> TyVarBndrUnit assume_unit = elimTV (\n -> kindedTV n StarT) (\n k -> kindedTV n (assumeStarT k))@@ -107,10 +142,11 @@ dropTrailing0s :: Data a => a -> a dropTrailing0s = everywhere (mkT (mkName . frob . nameBase)) where- frob str- | head str == 'r' = str- | head str == 'R' = str- | otherwise = L.dropWhileEnd isDigit str+ frob str =+ case str of+ 'r':_ -> str+ 'R':_ -> str+ _ -> L.dropWhileEnd isDigit str -- Because th-desugar does not support linear types, we must pretend like -- MulArrowT does not exist for testing purposes.@@ -154,11 +190,11 @@ data Record = MkRecord1 { field1 :: Bool, field2 :: Int } | MkRecord2 { field2 :: Int, field3 :: Char } -test14_record = [| let r1 = [MkRecord1 { field2 = 5, field1 = False }, MkRecord2 { field2 = 6, field3 = 'q' }]- r2 = map (\r -> r { field2 = 18 }) r1- r3 = (head r2) { field1 = True } in- map (\case MkRecord1 { field2 = some_int, field1 = some_bool } -> show some_int ++ show some_bool- MkRecord2 { field2 = some_int, field3 = some_char } -> show some_int ++ show some_char) (r3 : r2) |]+test14_record = [| let r1 = MkRecord1 { field2 = 5, field1 = False } :| [MkRecord2 { field2 = 6, field3 = 'q' }]+ r2 = fmap (\r -> r { field2 = 18 }) r1+ r3 = (NE.head r2) { field1 = True } in+ fmap (\case MkRecord1 { field2 = some_int, field1 = some_bool } -> show some_int ++ show some_bool+ MkRecord2 { field2 = some_int, field3 = some_char } -> show some_int ++ show some_char) (NE.cons r3 r2) |] test15_litp = [| map (\case { 5 -> True ; _ -> False }) [5,6] |] test16_tupp = [| map (\(x,y,z) -> x + y + z) [(1,2,3),(4,5,6)] |]@@ -197,8 +233,8 @@ test28_tupt = [| let f :: (a,b) -> a f (a,_) = a in map f [(1,'a'),(2,'b')] |]-test29_listt = [| let f :: [[a]] -> a- f = head . head in+test29_listt = [| let f :: [[Int]] -> [[Int]]+ f = map (map (+1)) in map f [ [[1]], [[2]] ] |] test30_promoted = [| let f :: Proxy '() -> Proxy '[Int, Bool] -> () f _ _ = () in@@ -351,6 +387,108 @@ _ _ -> "") (Just "Hello") (Just "World") |] #endif +#if __GLASGOW_HASKELL__ >= 907+test57_typed_th_bracket =+ typedBracketE [| 'x' |]++test58_typed_th_splice =+ typedSpliceE (typedBracketE [| 'y' |])+#endif++#if __GLASGOW_HASKELL__ >= 909+test59_embedded_types_keyword =+ [| let idv :: forall a -> a -> a+ idv (type a) (x :: a) = x :: a++ in idv (type Bool) True |]++test60_embedded_types_no_keyword =+ [| let idv :: forall a -> a -> a+ idv a (x :: a) = x :: a++ in idv Bool True |]++test61_invis_type_pat =+ [| let f :: a -> a+ f @a = id @a++ in f @Bool True |]++test62_embedded_types_lambda_keyword =+ [| let idv :: forall a -> a -> a+ idv = \(type a) (x :: a) -> x :: a++ in idv (type Bool) True |]++test63_embedded_types_case_keyword =+ [| let idv :: forall a -> a -> a+ idv = \case+ (type a) -> id @a++ in idv (type Bool) True |]++test64_embedded_types_cases_keyword =+ [| let idv :: forall a -> a -> a+ idv = \cases+ (type a) (x :: a) -> x :: a++ in idv (type Bool) True |]++test65_embedded_types_lambda_no_keyword =+ [| let idv :: forall a -> a -> a+ idv = \a (x :: a) -> x :: a++ in idv Bool True |]++test66_embedded_types_case_no_keyword =+ [| let idv :: forall a -> a -> a+ idv = \case+ a -> id @a++ in idv Bool True |]++test67_embedded_types_cases_no_keyword =+ [| let idv :: forall a -> a -> a+ idv = \cases+ a (x :: a) -> x :: a++ in idv Bool True |]++aux :: (forall a. a -> a) -> (forall a. a -> a)+aux f x = f x++test68_invis_type_pat_lambda =+ [| aux (\ @a (x :: a) -> x :: a) @Bool True |]++test69_invis_type_pat_cases =+ [| aux (\cases @a (x :: a) -> x :: a) @Bool True |]+#endif++#if __GLASGOW_HASKELL__ >= 911+test70_embedded_forall_invis =+ [| let idv :: forall a -> a -> a+ idv _ x = x+ in idv (forall a. a -> a) id True |]++test71_embedded_forall_vis =+ [| let idv :: forall a -> a -> a+ idv _ x = x+ in idv (forall a -> a -> a) idv Bool True |]++test72_embedded_constraint =+ [| let idv :: forall a -> a -> a+ idv _ x = x+ in idv (forall a. (a ~ Bool) => a -> a) (\x -> not x) False |]+#endif++#if __GLASGOW_HASKELL__ >= 913+test73_specialise_exp_pragma =+ [| let {-# SPECIALISE f @() #-}+ f :: forall a. Show a => a -> String+ f = show+ in f () |]+#endif+ type family TFExpand x type instance TFExpand Int = Bool type instance TFExpand (Maybe a) = [a]@@ -500,6 +638,25 @@ MkDec18 :: forall k (a :: k). Dec18 k a |] #endif +#if __GLASGOW_HASKELL__ >= 907+dectest19 = [d| type Dec19 :: forall k. k -> Kind.Type+ data Dec19 @k (a :: k) = MkDec19 k (Proxy a) |]+#endif++#if __GLASGOW_HASKELL__ >= 909+dectest20 = [d| infixr 3 data !@#+ infixr 3 type !@#++ (!@#) :: Bool -> Bool -> Bool+ (!@#) = (&&)++ type family (!@#) :: Bool -> Bool -> Bool |]++dectest21 = [d| {-# SCC dec21 "dec21" #-}+ dec21 :: a -> a+ dec21 x = x |]+#endif+ instance_test = [d| instance (Show a, Show b) => Show (a -> b) where show _ = "function" |] @@ -662,6 +819,19 @@ data R33 a where R34 :: { r35 :: Int } -> R33 Int++#if __GLASGOW_HASKELL__ >= 906+ type data R36 a = R37 a+ type data R38 a where+ R39 :: forall a. a -> R38 a+#endif++ -- A regression test for #184+ data family x ^^^ y+ data instance x ^^^ y = R40 x y++ -- A regression test for #188+ data R41 a (x :: Maybe a) = R42 |] reifyDecsNames :: [Name]@@ -677,6 +847,11 @@ , "R32" #endif , "R33", "R34", "r35"+#if __GLASGOW_HASKELL__ >= 906+ , "R36", "R37", "R38", "R39"+#endif+ , "R40"+ , "R41", "R42" ] simplCaseTests :: [Q Exp]@@ -774,5 +949,30 @@ #if __GLASGOW_HASKELL__ >= 903 , test55_opaque_pragma , test56_lambda_cases+#endif+#if __GLASGOW_HASKELL__ >= 907+ , test57_typed_th_bracket+ , test58_typed_th_splice+#endif+#if __GLASGOW_HASKELL__ >= 909+ , test59_embedded_types_keyword+ , test60_embedded_types_no_keyword+ , test61_invis_type_pat+ , test62_embedded_types_lambda_keyword+ , test63_embedded_types_case_keyword+ , test64_embedded_types_cases_keyword+ , test65_embedded_types_lambda_no_keyword+ , test66_embedded_types_case_no_keyword+ , test67_embedded_types_cases_no_keyword+ , test68_invis_type_pat_lambda+ , test69_invis_type_pat_cases+#endif+#if __GLASGOW_HASKELL__ >= 911+ , test70_embedded_forall_invis+ , test71_embedded_forall_vis+ , test72_embedded_constraint+#endif+#if __GLASGOW_HASKELL__ >= 913+ , test73_specialise_exp_pragma #endif ]
Test/T158Exp.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -Wno-incomplete-patterns #-} -- | A regression test for #158 which ensures that lambda expressions -- containing patterns with unlifted types desugar as expected. We define this
+ Test/T183.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}++#if __GLASGOW_HASKELL__ >= 907+{-# LANGUAGE NoFieldSelectors #-}+#endif++-- | A regression test for #T183 which ensures that 'lookupValueNameWithLocals'+-- does not reify a field selector when the @NoFieldSelectors@ language+-- extension is set on GHC 9.8 or later. We define this test in its own module+-- to avoid having to enable @NoFieldSelectors@ in other parts of the test+-- suite.+module T183 (t183) where++import Language.Haskell.TH (Name)+#if __GLASGOW_HASKELL__ >= 907+import Language.Haskell.TH.Desugar+#endif++t183 :: Maybe Name+#if __GLASGOW_HASKELL__ >= 907+-- This should return 'Nothing', as the 'unT' record should not be made into a+-- top-level field selector due to @NoFieldSelectors@.+t183 =+ $(do decs <- [d| data T = MkT { unT :: Int } |]+ mbName <- withLocalDeclarations decs (lookupValueNameWithLocals "unT")+ [| mbName |])+#else+-- Lacking @NoFieldSelectors@ on older versions of GHC, we simply hard-code the+-- result to 'Nothing'.+t183 = Nothing+#endif
th-desugar.cabal view
@@ -1,5 +1,5 @@ name: th-desugar-version: 1.14+version: 1.19 cabal-version: >= 1.10 synopsis: Functions to desugar Template Haskell homepage: https://github.com/goldfirere/th-desugar@@ -19,7 +19,13 @@ , GHC == 8.8.4 , GHC == 8.10.7 , GHC == 9.0.2- , GHC == 9.2.2+ , GHC == 9.2.8+ , GHC == 9.4.8+ , GHC == 9.6.7+ , GHC == 9.8.4+ , GHC == 9.10.3+ , GHC == 9.12.2+ , GHC == 9.14.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.@@ -45,14 +51,14 @@ build-depends: base >= 4.9 && < 5, ghc-prim,- template-haskell >= 2.11 && < 2.20,+ template-haskell >= 2.11 && < 2.25, containers >= 0.5, mtl >= 2.1 && < 2.4, ordered-containers >= 0.2.2, syb >= 0.4,- th-abstraction >= 0.4 && < 0.5,- th-lift >= 0.6.1,- th-orphans >= 0.13.7,+ th-abstraction >= 0.6 && < 0.8,+ th-compat >= 0.1 && < 0.2,+ th-orphans >= 0.13.11, transformers-compat >= 0.6.3 default-extensions: TemplateHaskell exposed-modules: Language.Haskell.TH.Desugar@@ -62,6 +68,7 @@ Language.Haskell.TH.Desugar.OMap.Strict Language.Haskell.TH.Desugar.OSet Language.Haskell.TH.Desugar.Subst+ Language.Haskell.TH.Desugar.Subst.Capturing Language.Haskell.TH.Desugar.Sweeten other-modules: Language.Haskell.TH.Desugar.AST Language.Haskell.TH.Desugar.Core@@ -82,21 +89,22 @@ main-is: Run.hs other-modules: Dec DsDec+ FakeSums+ FakeTuples ReifyTypeCUSKs ReifyTypeSigs Splices T158Exp T159Decs+ T183 build-depends: base >= 4 && < 5,+ ghc-prim, template-haskell, containers >= 0.5,- mtl >= 2.1, syb >= 0.4, HUnit >= 1.2, hspec >= 1.3,- th-abstraction >= 0.4 && < 0.5,- th-desugar,- th-lift >= 0.6.1,- th-orphans >= 0.13.9+ th-abstraction,+ th-desugar