packages feed

th-desugar 1.6 → 1.19

raw patch · 29 files changed

Files

CHANGES.md view
@@ -1,6 +1,661 @@ `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.+* Drop support for GHC 7.8 and 7.10. As a consequence of this, the+  `strictToBang` function was removed as it no longer serves a useful purpose.+* Desugared lambda expressions and guards that bind multiple patterns can now+  have patterns with unlifted types. The desugared code uses `UnboxedTuples` to+  make this possible, so if you load the desugared code into GHCi on prior to+  GHC 9.2, you will need to enable `-fobject-code`.+* `th-desugar` now desugars `PromotedInfixT` and `PromotedUInfixT`, which were+  added in GHC 9.4. Mirroring the existing treatment of other `Promoted*`+  `Type`s, `PromotedInfixT` is desugared to an application of a `DConT` applied+  to two arguments, just like `InfixT` is desugared. Similarly, attempting to+  desugar a `PromotedUInfixT` results in an error, just like attempting to+  desugar a `UInfixT` would be.+* `th-desugar` now supports `DefaultD` (i.e., `default` declarations) and+  `OpaqueP` (i.e., `OPAQUE` pragmas), which were added in GHC 9.4.+* `th-desugar` now desugars `LamCasesE` (i.e., `\cases` expressions), which was+  added in GHC 9.4. A `\cases` expression is desugared to an ordinary lambda+  expression, much like `\case` is currently desugared.+* Fix an inconsistency which caused non-exhaustive `case` expressions to be+  desugared into uses of `EmptyCase`. Non-exhaustive `case` expressions are now+  desugared into code that throws a "`Non-exhaustive patterns in...`" error at+  runtime, just as all other forms of non-exhaustive expressions are desugared.+* Fix a bug in which `expandType` would not expand closed type families when+  applied to arguments containing type variables.++Version 1.13.1 [2022.05.20]+---------------------------+* Allow building with `mtl-2.3.*`.++Version 1.13 [2021.10.30]+-------------------------+* Support GHC 9.2.+* Add support for visible type application in data constructor patterns. As a+  result of these changes, the `DConP` constructor now has an extra field to+  represent type arguments:++  ```diff+   data DPat+     = ...+  -  | DConP Name         [DPat] -- fun (Just    x) = ...+  +  | DConP Name [DType] [DPat] -- fun (Just @t x) = ...+     | ...+  ```+* Add support for the `e.field` and `(.field)` syntax from the+  `OverloadedRecordDot` language extension.+* The `Maybe [DTyVarBndrUnit]` fields in `DInstanceD` and `DStandaloneDerivD`+  are no longer used when sweetening. Previously, `th-desugar` would attempt to+  sweeten these `DTyVarBndrUnit`s by turning them into a nested `ForallT`, but+  GHC 9.2 or later no longer allow this, as they forbid nested `forall`s in+  instance heads entirely. As a result, the `Maybe [DTyVarBndrUnit]` fields are+  now only useful for functions that consume `DDec`s directly.+* Fix a bug in which desugared GADT constructors would sometimes incorrectly+  claim that they were declared infix, despite this not being the case.++Version 1.12 [2021.03.12]+-------------------------+* Support GHC 9.0.+* Add support for explicit specificity. As part of this change,+  the way `th-desugar` represents type variable binders has been overhauled:+  * The `DTyVarBndr` data type is now parameterized by a `flag` type parameter:++    ```hs+    data DTyVarBndr flag+      = DPlainTV Name flag+      | DKindedTV Name flag DKind+    ```++    This can be instantiated to `Specificity` (for type variable binders that+    can be specified or inferred) or `()` (for type variable binders where+    specificity is irrelevant). `DTyVarBndrSpec` and `DTyVarBndrUnit` are also+    provided as type synonyms for `DTyVarBndr Specificity` and `DTyVarBndr ()`,+    respectively.+  * In order to interface with `TyVarBndr` (the TH counterpart to `DTyVarBndr`)+    in a backwards-compatible way, `th-desugar` now depends on the+    `th-abstraction` library.+  * The `ForallVisFlag` has been removed in favor of the new `DForallTelescope`+    data type, which not only distinguishes between invisible and visible+    `forall`s but also uses the correct type variable flag for invisible type+    variables (`Specificity`) and visible type variables (`()`).+  * The type of the `dsTvb` is now different on pre-9.0 versions of GHC:++    ```hs+    #if __GLASGOW_HASKELL__ >= 900+    dsTvb :: DsMonad q => TyVarBndr flag -> q (DTyVarBndr flag)+    #else+    dsTvb :: DsMonad q => flag -> TyVarBndr -> q (DTyVarBndr flag)+    #endif+    ```++    This is unfortunately required by the fact that prior to GHC 9.0, there is+    no `flag` information stored anywhere in a `TyVarBndr`. If you need to use+    `dsTvb` in a backward-compatible way, `L.H.TH.Desugar` now provides+    `dsTvbSpec` and `dsTvbUnit` functions which specialise `dsTvb` to+    particular `flag` types:++    ```hs+    dsTvbSpec :: DsMonad q => TyVarBndrSpec -> q DTyVarBndrSpec+    dsTvbUnit :: DsMonad q => TyVarBndrUnit -> q DTyVarBndrUnit+    ```+* The type of the `getRecordSelectors` function has changed:++  ```diff+  -getRecordSelectors :: DsMonad q => DType -> [DCon] -> q [DLetDec]+  +getRecordSelectors :: DsMonad q =>          [DCon] -> q [DLetDec]+  ```++  The old type signature had a `DType` argument whose sole purpose was to help+  determine which type variables were existential, as this information was used+  to filter out "naughty" record selectors, like the example below:++  ```hs+  data Some :: (Type -> Type) -> Type where+    MkSome :: { getSome :: f a } -> Some f+  ```++  The old implementation of `getRecordSelectors` would not include `getSome` in+  the returned list, as its type `f a` mentions an existential type variable,+  `a`, that is not mentioned in the return type `Some f`. The new+  implementation of `getRecordSelectors`, on the other hand, makes no attempt+  to filter out naughty record selectors, so it would include `getSome`.++  This reason for this change is ultimately because determining which type+  variables are existentially quantified in the context of Template+  Haskell is rather challenging in the general case. There are heuristics we+  could employ to guess which variables are existential, but we have found+  these heuristics difficult to predict (let alone specify). As a result, we+  take the slightly less correct (but much easier to explain) approach of+  returning all record selectors, regardless of whether they are naughty or not.+* The `conExistentialTvbs` function has been removed. It was horribly buggy,+  especially in the presence of GADT constructors. Moreover, this function was+  used in the implementation of `getRecordSelectors` function, so bugs in+  `conExistentialTvbs` often affected the results of `getRecordSelectors`.+* The types of `decToTH`, `letDecToTH`, and `pragmaToTH` have changed:++  ```diff+  -decToTH :: DDec -> [Dec]+  +decToTH :: DDec -> Dec++  -letDecToTH :: DLetDec -> Maybe Dec+  +letDecToTH :: DLetDec -> Dec++  -pragmaToTH :: DPragma -> Maybe Pragma+  +pragmaToTH :: DPragma -> Pragma+  ```++  The semantics of `pragmaToTH` have changed accordingly. Previously,+  `pragmaToTH` would return `Nothing` when the argument is a `DPragma` that is+  not supported on an old version of GHC, but now an error will be thrown+  instead. `decToTH` and `letDecToTH`, which transitively invoke `pragmaToTH`,+  have had their types updated to accommodate `pragmaToTH`'s type change.+* The type of the `substTyVarBndrs` function has been simplified to avoid the+  needless use of continuation-passing style:++  ```diff+  -substTyVarBndrs :: Quasi q => DSubst -> [DTyVarBndr flag] -> (DSubst -> [DTyVarBndr flag] -> q a) -> q a+  +substTyVarBndrs :: Quasi q => DSubst -> [DTyVarBndr flag] -> q (DSubst, [DTyVarBndr flag])+  ```+* `mkDLamEFromDPats` has now generates slightly more direct code for certain+  lambda expressions with `@`-patterns. For example, `\x@y -> f x y` would+  previously desugar to `\arg -> case arg of { y -> let x = y in f x y }`, but+  it now desugars to `\y -> let x = y in f x y`.+* `mkDLamEFromDPats` now requires only a `Quasi` context instead of `DsMonad`.++Version 1.11 [2020.03.25]+-------------------------+* Support GHC 8.10.+* Add support for visible dependent quantification. As part of this change,+  the way `th-desugar` represents `forall` and constraint types has been+  overhauled:+  * The existing `DForallT` constructor has been split into two smaller+    constructors:++    ```diff+     data DType+       = ...+    -  | DForallT [DTyVarBndr] DCxt DType+    +  | DForallT ForallVisFlag [DTyVarBndr] DType+    +  | DConstrainedT DCxt DType+       | ...++    +data ForallVisFlag+    +  = ForallVis+    +  | ForallInvis+    ```++    The previous design combined `forall`s and constraints into a single+    constructor, while the new design puts them in distinct constructors+    `DForallT` and `DConstrainedT`, respectively. The new `DForallT`+    constructor also has a `ForallVisFlag` field to distinguish invisible+    `forall`s (e.g., `forall a. a`) from visible `forall`s (e.g.,+    `forall a -> a`).+  * The `unravel` function has been renamed to `unravelDType` and now returns+    `(DFunArgs, DType)`, where `DFunArgs` is a data type that represents+    the possible arguments in a function type (see the Haddocks for `DFunArgs`+    for more details). There is also an `unravelDType` counterpart for `Type`s+    named `unravelType`, complete with its own `FunArgs` data type.++    `{D}FunArgs` also have some supporting operations, including+    `filter{D}VisFunArgs` (to obtain only the visible arguments) and+    `ravel{D}Type` (to construct a function type using `{D}FunArgs` and+    a return `{D}Type`).+* Support standalone kind signatures by adding a `DKiSigD` constructor to+  `DDec`.+* Add `dsReifyType`, `reifyTypeWithLocals_maybe`, and `reifyTypeWithLocals`,+  which allow looking up the types or kinds of locally declared entities.+* Fix a bug in which `reifyFixityWithLocals` would not look into local fixity+  declarations inside of type classes.+* Fix a bug in which `reifyFixityWithLocals` would return incorrect results+  for classes with associated type family defaults.++Version 1.10+------------+* Support GHC 8.8. Drop support for GHC 7.6.+* Add support for visible kind application, type variable `foralls` in `RULES`,+  and explicit `forall`s in type family instances. Correspondingly,+  * There is now a `DAppKindT` constructor in `DType`.+  * Previously, the `DDataInstD` constructor had fields of type `Name` and+    `[DType]`. Those have been scrapped in favor of a single field of type+    `DType`, representing the application of the data family name (which was+    previously the `Name`) to its arguments (which was previously the+    `[DType]`).++    `DDataInstD` also has a new field of type `Maybe [DTyVarBndr]` to represent+    its explicitly quantified type variables (if present).+  * Previously, the `DTySynEqn` constructor had a field of type `[DType]`.+    That has been scrapped in favor of a field of type `DType`, representing+    the application of the type family name (which `DTySynEqn` did not used to+    contain!) to its arguments (which was previously the `[DType]`).++    `DTySynEqn` also has a new field of type `Maybe [DTyVarBndr]` to represent+    its explicitly quantified type variables (if present).+  * `DTySynInstD` no longer has a field of type `Name`, as that is redundant+    now that each `DTySynEqn` contains the same `Name`.+  * There is now a field of type `Maybe [DTyVarBndr]` in the `DRuleP`+    constructor to represent bound type variables in `RULES` (if present).+* Add a field of type `Maybe [DTyVarBndr]` to `DInstanceD` and+  `DStandaloneDerivD` for optionally quantifying type variables explicitly.+  If supplied with a `Just`, this sweetens the instance type to use a `ForallT`+  to represent the explicit quantification. This trick is not supported for+  `InstanceD` on GHC 8.0 and for `StandaloneDerivD` on GHC 7.10 or 8.0, so be+  aware of this limitation if you supply `Just` for this field.+* Add support for desugaring implicit params. This does not involve any changes+  to the `th-desugar` AST, as:+  * `(?x :: a) => ...` is desugared to `IP "x" a => ...`.+  * `id ?x` is desugared to `id (ip @"x")`.+  * `let ?x = 42 in ...` is desugared to+    `let new_x_val = 42 in bindIP @"x" new_x_val ...` (where `bindIP` is a new+    utility function exported by `Language.Haskell.TH.Desugar` on GHC 8.0 or+    later).++  In order to support this desugaring, the type signatures of `dsLetDec` and+  `dsLetDecs` now return `([DLetDec], DExp -> DExp)` instead of just+  `[DLetDec]`, where `DExp -> DExp` is the expression which binds the values of+  implicit params (e.g., `\z -> bindIP @"x" new_x_val z`) if any are bound.+  (If none are bound, this is simply the `id` function.)+* Fix a bug in which `toposortTyVarsOf` would error at runtime if given types+  containing `forall`s as arguments.+* Fix a bug in which `fvDType` would return incorrect results if given a type+  containing quantified constraints.+* Fix a bug in which `expandType` would not expand type synonyms in the kinds+  of type variable binders in `forall`s.+* Fix a bug in which `getRecordSelectors` would omit record selectors from+  GADT constructors.+* Fix a bug in which `toposortTyVarsOf` would sometimes not preserve+  the left-to-right ordering of `Name`s generated with `qNewName`.+* Locally reified class methods, data constructors, and record selectors now+  quantify kind variables properly.+* Desugared ADT constructors now quantify kind variables properly.+* Remove `DPred`, as it has become too similar to `DType`. This also means+  that the `DPat` constructors, which previously ended with the suffix `Pa`,+  can now use the suffix `P`, mirroring TH.+* The type of `applyDType` has changed from `DType -> [DType] -> DType` to+  `DType -> [DTypeArg] -> DType`, where `DTypeArg` is a new data type that+  encodes whether an argument is a normal type argument (e.g., the `Int` in+  `Maybe Int`) or a visible kind argument (e.g., the `@Type` in+  `Proxy @Type Char`). A `TypeArg` data type (which is like `DTypeArg`, but+  with `Type`s/`Kind`s instead of `DType`s/`DKind`s) is also provided.++  A handful of utility functions for manipulating `TypeArg`s and `DTypeArg`s+  are also exported.+* `th-desugar` functions that compute free variables (e.g., `fvDType`) now+  return an `OSet`, a variant of `Set` that remembers the order in which+  elements were inserted. A consequence of this change is that it fixes a bug+  that causes free variables to be computed in different orders depending on+  which unique numbers GHC happened to generate internally.+* Substition and type synonym expansion are now more efficient by avoiding+  the use of `syb` in inner loops.++Version 1.9+-----------+* Suppose GHC 8.6.++* Add support for `DerivingVia`. Correspondingly, there is now a+  `DDerivStrategy` data type.++* Add support for `QuantifiedConstraints`. Correspondingly, there is now a+  `DForallPr` constructor in `DPred` to represent quantified constraint types.++* Remove the `DStarT` constructor of `DType` in favor of `DConT ''Type`.+  Two utility functions have been added to `Language.Haskell.TH.Desugar` to+  ease this transition:++  * `isTypeKindName`: returns `True` if the argument `Name` is that+    of `Type` or `★` (or `*`, to support older GHCs).+  * `typeKindName`: the name of `Type` (on GHC 8.0 or later) or `*` (on older+    GHCs).++* `th-desugar` now desugars all data types to GADT syntax. The most significant+  API-facing changes resulting from this new design are:++  * The `DDataD`, `DDataFamilyD`, and `DDataFamInstD` constructors of `DDec`+    now have `Maybe DKind` fields that either have `Just` an explicit return+    kind (e.g., the `k -> Type -> Type` in `data Foo :: k -> Type -> Type`)+    or `Nothing` (if lacking an explicit return kind).+  * The `DCon` constructor previously had a field of type `Maybe DType`, since+    there was a possibility it could be a GADT (with an explicit return type)+    or non-GADT (without an explicit return type) constructor. Since all data+    types are desugared to GADTs now, this field has been changed to be simply+    a `DType`.+  * The type signature of `dsCon` was previously:++    ```haskell+    dsCon :: DsMonad q => Con -> q [DCon]+    ```++    However, desugaring constructors now needs more information than before,+    since GADT constructors have richer type signatures. Accordingly, the type+    of `dsCon` is now:++    ```haskell+    dsCon :: DsMonad q+          => [DTyVarBndr] -- ^ The universally quantified type variables+                          --   (used if desugaring a non-GADT constructor)+          -> DType        -- ^ The original data declaration's type+                          --   (used if desugaring a non-GADT constructor).+          -> Con -> q [DCon]+    ```++    The `instance Desugar [Con] [DCon]` has also been removed, as the previous+    implementation of `desugar` (`concatMapM dsCon`) no longer has enough+    information to work.++  Some other utility functions have also been added as part of this change:++  * A `conExistentialTvbs` function has been introduced to determine the+    existentially quantified type variables of a `DCon`. Note that this+    function is not 100% accurate—refer to the documentation for+    `conExistentialTvbs` for more information.++  * A `mkExtraDKindBinders` function has been introduced to turn a data type's+    return kind into explicit, fresh type variable binders.++  * A `toposortTyVarsOf` function, which finds the free variables of a list of+    `DType`s and returns them in a well scoped list that has been sorted in+    reverse topological order.++* `th-desugar` now desugars partial pattern matches in `do`-notation and+  list/monad comprehensions to the appropriate invocation of `fail`.+  (Previously, these were incorrectly desugared into `case` expressions with+  incomplete patterns.)++* Add a `mkDLamEFromDPats` function for constructing a `DLamE` expression using+  a list of `DPat` arguments and a `DExp` body.++* Add an `unravel` function for decomposing a function type into its `forall`'d+  type variables, its context, its argument types, and its result type.++* Export a `substTyVarBndrs` function from `Language.Haskell.TH.Desugar.Subst`,+  which substitutes over type variable binders in a capture-avoiding fashion.++* `getDataD`, `dataConNameToDataName`, and `dataConNameToCon` from+  `Language.Haskell.TH.Desugar.Reify` now look up local declarations. As a+  result, the contexts in their type signatures have been strengthened from+  `Quasi` to `DsMonad`.++* Export a `dTyVarBndrToDType` function which converts a `DTyVarBndr` to a+  `DType`, which preserves its kind.++* Previously, `th-desugar` would silently accept illegal uses of record+  construction with fields that did not belong to the constructor, such as+  `Identity { notAField = "wat" }`. This is now an error.++Version 1.8+-----------+* Support GHC 8.4.++* `substTy` now properly substitutes into kind signatures.++* Expose `fvDType`, which computes the free variables of a `DType`.++* Incorporate a `DDeclaredInfix` field into `DNormalC` to indicate if it is+  a constructor that was declared infix.++* Implement `lookupValueNameWithLocals`, `lookupTypeNameWithLocals`,+  `mkDataNameWithLocals`, and `mkTypeNameWithLocals`, counterparts to+  `lookupValueName`, `lookupTypeName`, `mkDataName`, and `mkTypeName` which+  have access to local Template Haskell declarations.++* Implement `reifyNameSpace` to determine a `Name`'s `NameSpace`.++* Export `reifyFixityWithLocals` from `Language.Haskell.TH.Desugar`.++* Export `matchTy` (among other goodies) from new module `Language.Haskell.TH.Subst`.+  This function matches a type template against a target.++Version 1.7+-----------+* Support for TH's support for `TypeApplications`, thanks to @RyanGlScott.++* Support for unboxed sums, thanks to @RyanGlScott.++* Support for `COMPLETE` pragmas.++* `getRecordSelectors` now requires a list of `DCon`s as an argument. This+  makes it easier to return correct record selector bindings in the event that+  a record selector appears in multiple constructors. (See+  [goldfirere/singletons#180](https://github.com/goldfirere/singletons/issues/180)+  for an example of where the old behavior of `getRecordSelectors` went wrong.)++* Better type family expansion (expanding an open type family with variables works now).+ Version 1.6 ----------- * Work with GHC 8, with thanks to @christiaanb for getting this change going.
Language/Haskell/TH/Desugar.hs view
@@ -1,36 +1,49 @@ {- Language/Haskell/TH/Desugar.hs  (c) Richard Eisenberg 2013-eir@cis.upenn.edu+rae@cs.brynmawr.edu -}  {-# LANGUAGE CPP, MultiParamTypeClasses, FunctionalDependencies,-             TypeSynonymInstances, FlexibleInstances #-}+             TypeSynonymInstances, FlexibleInstances, LambdaCase,+             ScopedTypeVariables, PatternSynonyms #-}  ----------------------------------------------------------------------------- -- | -- Module      :  Language.Haskell.TH.Desugar -- Copyright   :  (C) 2014 Richard Eisenberg -- License     :  BSD-style (see LICENSE)--- Maintainer  :  Richard Eisenberg (eir@cis.upenn.edu)+-- Maintainer  :  Ryan Scott -- Stability   :  experimental -- Portability :  non-portable -- -- Desugars full Template Haskell syntax into a smaller core syntax for further--- processing. The desugared types and constructors are prefixed with a D.+-- processing. -- ----------------------------------------------------------------------------  module Language.Haskell.TH.Desugar (   -- * Desugared data types-  DExp(..), DLetDec(..), DPat(..), DType(..), DKind, DCxt, DPred(..),-  DTyVarBndr(..), DMatch(..), DClause(..), DDec(..),-  Overlap(..), NewOrData(..),+  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(..), DataFlavor(..),   DTypeFamilyHead(..), DFamilyResultSig(..), InjectivityAnn(..),-  DCon(..), DConFields(..), DBangType, DVarBangType,+  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@@ -39,16 +52,20 @@   -- * Main desugaring functions   dsExp, dsDecs, dsType, dsInfo,   dsPatOverExp, dsPatsOverExp, dsPatX,-  dsLetDecs, dsTvb, dsCxt,+  dsLetDecs, dsTvb, dsTvbSpec, dsTvbUnit, dsTvbVis, dsCxt,   dsCon, dsForeign, dsPragma, dsRuleBndr,    -- ** Secondary desugaring functions-  PatM, dsPred, dsPat, dsDec, dsLetDec,+  PatM, dsPred, dsPat, dsDec, dsDataDec, dsDataInstDec,+  DerivingClause, dsDerivClause, dsLetDec,+  MatchContext(..), LamCaseVariant(..),   dsMatches, dsBody, dsGuards, dsDoStmts, dsComp, dsClauses,   dsBangType, dsVarBangType,-#if __GLASGOW_HASKELL__ > 710   dsTypeFamilyHead, dsFamilyResultSig,+#if __GLASGOW_HASKELL__ >= 801+  dsPatSynDir, #endif+  dsTypeArg,    -- * Converting desugared AST back to TH AST   module Language.Haskell.TH.Desugar.Sweeten,@@ -59,48 +76,97 @@   -- * Reification   reifyWithWarning, -  -- | The following definitions allow you to register a list of-  -- @Dec@s to be used in reification queries.-  withLocalDeclarations, dsReify, reifyWithLocals_maybe, reifyWithLocals,+  -- ** Local reification+  -- $localReification+  withLocalDeclarations, dsReify, dsReifyType,+  reifyWithLocals_maybe, reifyWithLocals, reifyFixityWithLocals,+  reifyTypeWithLocals_maybe, reifyTypeWithLocals,+  lookupValueNameWithLocals, lookupTypeNameWithLocals,+  mkDataNameWithLocals, mkTypeNameWithLocals,+  reifyNameSpace,   DsMonad(..), DsM,    -- * Nested pattern flattening   scExp, scLetDec, +  -- * Capture-avoiding substitution and utilities+  module Language.Haskell.TH.Desugar.Subst,++  -- * Free variable calculation+  module Language.Haskell.TH.Desugar.FV,+   -- * Utility functions-  applyDExp, applyDType,+  applyDExp,   dPatToDExp, removeWilds,   getDataD, dataConNameToDataName, dataConNameToCon,   nameOccursIn, allNamesIn, flattenDValD, getRecordSelectors,   mkTypeName, mkDataName, newUniqueName,-  mkTupleDExp, mkTupleDPat, maybeDLetE, maybeDCaseE,-  substTy,-  tupleDegree_maybe, tupleNameDegree_maybe,-  unboxedTupleDegree_maybe, unboxedTupleNameDegree_maybe,-  strictToBang,+  mkTupleDExp, mkTupleDPat, mkTupleDType,+  maybeDLetE, maybeDCaseE, maybeDCasesE,+  dCaseE, dCasesE, dLamE, dLamCaseE, mkDLamEFromDPats,+  tupleNameDegree_maybe,+  unboxedSumNameDegree_maybe, unboxedTupleNameDegree_maybe,+  isTypeKindName, typeKindName, bindIP,+  mkExtraDKindBinders, dTyVarBndrToDType, changeDTVFlags,+  mapDTVName, mapDTVKind,+  toposortTyVarsOf, toposortKindVarsOfTvbs,+  ForAllTyFlag(..),+  tvbForAllTyFlagsToSpecs, tvbForAllTyFlagsToBndrVis, matchUpSAKWithDecl,+  dtvbForAllTyFlagsToSpecs, dtvbForAllTyFlagsToBndrVis, dMatchUpSAKWithDecl, +  -- ** 'FunArgs' and 'VisFunArg'+  FunArgs(..), ForallTelescope(..), VisFunArg(..),+  filterVisFunArgs, ravelType, unravelType,++  -- ** 'DFunArgs' and 'DVisFunArg'+  DFunArgs(..), DVisFunArg(..),+  filterDVisFunArgs, ravelDType, unravelDType,++  -- ** 'TypeArg'+  TypeArg(..), applyType, filterTANormals,+  tyVarBndrVisToTypeArg, tyVarBndrVisToTypeArgWithSig,+  unfoldType,++  -- ** 'DTypeArg'+  DTypeArg(..), applyDType, filterDTANormals,+  dTyVarBndrVisToDTypeArg, dTyVarBndrVisToDTypeArgWithSig,+  unfoldDType,+   -- ** Extracting bound names   extractBoundNamesStmt, extractBoundNamesDec, extractBoundNamesPat   ) where +import Language.Haskell.TH.Datatype.TyVarBndr+import Language.Haskell.TH.Desugar.AST import Language.Haskell.TH.Desugar.Core-import Language.Haskell.TH.Desugar.Util-import Language.Haskell.TH.Desugar.Sweeten-import Language.Haskell.TH.Syntax-import Language.Haskell.TH.Desugar.Reify import Language.Haskell.TH.Desugar.Expand+import Language.Haskell.TH.Desugar.FV import Language.Haskell.TH.Desugar.Match+import Language.Haskell.TH.Desugar.Reify+import Language.Haskell.TH.Desugar.Subst+import Language.Haskell.TH.Desugar.Sweeten+import Language.Haskell.TH.Desugar.Util+import Language.Haskell.TH.Syntax +import Control.Monad+import qualified Data.Foldable as F+import Data.Function+import qualified Data.Map as M import qualified Data.Set as S-#if __GLASGOW_HASKELL__ < 709-import Data.Foldable ( foldMap )-#endif import Prelude hiding ( exp )  -- | This class relates a TH type with its th-desugar type and allows -- conversions back and forth. The functional dependency goes only one--- way because `Type` and `Kind` are type synonyms, but they desugar--- to different types.+-- way because we define the following instances on old versions of GHC:+--+-- @+-- instance 'Desugar' 'TyVarBndrSpec' 'DTyVarBndrSpec'+-- instance 'Desugar' 'TyVarBndrUnit' 'DTyVarBndrUnit'+-- @+--+-- Prior to GHC 9.0, 'TyVarBndrSpec' and 'TyVarBndrUnit' are simply type+-- synonyms for 'TyVarBndr', so making the functional dependencies+-- bidirectional would cause these instances to be rejected. class Desugar th ds | ds -> th where   desugar :: DsMonad q => th -> q ds   sweeten :: ds -> th@@ -117,17 +183,44 @@   desugar = dsCxt   sweeten = cxtToTH -instance Desugar TyVarBndr DTyVarBndr where+#if __GLASGOW_HASKELL__ >= 900+-- | This instance is only @flag@-polymorphic on GHC 9.0 or later, since+-- previous versions of GHC do not equip 'TyVarBndr' with a @flag@ type+-- parameter. As a result, we define two separate instances for 'DTyVarBndr'+-- on older GHCs:+--+-- @+-- instance 'Desugar' 'TyVarBndrSpec' 'DTyVarBndrSpec'+-- instance 'Desugar' 'TyVarBndrUnit' 'DTyVarBndrUnit'+-- @+instance Desugar (TyVarBndr flag) (DTyVarBndr flag) where   desugar = dsTvb   sweeten = tvbToTH+#else+-- | This instance monomorphizes the @flag@ parameter of 'DTyVarBndr' since+-- pre-9.0 versions of GHC do not equip 'TyVarBndr' with a @flag@ type+-- parameter. There is also a corresponding instance for+-- 'TyVarBndrUnit'/'DTyVarBndrUnit'.+instance Desugar TyVarBndrSpec DTyVarBndrSpec where+  desugar = dsTvbSpec+  sweeten = tvbToTH +-- | This instance monomorphizes the @flag@ parameter of 'DTyVarBndr' since+-- pre-9.0 versions of GHC do not equip 'TyVarBndr' with a @flag@ type+-- parameter. There is also a corresponding instance for+-- 'TyVarBndrSpec'/'DTyVarBndrSpec'.+instance Desugar TyVarBndrUnit DTyVarBndrUnit where+  desugar = dsTvbUnit+  sweeten = tvbToTH+#endif+ instance Desugar [Dec] [DDec] where   desugar = dsDecs   sweeten = decsToTH -instance Desugar [Con] [DCon] where-  desugar = concatMapM dsCon-  sweeten = map conToTH+instance Desugar TypeArg DTypeArg where+  desugar = dsTypeArg+  sweeten = typeArgToTH  -- | If the declaration passed in is a 'DValD', creates new, equivalent -- declarations such that the 'DPat' in all 'DValD's is just a plain@@ -136,11 +229,11 @@ -- less efficient than those that come in: they have many more pattern -- matches. flattenDValD :: Quasi q => DLetDec -> q [DLetDec]-flattenDValD dec@(DValD (DVarPa _) _) = return [dec]+flattenDValD dec@(DValD (DVarP _) _) = return [dec] flattenDValD (DValD pat exp) = do   x <- newUniqueName "x" -- must use newUniqueName here because we might be top-level-  let top_val_d = DValD (DVarPa x) exp-      bound_names = S.elems $ extractBoundNamesDPat pat+  let top_val_d = DValD (DVarP x) exp+      bound_names = F.toList $ extractBoundNamesDPat pat   other_val_ds <- mapM (mk_val_d x) bound_names   return $ top_val_d : other_val_ds   where@@ -148,72 +241,225 @@       y <- newUniqueName "y"       let pat'  = wildify name y pat           match = DMatch pat' (DVarE y)-          cas   = DCaseE (DVarE x) [match]-      return $ DValD (DVarPa name) cas+          cas   = dCaseE (DVarE x) [match]+      return $ DValD (DVarP name) cas      wildify name y p =       case p of-        DLitPa lit -> DLitPa lit-        DVarPa n-          | n == name -> DVarPa y-          | otherwise -> DWildPa-        DConPa con ps -> DConPa con (map (wildify name y) ps)-        DTildePa pa -> DTildePa (wildify name y pa)-        DBangPa pa -> DBangPa (wildify name y pa)-        DWildPa -> DWildPa+        DLitP lit -> DLitP lit+        DVarP n+          | n == name -> DVarP y+          | otherwise -> DWildP+        DConP con ts ps -> DConP con ts (map (wildify name y) ps)+        DTildeP pa -> DTildeP (wildify name y pa)+        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] -extractBoundNamesDPat :: DPat -> S.Set Name-extractBoundNamesDPat (DLitPa _)      = S.empty-extractBoundNamesDPat (DVarPa n)      = S.singleton n-extractBoundNamesDPat (DConPa _ pats) = foldMap extractBoundNamesDPat pats-extractBoundNamesDPat (DTildePa pat)  = extractBoundNamesDPat pat-extractBoundNamesDPat (DBangPa pat)   = extractBoundNamesDPat pat-extractBoundNamesDPat DWildPa         = S.empty--fvDType :: DType -> S.Set Name-fvDType = go+-- | Produces 'DLetDec's representing the record selector functions from+-- the provided 'DCon's.+--+-- Note that if the same record selector appears in multiple constructors,+-- 'getRecordSelectors' will return only one binding for that selector.+-- For example, if you had:+--+-- @+-- data X = X1 {y :: Symbol} | X2 {y :: Symbol}+-- @+--+-- Then calling 'getRecordSelectors' on @[X1, X2]@ will return:+--+-- @+-- [ DSigD y (DAppT (DAppT DArrowT (DConT X)) (DConT Symbol))+-- , DFunD y [ DClause [DConP X1 [DVarP field]] (DVarE field)+--           , DClause [DConP X2 [DVarP field]] (DVarE field) ] ]+-- @+--+-- instead of returning one binding for @X1@ and another binding for @X2@.+--+-- 'getRecordSelectors' does not attempt to filter out \"naughty\" record+-- selectors—that is, records whose field types mention existentially+-- quantified type variables that do not appear in the constructor's return+-- type. Here is an example of a naughty record selector:+--+-- @+-- data Some :: (Type -> Type) -> Type where+--   MkSome :: { getSome :: f a } -> Some f+-- @+--+-- GHC itself will not allow the use of @getSome@ as a top-level function due+-- to its type @f a@ mentioning the existential variable @a@, but+-- 'getRecordSelectors' will return it nonetheless. Ultimately, this design+-- choice is a practical one, as detecting which type variables are existential+-- in Template Haskell is difficult in the general case.+getRecordSelectors :: DsMonad q => [DCon] -> q [DLetDec]+getRecordSelectors cons = merge_let_decs `fmap` concatMapM get_record_sels cons   where-    go (DForallT tvbs _cxt ty) = go ty `S.difference` (foldMap dtvbName tvbs)-    go (DAppT ty1 ty2)         = go ty1 `S.union` go ty2-    go (DSigT ty ki)           = go ty `S.union` fvDType ki-    go (DVarT n)               = S.singleton n-    go (DConT _)               = S.empty-    go DArrowT                 = S.empty-    go (DLitT {})              = S.empty-    go DWildCardT              = S.empty-    go DStarT                  = S.empty+    get_record_sels (DCon con_tvbs _ con_name con_fields con_ret_ty) =+      case con_fields of+        DRecC fields -> go fields+        DNormalC{}   -> return []+        where+          go fields = do+            varName <- qNewName "field"+            return $ concat+              [ [ DSigD name $ DForallT (DForallInvis con_tvbs)+                             $ DArrowT `DAppT` con_ret_ty `DAppT` field_ty+                , DFunD name [DClause [DConP con_name []+                                         (mk_field_pats n (length fields) varName)]+                                      (DVarE varName)] ]+              | ((name, _strict, field_ty), n) <- zip fields [0..]+              ] -dtvbName :: DTyVarBndr -> S.Set Name-dtvbName (DPlainTV n)    = S.singleton n-dtvbName (DKindedTV n _) = S.singleton n+    mk_field_pats :: Int -> Int -> Name -> [DPat]+    mk_field_pats 0 total name = DVarP name : (replicate (total-1) DWildP)+    mk_field_pats n total name = DWildP : mk_field_pats (n-1) (total-1) name --- | Produces 'DLetDec's representing the record selector functions from--- the provided 'DCon'.-getRecordSelectors :: Quasi q-                   => DType        -- ^ the type of the argument-                   -> DCon-                   -> q [DLetDec]-getRecordSelectors arg_ty (DCon _ _ con_name con _) = case con of-    DRecC fields -> go fields-    _ -> return []+    merge_let_decs :: [DLetDec] -> [DLetDec]+    merge_let_decs decs =+      let (name_clause_map, decs') = gather_decs M.empty S.empty decs+       in augment_clauses name_clause_map decs'+        -- First, for each record selector-related declarations, do the following:+        --+        -- 1. If it's a DFunD...+        --   a. If we haven't encountered it before, add a mapping from its Name+        --      to its associated DClauses, and continue.+        --   b. If we have encountered it before, augment the existing Name's+        --      mapping with the new clauses. Then remove the DFunD from the list+        --      and continue.+        -- 2. If it's a DSigD...+        --   a. If we haven't encountered it before, remember its Name and continue.+        --   b. If we have encountered it before, remove the DSigD from the list+        --      and continue.+        -- 3. Otherwise, continue.+        --+        -- After this, scan over the resulting list once more with the mapping+        -- that we accumulated. For every DFunD, replace its DClauses with the+        -- ones corresponding to its Name in the mapping.+        --+        -- Note that this algorithm combines all of the DClauses for each unique+        -- Name, while preserving the order in which the DFunDs were originally+        -- found. Moreover, it removes duplicate DSigD entries. Using Maps and+        -- Sets avoid quadratic blowup for data types with many record selectors.+      where+        gather_decs :: M.Map Name [DClause] -> S.Set Name -> [DLetDec]+                    -> (M.Map Name [DClause], [DLetDec])+        gather_decs name_clause_map _ [] = (name_clause_map, [])+        gather_decs name_clause_map type_sig_names (x:xs)+          -- 1.+          | DFunD n clauses <- x+          = let name_clause_map' = M.insertWith (\new old -> old ++ new)+                                                n clauses name_clause_map+             in if n `M.member` name_clause_map+                then gather_decs name_clause_map' type_sig_names xs+                else let (map', decs') = gather_decs name_clause_map'+                                           type_sig_names xs+                      in (map', x:decs')++          -- 2.+          | DSigD n _ <- x+          = if n `S.member` type_sig_names+            then gather_decs name_clause_map type_sig_names xs+            else let (map', decs') = gather_decs name_clause_map+                                       (n `S.insert` type_sig_names) xs+                  in (map', x:decs')++          -- 3.+          | otherwise =+              let (map', decs') = gather_decs name_clause_map type_sig_names xs+               in (map', x:decs')++        augment_clauses :: M.Map Name [DClause] -> [DLetDec] -> [DLetDec]+        augment_clauses _ [] = []+        augment_clauses name_clause_map (x:xs)+          | DFunD n _ <- x, Just merged_clauses <- n `M.lookup` name_clause_map+          = DFunD n merged_clauses:augment_clauses name_clause_map xs+          | otherwise = x:augment_clauses name_clause_map xs++-- | Create new kind variable binder names corresponding to the return kind of+-- a data type. This is useful when you have a data type like:+--+-- @+-- data Foo :: forall k. k -> Type -> Type where ...+-- @+--+-- But you want to be able to refer to the type @Foo a b@.+-- 'mkExtraDKindBinders' will take the kind @forall k. k -> Type -> Type@,+-- discover that is has two visible argument kinds, and return as a result+-- two new kind variable binders @[a :: k, b :: Type]@, where @a@ and @b@+-- are fresh type variable names.+--+-- This expands kind synonyms if necessary.+mkExtraDKindBinders :: 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-    go fields = do-      varName <- qNewName "field"-      let tvbs = fvDType arg_ty-          maybe_forall-            | S.null tvbs = id-            | otherwise   = DForallT (map DPlainTV $ S.toList tvbs) []-          num_pats = length fields-      return $ concat-        [ [ DSigD name (maybe_forall $ DArrowT `DAppT` arg_ty `DAppT` res_ty)-          , DFunD name [DClause [DConPa con_name (mk_field_pats n num_pats varName)]-                                (DVarE varName)] ]-        | ((name, _strict, res_ty), n) <- zip fields [0..]-        , fvDType res_ty `S.isSubsetOf` tvbs   -- exclude "naughty" selectors-        ]+    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 -    mk_field_pats :: Int -> Int -> Name -> [DPat]-    mk_field_pats 0 total name = DVarPa name : (replicate (total-1) DWildPa)-    mk_field_pats n total name = DWildPa : mk_field_pats (n-1) (total-1) name+{- $localReification++@template-haskell@ reification functions like 'reify' and 'qReify', as well as+@th-desugar@'s 'reifyWithWarning', only look through declarations that either+(1) have already been typechecked in the current module, or (2) are in scope+because of imports. We refer to this as /global/ reification. Sometimes,+however, you may wish to reify declarations that have been quoted but not+yet been typechecked, such as in the following example:++@+example :: IO ()+example = putStrLn+  $(do decs <- [d| data Foo = MkFoo |]+       info <- 'reify' (mkName \"Foo\")+       stringE $ pprint info)+@++Because @Foo@ only exists in a TH quote, it is not available globally. As a+result, the call to @'reify' (mkName \"Foo\")@ will fail.++To make this sort of example possible, @th-desugar@ extends global reification+with /local/ reification. A function that performs local reification (such+as 'dsReify', 'reifyWithLocals', or similar functions that have a 'DsMonad'+context) looks through both typechecked (or imported) declarations /and/ quoted+declarations that are currently in scope. One can add quoted declarations in+the current scope by using the 'withLocalDeclarations' function. Here is an+example of how to repair the example above using 'withLocalDeclarations':++@+example2 :: IO ()+example2 = putStrLn+  $(do decs <- [d| data Foo = MkFoo |]+       info <- 'withLocalDeclarations' decs $+                 'reifyWithLocals' (mkName \"Foo\")+       stringE $ pprint info)+@++Note that 'withLocalDeclarations' should only be used to add quoted+declarations with names that are not duplicates of existing global or local+declarations. Adding duplicate declarations through 'withLocalDeclarations'+is undefined behavior and should be avoided. This is unlikely to happen if+you are only using 'withLocalDeclarations' in conjunction with TH quotes,+however. For instance, this is /not/ an example of duplicate declarations:++@+data T = MkT1++$(do decs <- [d| data T = MkT2 |]+     info <- 'withLocalDeclarations' decs ...+     ...)+@++The quoted @data T = MkT2@ does not conflict with the top-level @data T = Mk1@+since declaring a data type within TH quotes gives it a fresh, unique name that+distinguishes it from any other data types already in scope.+-}
+ Language/Haskell/TH/Desugar/AST.hs view
@@ -0,0 +1,494 @@+{- Language/Haskell/TH/Desugar/AST.hs++(c) Ryan Scott 2018++Defines the desugared Template Haskell AST. The desugared types and+constructors are prefixed with a D.+-}++{-# LANGUAGE CPP, DeriveDataTypeable, 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(..))+#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+            -- | 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+          | 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+          | DConP Name [DType] [DPat]+          | DTildeP DPat+          | DBangP DPat+          | DSigP DPat DType+          | DWildP+          | DTypeP DType+          | DInvisP DType+          deriving (Eq, Show, Data, Generic, Lift)++-- | Corresponds to TH's @Type@ type, used to represent+-- types and kinds.+data DType = DForallT DForallTelescope DType+           | DConstrainedT DCxt DType+           | DAppT DType DType+           | DAppKindT DType DKind+           | DSigT DType DKind+           | DVarT Name+           | DConT Name+           | DArrowT+           | DLitT TyLit+           | DWildCardT+           deriving (Eq, Show, Data, Generic, Lift)++-- | The type variable binders in a @forall@.+data DForallTelescope+  = DForallVis   [DTyVarBndrUnit]+    -- ^ A visible @forall@ (e.g., @forall a -> {...}@).+    --   These do not have any notion of specificity, so we use+    --   '()' as a placeholder value in the 'DTyVarBndr's.+  | DForallInvis [DTyVarBndrSpec]+    -- ^ An invisible @forall@ (e.g., @forall a {b} c -> {...}@),+    --   where each binder has a 'Specificity'.+  deriving (Eq, Show, Data, Generic, Lift)++-- | Kinds are types. Corresponds to TH's @Kind@+type DKind = DType++-- | Predicates are types. Corresponds to TH's @Pred@+type DPred = DType++-- | Corresponds to TH's @Cxt@+type DCxt = [DPred]++-- | Corresponds to TH's @TyVarBndr@+data DTyVarBndr flag+  = DPlainTV Name flag+  | DKindedTV Name flag DKind+  deriving (Eq, Show, Data, Generic, Functor, Foldable, Traversable, Lift)++-- | Corresponds to TH's @TyVarBndrSpec@+type DTyVarBndrSpec = DTyVarBndr Specificity++-- | 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, Lift)++-- | Corresponds to TH's @Clause@ type.+data DClause = DClause [DPat] DExp+  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 NamespaceSpecifier Name+             | DPragmaD DPragma+             deriving (Eq, Show, Data, Generic, Lift)++#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+            -- | 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.+          | DInstanceD (Maybe Overlap) (Maybe [DTyVarBndrUnit]) DCxt DType [DDec]+          | DForeignD DForeign+          | DOpenTypeFamilyD DTypeFamilyHead+          | DClosedTypeFamilyD DTypeFamilyHead [DTySynEqn]+          | 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]+            -- | Note that the @Maybe [DTyVarBndrUnit]@ field is dropped+            -- entirely when sweetened, so it is only useful for functions+            -- that directly consume @DDec@s.+          | DStandaloneDerivD (Maybe DDerivStrategy) (Maybe [DTyVarBndrUnit]) DCxt DType+          | DDefaultSigD Name DType+          | DPatSynD Name PatSynArgs DPatSynDir DPat+          | DPatSynSigD Name DPatSynType+          | DKiSigD Name DKind+              -- 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, 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, Lift)++-- | Corresponds to TH's 'PatSynType' type+type DPatSynType = DType++#if __GLASGOW_HASKELL__ < 801+-- | Same as @PatSynArgs@ from TH; defined here for backwards compatibility.+data PatSynArgs+  = PrefixPatSyn [Name]        -- ^ @pattern P {x y z} = p@+  | InfixPatSyn Name Name      -- ^ @pattern {x P y} = p@+  | RecordPatSyn [Name]        -- ^ @pattern P { {x,y,z} } = p@+  deriving (Eq, Show, Data, Generic, Lift)+#endif++-- | Corresponds to TH's 'TypeFamilyHead' type+data DTypeFamilyHead = DTypeFamilyHead Name [DTyVarBndrVis] DFamilyResultSig+                                       (Maybe InjectivityAnn)+                     deriving (Eq, Show, Data, Generic, Lift)++-- | Corresponds to TH's 'FamilyResultSig' type+data DFamilyResultSig = DNoSig+                      | DKindSig DKind+                      | DTyVarSig DTyVarBndrUnit+                      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+-- that all data type declarations can support explicit return kinds, so+-- one does not need to represent them with something like @'Maybe' 'DKind'@,+-- since Haskell98-style data declaration syntax isn't used. Accordingly,+-- there are some differences between 'DCon' and 'Con' to keep in mind:+--+-- * Unlike 'ForallC', where the meaning of the 'TyVarBndr's changes depending+--   on whether it's followed by 'GadtC'/'RecGadtC' or not, the meaning of the+--   'DTyVarBndr's in a 'DCon' is always the same: it is the list of+--   universally /and/ existentially quantified type variables. Note that it is+--   not guaranteed that one set of type variables will appear before the+--   other.+--+-- * A 'DCon' always has an explicit return type.+data DCon = DCon [DTyVarBndrSpec] DCxt Name DConFields+                 DType  -- ^ The GADT result type+          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, 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+-- below are declared infix.+--+-- @+-- data Infix = Int `Infix` Int | Int :*: Int+-- @+--+-- Whereas neither of these constructors are declared infix:+--+-- @+-- data Prefix = Prefix Int Int | (:+:) Int Int+-- @+--+-- For GADTs, detecting whether a constructor is declared infix is a bit+-- trickier, as one cannot write a GADT constructor "infix-style" like one+-- can for normal ADT constructors. GHC considers a GADT constructor to be+-- declared infix if it meets the following three criteria:+--+-- 1. Its name uses operator syntax (e.g., @(:*:)@).+-- 2. It has exactly two fields (without record syntax).+-- 3. It has a programmer-specified fixity declaration.+--+-- For example, in the following GADT:+--+-- @+-- infixl 5 :**:, :&&:, :^^:, `ActuallyPrefix`+-- data InfixGADT a where+--   (:**:) :: Int -> b -> InfixGADT (Maybe b) -- Only this one is infix+--   ActuallyPrefix :: Char -> Bool -> InfixGADT Double+--   (:&&:) :: { infixGADT1 :: b, infixGADT2 :: Int } -> InfixGADT [b]+--   (:^^:) :: Int -> Int -> Int -> InfixGADT Int+--   (:!!:) :: Char -> Char -> InfixGADT Char+-- @+--+-- Only the @(:**:)@ constructor is declared infix. The other constructors+-- are not declared infix, because:+--+-- * @ActuallyPrefix@ does not use operator syntax (criterion 1).+-- * @(:&&:)@ uses record syntax (criterion 2).+-- * @(:^^:)@ does not have exactly two fields (criterion 2).+-- * @(:!!:)@ does not have a programmer-specified fixity declaration (criterion 3).+type DDeclaredInfix = Bool++-- | Corresponds to TH's @BangType@ type.+type DBangType = (Bang, DType)++-- | Corresponds to TH's @VarBangType@ type.+type DVarBangType = (Name, Bang, DType)++-- | Corresponds to TH's @Foreign@ type.+data DForeign = DImportF Callconv Safety String Name DType+              | DExportF Callconv String Name DType+              deriving (Eq, Show, Data, Generic, Lift)++-- | Corresponds to TH's @Pragma@ type.+data DPragma = DInlineP Name Inline RuleMatch 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+             | 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, Lift)++-- | Corresponds to TH's @TySynEqn@ type (to store type family equations).+data DTySynEqn = DTySynEqn (Maybe [DTyVarBndrUnit]) DType DType+               deriving (Eq, Show, Data, Generic, Lift)++-- | Corresponds to TH's @Info@ type.+data DInfo = DTyConI DDec (Maybe [DInstanceDec])+           | DVarI Name DType (Maybe Name)+               -- ^ The @Maybe Name@ stores the name of the enclosing definition+               -- (datatype, for a data constructor; class, for a method),+               -- if any+           | DTyVarI Name DKind+           | DPrimTyConI Name Int Bool+               -- ^ The @Int@ is the arity; the @Bool@ is whether this tycon+               -- is unlifted.+           | DPatSynI Name DPatSynType+           deriving (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, 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, Lift)
Language/Haskell/TH/Desugar/Core.hs view
@@ -1,1173 +1,2451 @@ {- Language/Haskell/TH/Desugar/Core.hs  (c) Richard Eisenberg 2013-eir@cis.upenn.edu--Desugars full Template Haskell syntax into a smaller core syntax for further-processing. The desugared types and constructors are prefixed with a D.--}--{-# LANGUAGE TemplateHaskell, LambdaCase, CPP, DeriveDataTypeable,-             DeriveGeneric, TupleSections #-}--module Language.Haskell.TH.Desugar.Core where--import Prelude hiding (mapM, foldl, foldr, all, elem, exp, concatMap, and)--import Language.Haskell.TH hiding (match, clause, cxt)-import Language.Haskell.TH.Syntax hiding (lift)-import Language.Haskell.TH.ExpandSyns ( expandSyns )--#if __GLASGOW_HASKELL__ < 709-import Control.Applicative-#endif-import Control.Monad hiding (mapM)-import Control.Monad.Zip-import Control.Monad.Writer hiding (mapM)-import Data.Foldable hiding (notElem)-import Data.Traversable-import Data.Data hiding (Fixity)-import GHC.Generics hiding (Fixity)--import qualified Data.Set as S-import GHC.Exts--import Language.Haskell.TH.Desugar.Util-import Language.Haskell.TH.Desugar.Reify---- | Corresponds to TH's @Exp@ type. Note that @DLamE@ takes names, not patterns.-data DExp = DVarE Name-          | DConE Name-          | DLitE Lit-          | DAppE DExp DExp-          | DLamE [Name] DExp-          | DCaseE DExp [DMatch]-          | DLetE [DLetDec] DExp-          | DSigE DExp DType-          | DStaticE DExp-          deriving (Show, Typeable, Data, Generic)----- | Corresponds to TH's @Pat@ type.-data DPat = DLitPa Lit-          | DVarPa Name-          | DConPa Name [DPat]-          | DTildePa DPat-          | DBangPa DPat-          | DWildPa-          deriving (Show, Typeable, Data, Generic)---- | Corresponds to TH's @Type@ type, used to represent--- types and kinds.-data DType = DForallT [DTyVarBndr] DCxt DType-           | DAppT DType DType-           | DSigT DType DKind-           | DVarT Name-           | DConT Name-           | DArrowT-           | DLitT TyLit-           | DWildCardT-           | DStarT-           deriving (Show, Typeable, Data, Generic)---- | Kinds are types.-type DKind = DType---- | Corresponds to TH's @Cxt@-type DCxt = [DPred]---- | Corresponds to TH's @Pred@-data DPred = DAppPr DPred DType-           | DSigPr DPred DKind-           | DVarPr Name-           | DConPr Name-           | DWildCardPr-           deriving (Show, Typeable, Data, Generic)---- | Corresponds to TH's @TyVarBndr@-data DTyVarBndr = DPlainTV Name-                | DKindedTV Name DKind-                deriving (Show, Typeable, Data, Generic)---- | Corresponds to TH's @Match@ type.-data DMatch = DMatch DPat DExp-  deriving (Show, Typeable, Data, Generic)---- | Corresponds to TH's @Clause@ type.-data DClause = DClause [DPat] DExp-  deriving (Show, Typeable, Data, Generic)---- | Declarations as used in a @let@ statement.-data DLetDec = DFunD Name [DClause]-             | DValD DPat DExp-             | DSigD Name DType-             | DInfixD Fixity Name-             deriving (Show, Typeable, Data, Generic)---- | Is it a @newtype@ or a @data@ type?-data NewOrData = Newtype-               | Data-               deriving (Eq, Show, Typeable, Data, Generic)---- | Corresponds to TH's @Dec@ type.-data DDec = DLetDec DLetDec-          | DDataD NewOrData DCxt Name [DTyVarBndr] [DCon] [DPred]-          | DTySynD Name [DTyVarBndr] DType-          | DClassD DCxt Name [DTyVarBndr] [FunDep] [DDec]-          | DInstanceD (Maybe Overlap) DCxt DType [DDec]-          | DForeignD DForeign-          | DPragmaD DPragma-          | DOpenTypeFamilyD DTypeFamilyHead-          | DClosedTypeFamilyD DTypeFamilyHead [DTySynEqn]-          | DDataFamilyD Name [DTyVarBndr]-          | DDataInstD NewOrData DCxt Name [DType] [DCon] [DPred]-          | DTySynInstD Name DTySynEqn-          | DRoleAnnotD Name [Role]-          | DStandaloneDerivD DCxt DType-          | DDefaultSigD Name DType-          deriving (Show, Typeable, Data, Generic)--#if __GLASGOW_HASKELL__ < 711-data Overlap = Overlappable | Overlapping | Overlaps | Incoherent-  deriving (Eq, Ord, Show, Typeable, Data, Generic)-#endif---- | Corresponds to TH's 'TypeFamilyHead' type-data DTypeFamilyHead = DTypeFamilyHead Name [DTyVarBndr] DFamilyResultSig-                                       (Maybe InjectivityAnn)-                     deriving (Show, Typeable, Data, Generic)---- | Corresponds to TH's 'FamilyResultSig' type-data DFamilyResultSig = DNoSig-                      | DKindSig DKind-                      | DTyVarSig DTyVarBndr-                      deriving (Show, Typeable, Data, Generic)--#if __GLASGOW_HASKELL__ <= 710-data InjectivityAnn = InjectivityAnn Name [Name]-  deriving (Eq, Ord, Show, Typeable, Data, Generic)-#endif---- | Corresponds to TH's @Con@ type.-data DCon = DCon [DTyVarBndr] DCxt Name DConFields-                 (Maybe DType)  -- ^ A GADT result type, if there is one-          deriving (Show, Typeable, Data, Generic)---- | A list of fields either for a standard data constructor or a record--- data constructor.-data DConFields = DNormalC [DBangType]-                | DRecC [DVarBangType]-                deriving (Show, Typeable, Data, Generic)---- | Corresponds to TH's @BangType@ type.-type DBangType = (Bang, DType)---- | Corresponds to TH's @VarBangType@ type.-type DVarBangType = (Name, Bang, DType)--#if __GLASGOW_HASKELL__ <= 710--- | Corresponds to TH's definition-data SourceUnpackedness = NoSourceUnpackedness-                        | SourceNoUnpack-                        | SourceUnpack-  deriving (Eq, Ord, Show, Typeable, Data, Generic)---- | Corresponds to TH's definition-data SourceStrictness = NoSourceStrictness-                      | SourceLazy-                      | SourceStrict-  deriving (Eq, Ord, Show, Typeable, Data, Generic)---- | Corresponds to TH's definition-data Bang = Bang SourceUnpackedness SourceStrictness-  deriving (Eq, Ord, Show, Typeable, Data, Generic)-#endif---- | Corresponds to TH's @Foreign@ type.-data DForeign = DImportF Callconv Safety String Name DType-              | DExportF Callconv String Name DType-              deriving (Show, Typeable, Data, Generic)---- | Corresponds to TH's @Pragma@ type.-data DPragma = DInlineP Name Inline RuleMatch Phases-             | DSpecialiseP Name DType (Maybe Inline) Phases-             | DSpecialiseInstP DType-             | DRuleP String [DRuleBndr] DExp DExp Phases-             | DAnnP AnnTarget DExp-             | DLineP Int String-             deriving (Show, Typeable, Data, Generic)---- | Corresponds to TH's @RuleBndr@ type.-data DRuleBndr = DRuleVar Name-               | DTypedRuleVar Name DType-               deriving (Show, Typeable, Data, Generic)---- | Corresponds to TH's @TySynEqn@ type (to store type family equations).-data DTySynEqn = DTySynEqn [DType] DType-               deriving (Show, Typeable, Data, Generic)--#if __GLASGOW_HASKELL__ < 707--- | Same as @Role@ from TH; defined here for GHC 7.6.3 compatibility.-data Role = NominalR | RepresentationalR | PhantomR | InferR-          deriving (Show, Typeable, Data, Generic)---- | Same as @AnnTarget@ from TH; defined here for GHC 7.6.3 compatibility.-data AnnTarget = ModuleAnnotation-               | TypeAnnotation Name-               | ValueAnnotation Name-               deriving (Show, Typeable, Data, Generic)-#endif---- | Corresponds to TH's @Info@ type.-data DInfo = DTyConI DDec (Maybe [DInstanceDec])-           | DVarI Name DType (Maybe Name)-               -- ^ The @Maybe Name@ stores the name of the enclosing definition-               -- (datatype, for a data constructor; class, for a method),-               -- if any-           | DTyVarI Name DKind-           | DPrimTyConI Name Int Bool-               -- ^ The @Int@ is the arity; the @Bool@ is whether this tycon-               -- is unlifted.-           deriving (Show, Typeable, Data, Generic)--type DInstanceDec = DDec -- ^ Guaranteed to be an instance declaration---- | 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) = dsLam pats =<< dsExp exp-dsExp (LamCaseE matches) = do-  x <- newUniqueName "x"-  matches' <- dsMatches x matches-  return $ DLamE [x] (DCaseE (DVarE x) matches')-dsExp (TupE exps) = do-  exps' <- mapM dsExp exps-  return $ foldl DAppE (DConE $ tupleDataName (length exps)) exps'-dsExp (UnboxedTupE exps) =-  foldl DAppE (DConE $ unboxedTupleDataName (length exps)) <$> mapM dsExp exps-dsExp (CondE e1 e2 e3) =-  dsExp (CaseE e1 [ Match (ConP 'True [])  (NormalB e2) []-                  , Match (ConP 'False []) (NormalB e3) [] ])-dsExp (MultiIfE guarded_exps) =-  let failure = DAppE (DVarE 'error) (DLitE (StringL "Non-exhaustive guards in multi-way if")) in-  dsGuards guarded_exps failure-dsExp (LetE decs exp) = DLetE <$> dsLetDecs decs <*> dsExp 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 (DVarPa scrutinee) exp'] $-           DCaseE (DVarE scrutinee) matches'-dsExp (DoE stmts) = dsDoStmts stmts-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 <- case con of-                 RecC _name fields -> reorderFields fields field_exps-                                                    (repeat $ DVarE 'undefined)-                 _ -> impossible $ "Record syntax used with non-record constructor "-                                   ++ (show con_name) ++ "."-  return $ foldl DAppE (DConE con_name) reordered-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-#if __GLASGOW_HASKELL__ > 710-                    VarI _name ty _m_dec -> extract_first_arg ty-#else-                    VarI _name ty _m_dec _fixity -> extract_first_arg ty-#endif-                    _ -> 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-        has_names (RecC _con_name args) =-          let con_field_names = map fst_of_3 args in-          all (`elem` con_field_names) field_names-        has_names (ForallC _ _ c) = has_names c-        has_names _               = False--    con_to_dmatch :: DsMonad q => Con -> q DMatch-    con_to_dmatch (RecC con_name args) = do-      let con_field_names = map fst_of_3 args-      field_var_names <- mapM (newUniqueName . nameBase) con_field_names-      DMatch (DConPa con_name (map DVarPa field_var_names)) <$>-             (foldl DAppE (DConE con_name) <$>-                    (reorderFields args field_exps (map DVarE field_var_names)))-    con_to_dmatch (ForallC _ _ c) = con_to_dmatch c-    con_to_dmatch _ = impossible "Internal error within th-desugar."--    error_match = DMatch DWildPa (DAppE (DVarE 'error)-                   (DLitE (StringL "Non-exhaustive patterns in record update")))--    fst_of_3 (x, _, _) = x-#if __GLASGOW_HASKELL__ >= 709-dsExp (StaticE exp) = DStaticE <$> dsExp exp-#endif-#if __GLASGOW_HASKELL__ > 710-dsExp (UnboundVarE n) = return (DVarE n)-#endif---- | Desugar a lambda expression, where the body has already been desugared-dsLam :: DsMonad q => [Pat] -> DExp -> q DExp-dsLam pats exp-  | Just names <- mapM stripVarP_maybe pats-  = return $ DLamE names exp-  | otherwise-  = do arg_names <- replicateM (length pats) (newUniqueName "arg")-       let scrutinee = mkTupleDExp (map DVarE arg_names)-       (pats', exp') <- dsPatsOverExp pats exp-       let match = DMatch (mkTupleDPat pats') exp'-       return $ DLamE arg_names (DCaseE scrutinee [match])---- | 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 = DCaseE (DVarE scr) rest'  -- this might be an empty case.-      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 _ =-  maybeDLetE <$> dsLetDecs decs <*> dsExp exp-dsBody (GuardedB guarded_exps) decs failure =-  maybeDLetE <$> dsLetDecs decs <*> dsGuards guarded_exps failure---- | 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 :: String -> DExp -> [DMatch] -> DExp-maybeDCaseE err _     []      = DAppE (DVarE 'error) (DLitE (StringL err))-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 DWildPa failure]-dsGuardStmts (LetS decs : rest) success failure = do-  decs' <- dsLetDecs decs-  success' <- dsGuardStmts rest success failure-  return $ DLetE decs' 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 (DConPa 'True []) success'-                       , DMatch (DConPa 'False []) failure ]-dsGuardStmts (ParS _ : _) _ _ = impossible "Parallel comprehension in a pattern guard."---- | Desugar the @Stmt@s in a @do@ expression-dsDoStmts :: DsMonad q => [Stmt] -> q DExp-dsDoStmts [] = impossible "do-expression ended with something other than bare statement."-dsDoStmts [NoBindS exp] = dsExp exp-dsDoStmts (BindS pat exp : rest) = do-  exp' <- dsExp exp-  rest' <- dsDoStmts rest-  DAppE (DAppE (DVarE '(>>=)) exp') <$> dsLam [pat] rest'-dsDoStmts (LetS decs : rest) = DLetE <$> dsLetDecs decs <*> dsDoStmts rest-dsDoStmts (NoBindS exp : rest) = do-  exp' <- dsExp exp-  rest' <- dsDoStmts rest-  return $ DAppE (DAppE (DVarE '(>>)) exp') rest'-dsDoStmts (ParS _ : _) = impossible "Parallel comprehension in a do-statement."---- | 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-  exp' <- dsExp exp-  rest' <- dsComp rest-  DAppE (DAppE (DVarE '(>>=)) exp') <$> dsLam [pat] rest'-dsComp (LetS decs : rest) = DLetE <$> dsLetDecs decs <*> dsComp 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) <$> dsLam [pat] rest'---- | 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 (Pat, 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_pat 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 (ConP (tupleDataName 2) [mk_tuple_pat qv, rest_pat], zipped)---- helper function for dsParComp-mk_tuple_stmt :: S.Set Name -> Stmt-mk_tuple_stmt name_set =-  NoBindS (mkTupleExp (S.foldr ((:) . VarE) [] name_set))---- helper function for dsParComp-mk_tuple_pat :: S.Set Name -> Pat-mk_tuple_pat name_set =-  mkTuplePat (S.foldr ((:) . VarP) [] 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 = uncurry (zipWith (DValD . DVarPa)) $ unzip 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 = uncurry (zipWith (DValD . DVarPa)) $ unzip 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 $ DLitPa lit-dsPat (VarP n) = return $ DVarPa n-dsPat (TupP pats) = DConPa (tupleDataName (length pats)) <$> mapM dsPat pats-dsPat (UnboxedTupP pats) = DConPa (unboxedTupleDataName (length pats)) <$>-                           mapM dsPat pats-dsPat (ConP name pats) = DConPa name <$> mapM dsPat pats-dsPat (InfixP p1 name p2) = DConPa name <$> mapM dsPat [p1, p2]-dsPat (UInfixP _ _ _) =-  fail "Cannot desugar unresolved infix operators."-dsPat (ParensP pat) = dsPat pat-dsPat (TildeP pat) = DTildePa <$> dsPat pat-dsPat (BangP pat) = DBangPa <$> dsPat pat-dsPat (AsP name pat) = do-  pat' <- dsPat pat-  pat'' <- lift $ removeWilds pat'-  tell [(name, dPatToDExp pat'')]-  return pat''-dsPat WildP = return DWildPa-dsPat (RecP con_name field_pats) = do-  con <- lift $ dataConNameToCon con_name-  reordered <- case con of-    RecC _name fields -> reorderFieldsPat fields field_pats-    _ -> lift $ impossible $ "Record syntax used with non-record constructor "-                             ++ (show con_name) ++ "."-  return $ DConPa con_name reordered-dsPat (ListP pats) = go pats-  where go [] = return $ DConPa '[] []-        go (h : t) = do-          h' <- dsPat h-          t' <- go t-          return $ DConPa '(:) [h', t']-dsPat (SigP _ _) =-  lift $ impossible-             ("At last check (Aug 2013), type patterns in signatures are not\n" ++-              "supported in GHC. They are not supported in th-desugar either.")-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 (DLitPa lit) = DLitE lit-dPatToDExp (DVarPa name) = DVarE name-dPatToDExp (DConPa name pats) = foldl DAppE (DConE name) (map dPatToDExp pats)-dPatToDExp (DTildePa pat) = dPatToDExp pat-dPatToDExp (DBangPa pat) = dPatToDExp pat-dPatToDExp DWildPa = 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@(DLitPa _) = return p-removeWilds p@(DVarPa _) = return p-removeWilds (DConPa con_name pats) = DConPa con_name <$> mapM removeWilds pats-removeWilds (DTildePa pat) = DTildePa <$> removeWilds pat-removeWilds (DBangPa pat) = DBangPa <$> removeWilds pat-removeWilds DWildPa = DVarPa <$> 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)-#if __GLASGOW_HASKELL__ > 710-dsInfo (ClassOpI name ty parent) =-#else-dsInfo (ClassOpI name ty parent _fixity) =-#endif-  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-  (ddec', num_args) <- fixBug8884ForFamilies ddec-  let dinstances' = map (fixBug8884ForInstances num_args) dinstances-  return $ DTyConI ddec' (Just dinstances')-dsInfo (PrimTyConI name arity unlifted) =-  return $ DPrimTyConI name arity unlifted-#if __GLASGOW_HASKELL__ > 710-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-#else-dsInfo (DataConI name ty parent _fixity) =-  DVarI name <$> dsType ty <*> pure (Just parent)-dsInfo (VarI name ty Nothing _fixity) =-  DVarI name <$> dsType ty <*> pure Nothing-dsInfo (VarI name _ (Just _) _) =-  impossible $ "Declaration supplied with variable: " ++ show name-#endif-dsInfo (TyVarI name ty) = DTyVarI name <$> dsType ty--fixBug8884ForFamilies :: DsMonad q => DDec -> q (DDec, Int)-#if __GLASGOW_HASKELL__ < 708-fixBug8884ForFamilies (DOpenTypeFamilyD (DTypeFamilyHead name tvbs frs ann)) = do-  let num_args = length tvbs-  frs' <- remove_arrows num_args frs-  return (DOpenTypeFamilyD (DTypeFamilyHead name tvbs frs' ann),num_args)-fixBug8884ForFamilies (DClosedTypeFamilyD (DTypeFamilyHead name tvbs frs ann) eqns) = do-  let num_args = length tvbs-      eqns' = map (fixBug8884ForEqn num_args) eqns-  frs' <- remove_arrows num_args frs-  return (DClosedTypeFamilyD (DTypeFamilyHead name tvbs frs' ann) eqns', num_args)-fixBug8884ForFamilies dec@(DDataFamilyD _ _)-  = return (dec, 0)   -- the num_args is ignored for data families-fixBug8884ForFamilies dec =-  impossible $ "Reifying yielded a FamilyI with a non-family Dec: " ++ show dec--remove_arrows :: DsMonad q => Int -> DFamilyResultSig -> q DFamilyResultSig-remove_arrows n (DKindSig k) = DKindSig <$> remove_arrows_kind n k-remove_arrows n (DTyVarSig (DKindedTV nm k)) =-  DTyVarSig <$> (DKindedTV nm <$> remove_arrows_kind n k)-remove_arrows _ frs = return frs--remove_arrows_kind :: DsMonad q => Int -> DKind -> q DKind-remove_arrows_kind 0 k = return k-remove_arrows_kind n (DAppT (DAppT DArrowT _) k) = remove_arrows_kind (n-1) k-remove_arrows_kind _ _ =-  impossible "Internal error: Fix for bug 8884 ran out of arrows."--#else-fixBug8884ForFamilies dec = return (dec, 0)   -- return value ignored-#endif--fixBug8884ForInstances :: Int -> DDec -> DDec-fixBug8884ForInstances num_args (DTySynInstD name eqn) =-  DTySynInstD name (fixBug8884ForEqn num_args eqn)-fixBug8884ForInstances _ dec = dec--fixBug8884ForEqn :: Int -> DTySynEqn -> DTySynEqn-#if __GLASGOW_HASKELL__ < 708-fixBug8884ForEqn num_args (DTySynEqn lhs rhs) =-  let lhs' = drop (length lhs - num_args) lhs in-  DTySynEqn lhs' rhs-#else-fixBug8884ForEqn _ = id-#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 {}) = (fmap . map) DLetDec $ dsLetDec d-dsDec d@(ValD {}) = (fmap . map) DLetDec $ dsLetDec d-#if __GLASGOW_HASKELL__ > 710-dsDec (DataD cxt n tvbs mk cons derivings) = do-  extra_tvbs <- mkExtraTvbs tvbs mk-  (:[]) <$> (DDataD Data <$> dsCxt cxt <*> pure n-                         <*> ((++ extra_tvbs) <$> mapM dsTvb tvbs)-                         <*> concatMapM dsCon cons-                         <*> dsCxt derivings)-dsDec (NewtypeD cxt n tvbs mk con derivings) = do-  extra_tvbs <- mkExtraTvbs tvbs mk-  (:[]) <$> (DDataD Newtype <$> dsCxt cxt <*> pure n-                            <*> ((++ extra_tvbs) <$> mapM dsTvb tvbs)-                            <*> dsCon con <*> dsCxt derivings)-#else-dsDec (DataD cxt n tvbs cons derivings) =-  (:[]) <$> (DDataD Data <$> dsCxt cxt <*> pure n-                         <*> mapM dsTvb tvbs <*> concatMapM dsCon cons-                         <*> pure (map DConPr derivings))-dsDec (NewtypeD cxt n tvbs con derivings) =-  (:[]) <$> (DDataD Newtype <$> dsCxt cxt <*> pure n-                            <*> mapM dsTvb tvbs <*> dsCon con-                            <*> pure (map DConPr derivings))-#endif-dsDec (TySynD n tvbs ty) =-  (:[]) <$> (DTySynD n <$> mapM dsTvb tvbs <*> dsType ty)-dsDec (ClassD cxt n tvbs fds decs) =-  (:[]) <$> (DClassD <$> dsCxt cxt <*> pure n <*> mapM dsTvb tvbs-                     <*> pure fds <*> dsDecs decs)-#if __GLASGOW_HASKELL__ >= 711-dsDec (InstanceD over cxt ty decs) =-  (:[]) <$> (DInstanceD <$> pure over <*> dsCxt cxt <*> dsType ty <*> dsDecs decs)-#else-dsDec (InstanceD cxt ty decs) =-  (:[]) <$> (DInstanceD <$> pure Nothing <*> dsCxt cxt <*> dsType ty <*> dsDecs decs)-#endif-dsDec d@(SigD {}) = (fmap . map) DLetDec $ dsLetDec d-dsDec (ForeignD f) = (:[]) <$> (DForeignD <$> dsForeign f)-dsDec d@(InfixD {}) = (fmap . map) DLetDec $ dsLetDec d-dsDec (PragmaD prag) = (:[]) <$> (DPragmaD <$> dsPragma prag)-#if __GLASGOW_HASKELL__ > 710-dsDec (OpenTypeFamilyD tfHead) =-  (:[]) <$> (DOpenTypeFamilyD <$> dsTypeFamilyHead tfHead)-dsDec (DataFamilyD n tvbs m_k) = do-  extra_tvbs <- mkExtraTvbs tvbs m_k-  (:[]) <$> (DDataFamilyD n <$> ((++ extra_tvbs) <$> mapM dsTvb tvbs))-#else-dsDec (FamilyD TypeFam n tvbs m_k) = do-  (:[]) <$> (DOpenTypeFamilyD <$> dsTypeFamilyHead n tvbs m_k)-dsDec (FamilyD DataFam n tvbs m_k) = do-  extra_tvbs <- mkExtraTvbs tvbs m_k-  (:[]) <$> (DDataFamilyD n <$> ((++ extra_tvbs) <$> mapM dsTvb tvbs))-#endif-#if __GLASGOW_HASKELL__ > 710-dsDec (DataInstD cxt n tys mk cons derivings) = do-  extra_tvbs <- map dTyVarBndrToDType <$> mkExtraTvbs [] mk-  (:[]) <$> (DDataInstD Data <$> dsCxt cxt <*> pure n-                             <*> ((++ extra_tvbs) <$> mapM dsType tys)-                             <*> concatMapM dsCon cons-                             <*> dsCxt derivings)-dsDec (NewtypeInstD cxt n tys mk con derivings) = do-  extra_tvbs <- map dTyVarBndrToDType <$> mkExtraTvbs [] mk-  (:[]) <$> (DDataInstD Newtype <$> dsCxt cxt <*> pure n-                                <*> ((++ extra_tvbs) <$> mapM dsType tys)-                                <*> dsCon con-                                <*> dsCxt derivings)-#else-dsDec (DataInstD cxt n tys cons derivings) = do-  (:[]) <$> (DDataInstD Data <$> dsCxt cxt <*> pure n <*> mapM dsType tys-                             <*> concatMapM dsCon cons-                             <*> pure (map DConPr derivings))-dsDec (NewtypeInstD cxt n tys con derivings) = do-  (:[]) <$> (DDataInstD Newtype <$> dsCxt cxt <*> pure n <*> mapM dsType tys-                                <*> dsCon con <*> pure (map DConPr derivings))-#endif-#if __GLASGOW_HASKELL__ < 707-dsDec (TySynInstD n lhs rhs) = (:[]) <$> (DTySynInstD n <$>-                                          (DTySynEqn <$> mapM dsType lhs-                                                     <*> dsType rhs))-#else-dsDec (TySynInstD n eqn) = (:[]) <$> (DTySynInstD n <$> dsTySynEqn eqn)-#if __GLASGOW_HASKELL__ > 710-dsDec (ClosedTypeFamilyD tfHead eqns) =-  (:[]) <$> (DClosedTypeFamilyD <$> dsTypeFamilyHead tfHead-                                <*> mapM dsTySynEqn eqns)-#else-dsDec (ClosedTypeFamilyD n tvbs m_k eqns) = do-  (:[]) <$> (DClosedTypeFamilyD <$> dsTypeFamilyHead n tvbs m_k-                                <*> mapM dsTySynEqn eqns)-#endif-dsDec (RoleAnnotD n roles) = return [DRoleAnnotD n roles]-#endif-#if __GLASGOW_HASKELL__ >= 709-dsDec (StandaloneDerivD cxt ty) = (:[]) <$> (DStandaloneDerivD <$> dsCxt cxt-                                                               <*> dsType ty)-dsDec (DefaultSigD n ty) = (:[]) <$> (DDefaultSigD n <$> dsType ty)-#endif--mkExtraTvbs :: DsMonad q => [TyVarBndr] -> Maybe Kind -> q [DTyVarBndr]-mkExtraTvbs _         Nothing = return []-mkExtraTvbs orig_tvbs (Just k) = do-  k' <- runQ (expandSyns k)  -- just in case-  dk <- dsType k'-  let args = split_funs [] dk-      -- christiaanb: I have no idea how GHC normally picks fresh-      -- tyvars, this looks like something GHC might do. Though probably in a-      -- nicer/safer way.-      ---      -- RAE: It's actually not terribly far off from what GHC does. This is-      -- terrible. But I don't see another way to do this. <shudder>-      ---      -- All of this is needed so that "dec test 9" passes.-      orig_names = map (nameBase . tvbName) orig_tvbs-      all_names  =-#if __GLASGOW_HASKELL__ <= 708-                    map ('$':) $-#endif-                    take (length args + length orig_tvbs)-                        (map (:[]) ['a' .. 'z'] ++-                         concatMap (zipWith (:) ['a' .. 'z'] . repeat . show)-                                   [(0::Int)..])-      new_names  = filter (`notElem` orig_names) all_names-  names <- zipWithM (\n _ -> qNewName n) new_names args-  return (zipWith DKindedTV names args)-  where-    split_funs args (DAppT (DAppT DArrowT arg) res) = split_funs (arg:args) res-    split_funs args _other                          = reverse args--#if __GLASGOW_HASKELL__ > 710--- | Desugar a @FamilyResultSig@-dsFamilyResultSig :: DsMonad q => FamilyResultSig -> q DFamilyResultSig-dsFamilyResultSig NoSig          = return DNoSig-dsFamilyResultSig (KindSig k)    = DKindSig <$> dsType k-dsFamilyResultSig (TyVarSig tvb) = DTyVarSig <$> dsTvb tvb---- | Desugar a @TypeFamilyHead@-dsTypeFamilyHead :: DsMonad q => TypeFamilyHead -> q DTypeFamilyHead-dsTypeFamilyHead (TypeFamilyHead n tvbs result inj)-  = DTypeFamilyHead n <$> mapM dsTvb tvbs-                      <*> dsFamilyResultSig result-                      <*> pure inj-#else--- | Desugar bits and pieces into a 'DTypeFamilyHead'-dsTypeFamilyHead :: DsMonad q-                 => Name -> [TyVarBndr] -> Maybe Kind -> q DTypeFamilyHead-dsTypeFamilyHead n tvbs m_kind = do-  result_sig <- case m_kind of-    Nothing -> return DNoSig-    Just k  -> DKindSig <$> dsType k-  DTypeFamilyHead n <$> mapM dsTvb tvbs-                    <*> pure result_sig-                    <*> pure Nothing-#endif---- | Desugar @Dec@s that can appear in a let expression-dsLetDecs :: DsMonad q => [Dec] -> q [DLetDec]-dsLetDecs = concatMapM dsLetDec---- | Desugar a single @Dec@, perhaps producing multiple 'DLetDec's-dsLetDec :: DsMonad q => Dec -> q [DLetDec]-dsLetDec (FunD name clauses) = do-  clauses' <- dsClauses name clauses-  return [DFunD name clauses']-dsLetDec (ValD pat body where_decs) = do-  (pat', vars) <- dsPatX pat-  body' <- dsBody body where_decs error_exp-  let extras = uncurry (zipWith (DValD . DVarPa)) $ unzip vars-  return $ DValD pat' body' : extras-  where-    error_exp = DAppE (DVarE 'error) (DLitE-                       (StringL $ "Non-exhaustive patterns for " ++ pprint pat))-dsLetDec (SigD name ty) = do-  ty' <- dsType ty-  return [DSigD name ty']-dsLetDec (InfixD fixity name) = return [DInfixD fixity name]-dsLetDec _dec = impossible "Illegal declaration in let expression."---- | Desugar a single @Con@.-dsCon :: DsMonad q-      => Con -> q [DCon]-dsCon (NormalC n stys) =-  (:[]) <$> (DCon [] [] n <$> (DNormalC <$> mapM dsBangType stys) <*> pure Nothing)-dsCon (RecC n vstys) =-  (:[]) <$> (DCon [] [] n <$> (DRecC <$> mapM dsVarBangType vstys) <*> pure Nothing)-dsCon (InfixC sty1 n sty2) = do-  dty1 <- dsBangType sty1-  dty2 <- dsBangType sty2-  return $ [DCon [] [] n (DNormalC [dty1, dty2]) Nothing]-dsCon (ForallC tvbs cxt con) = do-  dtvbs <- mapM dsTvb tvbs-  dcxt <- dsCxt cxt-  dcons <- dsCon con-  return $ flip map dcons $ \(DCon dtvbs' dcxt' n fields m_kind) ->-    DCon (dtvbs ++ dtvbs') (dcxt ++ dcxt') n fields m_kind-#if __GLASGOW_HASKELL__ > 710-dsCon (GadtC nms btys rty) = do-  dbtys <- mapM dsBangType btys-  drty  <- dsType rty-  return $ flip map nms $ \nm ->-    DCon [] [] nm (DNormalC dbtys) (Just drty)-dsCon (RecGadtC nms vbtys rty) = do-  dvbtys <- mapM dsVarBangType vbtys-  drty   <- dsType rty-  return $ flip map nms $ \nm ->-    DCon [] [] nm (DRecC dvbtys) (Just drty)-#endif--#if __GLASGOW_HASKELL__ > 710--- | Desugar a @BangType@ (or a @StrictType@, if you're old-fashioned)-dsBangType :: DsMonad q => BangType -> q DBangType-dsBangType (b, ty) = (b, ) <$> dsType ty---- | Desugar a @VarBangType@ (or a @VarStrictType@, if you're old-fashioned)-dsVarBangType :: DsMonad q => VarBangType -> q DVarBangType-dsVarBangType (n, b, ty) = (n, b, ) <$> dsType ty-#else--- | Desugar a @BangType@ (or a @StrictType@, if you're old-fashioned)-dsBangType :: DsMonad q => StrictType -> q DBangType-dsBangType (b, ty) = (strictToBang b, ) <$> dsType ty---- | Desugar a @VarBangType@ (or a @VarStrictType@, if you're old-fashioned)-dsVarBangType :: DsMonad q => VarStrictType -> q DVarBangType-dsVarBangType (n, b, ty) = (n, strictToBang b, ) <$> dsType ty-#endif---- | 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-dsPragma (RuleP str rbs lhs rhs phases)  = DRuleP str <$> mapM dsRuleBndr rbs-                                                      <*> dsExp lhs-                                                      <*> dsExp rhs-                                                      <*> pure phases-#if __GLASGOW_HASKELL__ >= 707-dsPragma (AnnP target exp)               = DAnnP target <$> dsExp exp-#endif-#if __GLASGOW_HASKELL__ >= 709-dsPragma (LineP n str)                   = return $ DLineP n str-#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__ >= 707--- | Desugar a @TySynEqn@. (Available only with GHC 7.8+)-dsTySynEqn :: DsMonad q => TySynEqn -> q DTySynEqn-dsTySynEqn (TySynEqn lhs rhs) = DTySynEqn <$> mapM dsType lhs <*> dsType rhs-#endif---- | Desugar clauses to a function definition-dsClauses :: DsMonad q-          => Name         -- ^ Name of the function-          -> [Clause]     -- ^ Clauses to desugar-          -> q [DClause]-dsClauses _ [] = return []-dsClauses n (Clause pats (NormalB exp) where_decs : rest) = do-  -- this case is necessary to maintain the roundtrip property.-  rest' <- dsClauses n rest-  exp' <- dsExp exp-  where_decs' <- dsLetDecs where_decs-  let exp_with_wheres = maybeDLetE where_decs' exp'-  (pats', exp'') <- dsPatsOverExp pats exp_with_wheres-  return $ DClause pats' exp'' : rest'-dsClauses n clauses@(Clause outer_pats _ _ : _) = do-  arg_names <- replicateM (length outer_pats) (newUniqueName "arg")-  let scrutinee = mkTupleDExp (map DVarE arg_names)-  clause <- DClause (map DVarPa 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 ("Non-exhaustive patterns in " ++ (show n))-                                    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 (mkTupleDPat pats') exp'-      if uni_pats-      then return [match]-      else return (match : failure_matches)---- | Desugar a type-dsType :: DsMonad q => Type -> q DType-dsType (ForallT tvbs preds ty) = DForallT <$> mapM dsTvb 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 only difference between ConT and PromotedT is the name lookup. Here, we assume-  -- that the TH quote mechanism figured out the right name. Note that lookupDataName name-  -- does not necessarily work, because `name` has its original module attached, which-  -- may not be in scope.-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 DStarT-dsType ConstraintT = return $ DConT ''Constraint-dsType (LitT lit) = return $ DLitT lit-#if __GLASGOW_HASKELL__ >= 709-dsType EqualityT = return $ DConT ''(~)-#endif-#if __GLASGOW_HASKELL__ > 710-dsType (InfixT t1 n t2) = DAppT <$> (DAppT (DConT n) <$> dsType t1) <*> dsType t2-dsType (UInfixT _ _ _) = fail "Cannot desugar unresolved infix operators."-dsType (ParensT t) = dsType t-dsType WildCardT = return DWildCardT-#endif---- | Desugar a @TyVarBndr@-dsTvb :: DsMonad q => TyVarBndr -> q DTyVarBndr-dsTvb (PlainTV n) = return $ DPlainTV n-dsTvb (KindedTV n k) = DKindedTV n <$> dsType k---- | Desugar a @Cxt@-dsCxt :: DsMonad q => Cxt -> q DCxt-dsCxt = concatMapM dsPred---- | Desugar a @Pred@, flattening any internal tuples-dsPred :: DsMonad q => Pred -> q DCxt-#if __GLASGOW_HASKELL__ < 709-dsPred (ClassP n tys) = do-  ts' <- mapM dsType tys-  return [foldl DAppPr (DConPr n) ts']-dsPred (EqualP t1 t2) = do-  ts' <- mapM dsType [t1, t2]-  return [foldl DAppPr (DConPr ''(~)) ts']-#else-dsPred t-  | Just ts <- splitTuple_maybe t-  = concatMapM dsPred ts-dsPred t@(ForallT _ _ _) = impossible $ "Forall seen in constraint: " ++ show t-dsPred (AppT t1 t2) = do-  [p1] <- dsPred t1   -- tuples can't be applied!-  (:[]) <$> DAppPr p1 <$> dsType t2-dsPred (SigT ty ki) = do-  preds <- dsPred ty-  case preds of-    [p]   -> (:[]) <$> DSigPr p <$> dsType ki-    other -> return other   -- just drop the kind signature on a tuple.-dsPred (VarT n) = return [DVarPr n]-dsPred (ConT n) = return [DConPr n]-dsPred t@(PromotedT _) =-  impossible $ "Promoted type seen as head of constraint: " ++ show t-dsPred (TupleT 0) = return [DConPr (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 [DConPr ''(~)]-#if __GLASGOW_HASKELL__ > 710-dsPred (InfixT t1 n t2) = (:[]) <$> (DAppPr <$> (DAppPr (DConPr n) <$> dsType t1) <*> dsType t2)-dsPred (UInfixT _ _ _) = fail "Cannot desugar unresolved infix operators."-dsPred (ParensT t) = dsPred t-dsPred WildCardT = return [DWildCardPr]-#endif-#endif---- | Like 'reify', but safer and desugared. Uses local declarations where--- available.-dsReify :: DsMonad q => Name -> q (Maybe DInfo)-dsReify = traverse dsInfo <=< reifyWithLocals_maybe---- 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 => [VarStrictType] -> [FieldExp] -> [DExp] -> q [DExp]-reorderFields = reorderFields' dsExp--reorderFieldsPat :: DsMonad q => [VarStrictType] -> [FieldPat] -> PatM q [DPat]-reorderFieldsPat field_decs field_pats =-  reorderFields' dsPat field_decs field_pats (repeat DWildPa)--reorderFields' :: (Applicative m, Monad m)-               => (a -> m da)-               -> [VarStrictType] -> [(Name, a)]-               -> [da] -> m [da]-reorderFields' _ [] _ _ = return []-reorderFields' ds_thing ((field_name, _, _) : rest)-               field_things (deflt : rest_deflt) = do-  rest' <- reorderFields' ds_thing rest field_things rest_deflt-  case find (\(thing_name, _) -> thing_name == field_name) field_things of-    Just (_, thing) -> (: rest') <$> ds_thing thing-    Nothing -> return $ deflt : rest'-reorderFields' _ (_ : _) _ [] = error "Internal error in th-desugar."---- | 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 = DConPa (tupleDataName (length pats)) pats---- | Make a tuple 'Pat' from a list of 'Pat's. Avoids using a 1-tuple.-mkTuplePat :: [Pat] -> Pat-mkTuplePat [pat] = pat-mkTuplePat pats = ConP (tupleDataName (length pats)) pats---- | Is this pattern guaranteed to match?-isUniversalPattern :: DsMonad q => DPat -> q Bool-isUniversalPattern (DLitPa {}) = return False-isUniversalPattern (DVarPa {}) = return True-isUniversalPattern (DConPa 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 (DTildePa {}) = return True-isUniversalPattern (DBangPa pat) = isUniversalPattern pat-isUniversalPattern DWildPa       = 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 -> [DType] -> DType-applyDType = foldl DAppT---- | Convert a 'DTyVarBndr' into a 'DType'-dTyVarBndrToDType :: DTyVarBndr -> DType-dTyVarBndrToDType (DPlainTV a)    = DVarT a-dTyVarBndrToDType (DKindedTV a k) = DVarT a `DSigT` k---- | Convert a 'Strict' to a 'Bang' in GHCs 7.x. This is just--- the identity operation in GHC 8.x, which has no 'Strict'.--- (This is included in GHC 8.x only for good Haddocking.)-#if __GLASGOW_HASKELL__ <= 710-strictToBang :: Strict -> Bang-strictToBang IsStrict  = Bang NoSourceUnpackedness SourceStrict-strictToBang NotStrict = Bang NoSourceUnpackedness NoSourceStrictness-strictToBang Unpacked  = Bang SourceUnpack SourceStrict-#else-strictToBang :: Bang -> Bang-strictToBang = id-#endif+rae@cs.brynmawr.edu++Desugars full Template Haskell syntax into a smaller core syntax for further+processing. The desugared types and constructors are prefixed with a D.+-}++{-# LANGUAGE TemplateHaskellQuotes, LambdaCase, CPP, ScopedTypeVariables,+             TupleSections, DeriveDataTypeable, DeriveGeneric #-}++module Language.Haskell.TH.Desugar.Core where++import Prelude hiding (mapM, foldl, foldr, all, elem, exp, concatMap, and)++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/Expand.hs view
@@ -1,17 +1,17 @@ {- Language/Haskell/TH/Desugar/Expand.hs  (c) Richard Eisenberg 2013-eir@cis.upenn.edu+rae@cs.brynmawr.edu -} -{-# LANGUAGE CPP, NoMonomorphismRestriction #-}+{-# LANGUAGE NoMonomorphismRestriction, ScopedTypeVariables #-}  ----------------------------------------------------------------------------- -- | -- Module      :  Language.Haskell.TH.Desugar.Expand -- Copyright   :  (C) 2014 Richard Eisenberg -- License     :  BSD-style (see LICENSE)--- Maintainer  :  Richard Eisenberg (eir@cis.upenn.edu)+-- Maintainer  :  Ryan Scott -- Stability   :  experimental -- Portability :  non-portable --@@ -26,242 +26,175 @@   expand, expandType,    -- * Expand synonyms potentially unsoundly-  expandUnsoundly,--  -- * Capture-avoiding substitution-  substTy+  expandUnsoundly   ) where  import qualified Data.Map as M-import qualified Data.Set as S-import Control.Monad-#if __GLASGOW_HASKELL__ < 709-import Control.Applicative-#endif import Language.Haskell.TH hiding (cxt) import Language.Haskell.TH.Syntax ( Quasi(..) ) import Data.Data import Data.Generics-import Data.List import qualified Data.Traversable as T +import Language.Haskell.TH.Desugar.AST import Language.Haskell.TH.Desugar.Core import Language.Haskell.TH.Desugar.Util import Language.Haskell.TH.Desugar.Sweeten import Language.Haskell.TH.Desugar.Reify---- | Ignore kind annotations?-data IgnoreKinds = YesIgnore | NoIgnore+import Language.Haskell.TH.Desugar.Subst  -- | Expands all type synonyms in a desugared type. Also expands open type family--- applications, as long as the arguments have no free variables. Attempts to+-- applications. (In GHCs before 7.10, this part does not work if there are any+-- variables.) Attempts to -- expand closed type family applications, but aborts the moment it spots anything -- strange, like a nested type family application or type variable. expandType :: DsMonad q => DType -> q DType expandType = expand_type NoIgnore -expand_type :: DsMonad q => IgnoreKinds -> DType -> q DType+expand_type :: forall q. DsMonad q => IgnoreKinds -> DType -> q DType expand_type ign = go []   where-    go [] (DForallT tvbs cxt ty) =-      DForallT tvbs <$> mapM (expand_ ign) cxt <*> expand_type ign ty+    go :: [DTypeArg] -> DType -> q DType+    go [] (DForallT tele ty) =+      DForallT <$> expand_tele ign tele+               <*> expand_type ign ty     go _ (DForallT {}) =       impossible "A forall type is applied to another type."+    go [] (DConstrainedT cxt ty) =+      DConstrainedT <$> mapM (expand_type ign) cxt+                    <*> expand_type ign ty+    go _ (DConstrainedT {}) =+      impossible "A constrained type is applied to another type."     go args (DAppT t1 t2) = do       t2' <- expand_type ign t2-      go (t2' : args) t1+      go (DTANormal t2' : args) t1+    go args (DAppKindT p k) = do+      k' <- expand_type ign k+      go (DTyArg k' : args) p     go args (DSigT ty ki) = do       ty' <- go [] ty-      return $ foldl DAppT (DSigT ty' ki) args+      ki' <- go [] ki+      finish (DSigT ty' ki') args     go args (DConT n) = expand_con ign n args-    go args ty = return $ foldl DAppT ty args+    go args ty@(DVarT _)  = finish ty args+    go args ty@DArrowT    = finish ty args+    go args ty@(DLitT _)  = finish ty args+    go args ty@DWildCardT = finish ty args --- | Expands all type synonyms in a desugared predicate.-expand_pred :: DsMonad q => IgnoreKinds -> DPred -> q DPred-expand_pred ign = go []-  where-    go args (DAppPr p t) = do-      t' <- expand_type ign t-      go (t' : args) p-    go args (DSigPr p k) = do-      p' <- go [] p-      return $ foldl DAppPr (DSigPr p' k) args-    go args (DConPr n) = do-      ty <- expand_con ign n args-      dTypeToDPred ty-    go args p = return $ foldl DAppPr p args+    finish :: DType -> [DTypeArg] -> q DType+    finish ty args = return $ applyDType ty args +-- | Expands all type synonyms in the kinds of a @forall@ telescope.+expand_tele :: DsMonad q => IgnoreKinds -> DForallTelescope -> q DForallTelescope+expand_tele ign (DForallVis   tvbs) = DForallVis   <$> mapM (expand_tvb ign) tvbs+expand_tele ign (DForallInvis tvbs) = DForallInvis <$> mapM (expand_tvb ign) tvbs++-- | Expands all type synonyms in a type variable binder's kind.+expand_tvb :: DsMonad q => IgnoreKinds -> DTyVarBndr flag -> q (DTyVarBndr flag)+expand_tvb _   tvb@DPlainTV{}       = pure tvb+expand_tvb ign (DKindedTV n flag k) = DKindedTV n flag <$> expand_type ign k+ -- | Expand a constructor with given arguments-expand_con :: DsMonad q+expand_con :: forall q.+              DsMonad q            => IgnoreKinds-           -> Name     -- ^ Tycon name-           -> [DType]  -- ^ Arguments-           -> q DType  -- ^ Expanded type+           -> Name       -- ^ Tycon name+           -> [DTypeArg] -- ^ Arguments+           -> q DType    -- ^ Expanded type expand_con ign n args = do   info <- reifyWithLocals n-  dinfo <- dsInfo info-  args_ok <- allM no_tyvars_tyfams args-  case dinfo of-    DTyConI (DTySynD _n tvbs rhs) _-      |  length args >= length tvbs   -- this should always be true!-      -> do-        let (syn_args, rest_args) = splitAtList tvbs args-        ty <- substTy (M.fromList $ zip (map extractDTvbName tvbs) syn_args) rhs-        ty' <- expand_type ign ty-        return $ foldl DAppT ty' rest_args+  case info of+    TyConI (TySynD _ _ StarT)+         -- See Note [Don't expand synonyms for *]+      -> return $ applyDType (DConT typeKindName) args+    _ -> go info+  where+    -- Only the normal (i.e., non-visibly applied) arguments. These are+    -- important since we need to align these with the arguments of the type+    -- synonym/family, and visible kind arguments can mess with this.+    normal_args :: [DType]+    normal_args = filterDTANormals args -    DTyConI (DOpenTypeFamilyD (DTypeFamilyHead _n tvbs _frs _ann)) _-      |  length args >= length tvbs   -- this should always be true!-      ,  args_ok-      -> do-        let (syn_args, rest_args) = splitAtList tvbs args-        -- need to get the correct instance-        insts <- qReifyInstances n (map typeToTH syn_args)-        dinsts <- dsDecs insts-        case dinsts of-          [DTySynInstD _n (DTySynEqn lhs rhs)] -> do-            subst <--              expectJustM "Impossible: reification returned a bogus instance" $-              merge_maps $ zipWith build_subst lhs syn_args-            ty <- substTy subst rhs+    go :: Info -> q DType+    go info = do+      dinfo <- dsInfo info+      case dinfo of+        DTyConI (DTySynD _n tvbs rhs) _+          |  length normal_args >= length tvbs   -- this should always be true!+          -> do+            let (syn_args, rest_args) = splitAtList tvbs normal_args+            ty <- substTy (M.fromList $ zip (map dtvbName tvbs) syn_args) rhs             ty' <- expand_type ign ty-            return $ foldl DAppT ty' rest_args-          _ -> return $ foldl DAppT (DConT n) args+            return $ applyDType ty' $ map DTANormal rest_args +        DTyConI (DOpenTypeFamilyD (DTypeFamilyHead _n tvbs _frs _ann)) _+          |  length normal_args >= length tvbs   -- this should always be true!+          -> do+            let (syn_args, rest_args) = splitAtList tvbs normal_args+            -- We need to get the correct instance. If we fail to reify anything+            -- (e.g., if a type family is quasiquoted), then fall back by+            -- pretending that there are no instances in scope.+            insts <- qRecover (return []) $+                     qReifyInstances n (map typeToTH syn_args)+            dinsts <- dsDecs insts+            case dinsts of+              [DTySynInstD (DTySynEqn _ lhs rhs)]+                |  (_, lhs_args) <- unfoldDType lhs+                ,  let lhs_normal_args = filterDTANormals lhs_args+                ,  Just subst <-+                     unionMaybeSubsts $ zipWith (matchTy ign) lhs_normal_args syn_args+                -> do ty <- substTy subst rhs+                      ty' <- expand_type ign ty+                      return $ applyDType ty' $ map DTANormal rest_args+              _ -> give_up -    DTyConI (DClosedTypeFamilyD (DTypeFamilyHead _n tvbs _frs _ann) eqns) _-      |  length args >= length tvbs-      ,  args_ok-      -> do-        let (syn_args, rest_args) = splitAtList tvbs args-        rhss <- mapMaybeM (check_eqn syn_args) eqns-        case rhss of-          (rhs : _) -> do-            rhs' <- expand_type ign rhs-            return $ foldl DAppT rhs' rest_args-          [] -> return $ foldl DAppT (DConT n) args -      where-         -- returns the substed rhs-        check_eqn :: DsMonad q => [DType] -> DTySynEqn -> q (Maybe DType)-        check_eqn arg_tys (DTySynEqn lhs rhs) = do-          let m_subst = merge_maps $ zipWith build_subst lhs arg_tys-          T.mapM (flip substTy rhs) m_subst--    _ -> return $ foldl DAppT (DConT n) args--  where-    no_tyvars_tyfams :: (DsMonad q, Data a) => a -> q Bool-    no_tyvars_tyfams = everything (liftM2 (&&)) (mkQ (return True) no_tyvar_tyfam)--    no_tyvar_tyfam :: DsMonad q => DType -> q Bool-    no_tyvar_tyfam (DVarT _) = return False-    no_tyvar_tyfam (DConT con_name) = do-      m_info <- dsReify con_name-      return $ case m_info of-        Nothing -> False   -- we don't know anything. False is safe.-        Just (DTyConI (DOpenTypeFamilyD {}) _)   -> False-        Just (DTyConI (DDataFamilyD {}) _)       -> False-        Just (DTyConI (DClosedTypeFamilyD {}) _) -> False-        _                                        -> True-    no_tyvar_tyfam t = gmapQl (liftM2 (&&)) (return True) no_tyvars_tyfams t--    build_subst :: DType -> DType -> Maybe (M.Map Name DType)-    build_subst (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.-    build_subst (DSigT ty _ki) arg = case ign of-      YesIgnore -> build_subst ty arg-      NoIgnore  -> Nothing-      -- but we can safely ignore kind signatures on the target-    build_subst pat (DSigT ty _ki) = build_subst pat ty-    build_subst (DForallT {}) _ =-      error "Impossible: forall-quantified pattern to type family"-      -- reifyInstances should fail if an argument is forall-quantified.-    build_subst _ (DForallT {}) =-      error "Impossible: forall-quantified argument to type family"-    build_subst (DAppT pat1 pat2) (DAppT arg1 arg2) =-      merge_maps [build_subst pat1 arg1, build_subst pat2 arg2]-    build_subst (DConT pat_con) (DConT arg_con)-      | pat_con == arg_con = Just M.empty-    build_subst DArrowT DArrowT = Just M.empty-    build_subst (DLitT pat_lit) (DLitT arg_lit)-      | pat_lit == arg_lit = Just M.empty-    build_subst _ _ = Nothing--    merge_maps :: [Maybe (M.Map Name DType)] -> Maybe (M.Map Name DType)-    merge_maps = foldl' merge_map1 (Just M.empty)--    merge_map1 :: Maybe (M.Map Name DType) -> Maybe (M.Map Name DType)-               -> Maybe (M.Map Name DType)-    merge_map1 ma mb = do-      a <- ma-      b <- mb-      let shared_key_set = M.keysSet a `S.intersection` M.keysSet b-          matches_up     = S.foldr (\name -> ((a M.! name) `geq` (b M.! name) &&))-                                   True shared_key_set-      if matches_up then return (a `M.union` b) else Nothing+        DTyConI (DClosedTypeFamilyD (DTypeFamilyHead _n tvbs _frs _ann) eqns) _+          |  length normal_args >= length tvbs+          -> do+            let (syn_args, rest_args) = splitAtList tvbs normal_args+            rhss <- mapMaybeM (check_eqn syn_args) eqns+            case rhss of+              (rhs : _) -> do+                rhs' <- expand_type ign rhs+                return $ applyDType rhs' $ map DTANormal rest_args+              [] -> give_up -    allM :: Monad m => (a -> m Bool) -> [a] -> m Bool-    allM f = foldM (\b x -> (b &&) `liftM` f x) True+          where+             -- returns the substed rhs+            check_eqn :: [DType] -> DTySynEqn -> q (Maybe DType)+            check_eqn arg_tys (DTySynEqn _ lhs rhs) = do+              let (_, lhs_args) = unfoldDType lhs+                  normal_lhs_args = filterDTANormals lhs_args+                  m_subst = unionMaybeSubsts $ zipWith (matchTy ign) normal_lhs_args arg_tys+              T.mapM (flip substTy rhs) m_subst --- | Capture-avoiding substitution on types-substTy :: DsMonad q => M.Map Name DType -> DType -> q DType-substTy vars (DForallT tvbs cxt ty) =-  substTyVarBndrs vars tvbs $ \vars' tvbs' -> do-    cxt' <- mapM (substPred vars') cxt-    ty' <- substTy vars' ty-    return $ DForallT tvbs' cxt' ty'-substTy vars (DAppT t1 t2) =-  DAppT <$> substTy vars t1 <*> substTy vars t2-substTy vars (DSigT ty ki) =-  DSigT <$> substTy vars ty <*> pure ki-substTy vars (DVarT n)-  | Just ty <- M.lookup n vars-  = return ty-  | otherwise-  = return $ DVarT n-substTy _ ty = return ty+        _ -> give_up -substTyVarBndrs :: DsMonad q => M.Map Name DType -> [DTyVarBndr]-                -> (M.Map Name DType -> [DTyVarBndr] -> q DType)-                -> q DType-substTyVarBndrs vars tvbs thing = do-  new_names <- mapM (const (qNewName "local")) tvbs-  let new_vars = M.fromList (zip (map extractDTvbName tvbs) (map DVarT new_names))-  -- this is very inefficient. Oh well.-  thing (M.union vars new_vars) (zipWith substTvb tvbs new_names)+    -- Used when we can't proceed with type family instance expansion any more,+    -- and must conservatively return the orignal type family applied to its+    -- arguments.+    give_up :: q DType+    give_up = return $ applyDType (DConT n) args -substTvb :: DTyVarBndr -> Name -> DTyVarBndr-substTvb (DPlainTV _) n = DPlainTV n-substTvb (DKindedTV _ k) n = DKindedTV n k+{-+Note [Don't expand synonyms for *]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We deliberately avoid expanding type synonyms for * such as Type and ★.+Why? If you reify any such type synonym using Template Haskell, this is+what you'll get: --- | Extract the name from a @TyVarBndr@-extractDTvbName :: DTyVarBndr -> Name-extractDTvbName (DPlainTV n) = n-extractDTvbName (DKindedTV n _) = n+  TyConI (TySynD <type synonym name> [] StarT) -substPred :: DsMonad q => M.Map Name DType -> DPred -> q DPred-substPred vars (DAppPr p t) = DAppPr <$> substPred vars p <*> substTy vars t-substPred vars (DSigPr p k) = DSigPr <$> substPred vars p <*> pure k-substPred vars (DVarPr n)-  | Just ty <- M.lookup n vars-  = dTypeToDPred ty-  | otherwise-  = return $ DVarPr n-substPred _ p = return p+If you blindly charge ahead and recursively inspect the right-hand side of+this type synonym, you'll desugar StarT into (DConT ''Type), reify ''Type,+and get back another type synonym with StarT as its right-hand side. Then+you'll recursively inspect StarT and find yourself knee-deep in an infinite+loop. --- | Convert a 'DType' to a 'DPred'-dTypeToDPred :: DsMonad q => DType -> q DPred-dTypeToDPred (DForallT _ _ _) = impossible "Forall-type used as constraint"-dTypeToDPred (DAppT t1 t2)   = DAppPr <$> dTypeToDPred t1 <*> pure t2-dTypeToDPred (DSigT ty ki)   = DSigPr <$> dTypeToDPred ty <*> pure ki-dTypeToDPred (DVarT n)       = return $ DVarPr n-dTypeToDPred (DConT n)       = return $ DConPr n-dTypeToDPred DArrowT         = impossible "Arrow used as head of constraint"-dTypeToDPred (DLitT _)       = impossible "Type literal used as head of constraint"-dTypeToDPred DWildCardT      = return DWildCardPr-dTypeToDPred DStarT          = impossible "Star used as head of constraint"+To prevent these sorts of shenanigans, we simply stop whenever we see a type+synonym with StarT as its right-hand side and return Type.+-}  -- | Expand all type synonyms and type families in the desugared abstract -- syntax tree provided, where type family simplification is on a "best effort"@@ -290,4 +223,4 @@  -- | Generalization of 'expand' that either can or won't ignore kind annotations.sx expand_ :: (DsMonad q, Data a) => IgnoreKinds -> a -> q a-expand_ ign = everywhereM (mkM (expand_type ign) >=> mkM (expand_pred ign))+expand_ ign = everywhereM (mkM (expand_type ign))
+ Language/Haskell/TH/Desugar/FV.hs view
@@ -0,0 +1,76 @@+{- Language/Haskell/TH/Desugar/FV.hs++(c) Ryan Scott 2018++Compute free variables of programs.+-}++{-# LANGUAGE CPP #-}+module Language.Haskell.TH.Desugar.FV+  ( fvDType+  , extractBoundNamesDPat+  ) where++#if __GLASGOW_HASKELL__ < 804+import Data.Monoid ((<>))+#endif+import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Desugar.AST+import qualified Language.Haskell.TH.Desugar.OSet as OS+import Language.Haskell.TH.Desugar.OSet (OSet)++-- | Compute the free variables of a 'DType'.+fvDType :: DType -> OSet Name+fvDType = go+  where+    go :: DType -> OSet Name+    go (DForallT tele ty)      = fv_dtele tele (go ty)+    go (DConstrainedT ctxt ty) = foldMap fvDType ctxt <> go ty+    go (DAppT t1 t2)           = go t1 <> go t2+    go (DAppKindT t k)         = go t <> go k+    go (DSigT ty ki)           = go ty <> go ki+    go (DVarT n)               = OS.singleton n+    go (DConT {})              = OS.empty+    go DArrowT                 = OS.empty+    go (DLitT {})              = OS.empty+    go DWildCardT              = OS.empty++-----+-- Extracting bound term names+-----++-- | Extract the term variables bound by a 'DPat'.+--+-- 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 _ _ 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+-----++-- | Adjust the free variables of something following a 'DForallTelescope'.+fv_dtele :: DForallTelescope -> OSet Name -> OSet Name+fv_dtele (DForallVis   tvbs) = fv_dtvbs tvbs+fv_dtele (DForallInvis tvbs) = fv_dtvbs tvbs++-- | Adjust the free variables of something following 'DTyVarBndr's.+fv_dtvbs :: [DTyVarBndr flag] -> OSet Name -> OSet Name+fv_dtvbs tvbs fvs = foldr fv_dtvb fvs tvbs++-- | Adjust the free variables of something following a 'DTyVarBndr'.+fv_dtvb :: DTyVarBndr flag -> OSet Name -> OSet Name+fv_dtvb (DPlainTV n _)    fvs = OS.delete n fvs+fv_dtvb (DKindedTV n _ k) fvs = OS.delete n fvs <> fvDType k
Language/Haskell/TH/Desugar/Lift.hs view
@@ -3,36 +3,16 @@ -- Module      :  Language.Haskell.TH.Desugar.Lift -- Copyright   :  (C) 2014 Richard Eisenberg -- License     :  BSD-style (see LICENSE)--- Maintainer  :  Richard Eisenberg (eir@cis.upenn.edu)+-- Maintainer  :  Ryan Scott -- 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 -fno-warn-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, ''DPred, ''DTyVarBndr-                 , ''DMatch, ''DClause, ''DLetDec, ''DDec, ''DCon-                 , ''DConFields, ''DForeign, ''DPragma, ''DRuleBndr, ''DTySynEqn-                 , ''NewOrData-#if __GLASGOW_HASKELL__ < 707-                 , ''AnnTarget, ''Role-#endif-                 , ''DTypeFamilyHead,  ''DFamilyResultSig-#if __GLASGOW_HASKELL__ <= 710-                 , ''InjectivityAnn, ''Bang, ''SourceUnpackedness-                 , ''SourceStrictness, ''Overlap-#endif-                 ])+import Language.Haskell.TH.Desugar ()
Language/Haskell/TH/Desugar/Match.hs view
@@ -1,7 +1,7 @@ {- Language/Haskell/TH/Desugar/Match.hs  (c) Richard Eisenberg 2013-eir@cis.upenn.edu+rae@cs.brynmawr.edu  Simplifies case statements in desugared TH. After this pass, there are no more nested patterns.@@ -9,27 +9,28 @@ This code is directly based on the analogous operation as written in GHC. -} -{-# LANGUAGE CPP, TemplateHaskell #-}--#if __GLASGOW_HASKELL__ <= 708-{-# LANGUAGE StandaloneDeriving #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}   -- we need Ord Lit. argh.-#endif+{-# LANGUAGE CPP, TemplateHaskellQuotes #-}  module Language.Haskell.TH.Desugar.Match (scExp, scLetDec) where  import Prelude hiding ( fail, exp ) -#if __GLASGOW_HASKELL__ < 709-import Control.Applicative-#endif import Control.Monad hiding ( fail )+import qualified Control.Monad as Monad+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 () import Language.Haskell.TH.Syntax -import Language.Haskell.TH.Desugar.Core+import Language.Haskell.TH.Desugar.AST+import Language.Haskell.TH.Desugar.Core (dsReify, maybeDLetE, mkTupleDExp)+import Language.Haskell.TH.Desugar.FV+import qualified Language.Haskell.TH.Desugar.OSet as OS import Language.Haskell.TH.Desugar.Util import Language.Haskell.TH.Desugar.Reify @@ -39,34 +40,65 @@ -- 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 (DVarPa 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 e = return e+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+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++-- | 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'-  return $ DFunD name [DClause (map DVarPa arg_names) case_exp]+  pure $ DClause (map DVarP arg_names) case_exp   where     sc_clause_rhs (DClause pats exp) = DClause pats <$> scExp exp-scLetDec (DValD pat exp) = DValD pat <$> scExp exp-scLetDec dec = return dec +scLetPragma :: DsMonad q => DPragma -> q DPragma+scLetPragma = topEverywhereM scExp -- Only topEverywhereM because scExp already recurses on its own+ type MatchResult = DExp -> DExp  matchResultToDExp :: MatchResult -> DExp@@ -80,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@@ -94,77 +132,124 @@ 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 ...       -> DPat   -- ... this pattern is matching against       -> q (DExp -> DExp, DPat)   -- a wrapper and tidied pattern-tidy1 _ p@(DLitPa {}) = return (id, p)-tidy1 v (DVarPa var) = return (wrapBind var v, DWildPa)-tidy1 _ p@(DConPa {}) = return (id, p)-tidy1 v (DTildePa pat) = do+tidy1 _ p@(DLitP {}) = return (id, p)+tidy1 v (DVarP var) = return (wrapBind var v, DWildP)+tidy1 _ p@(DConP {}) = return (id, p)+tidy1 v (DTildeP pat) = do   sel_decs <- mkSelectorDecs pat v-  return (maybeDLetE sel_decs, DWildPa)-tidy1 v (DBangPa pat) =+  return (maybeDLetE sel_decs, DWildP)+tidy1 v (DBangP pat) =   case pat of-    DLitPa _   -> tidy1 v pat   -- already strict-    DVarPa _   -> return (id, DBangPa pat)  -- no change-    DConPa _ _ -> tidy1 v pat   -- already strict-    DTildePa p -> tidy1 v (DBangPa p) -- discard ~ under !-    DBangPa p  -> tidy1 v (DBangPa p) -- discard ! under !-    DWildPa    -> return (id, DBangPa pat)  -- no change-tidy1 _ DWildPa = return (id, DWildPa)+    DLitP _   -> tidy1 v pat   -- already strict+    DVarP _   -> return (id, DBangP pat)  -- no change+    DConP{}   -> tidy1 v pat   -- already strict+    DTildeP p -> tidy1 v (DBangP p) -- discard ~ under !+    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+  -- type variables properly, so we give up if we encounter one.+  -- See https://github.com/goldfirere/th-desugar/pull/48#issuecomment-266778976+  -- for further discussion.+  | otherwise = Monad.fail+    "Match-flattening patterns that mention type variables is not supported."+  where+    no_tyvars_ty :: Data a => a -> Bool+    no_tyvars_ty = everything (&&) (mkQ True no_tyvar_ty) +    no_tyvar_ty :: DType -> Bool+    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 (DVarPa new) (DVarE old)]+  | 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                -> q [DLetDec]-mkSelectorDecs (DVarPa v) name = return [DValD (DVarPa v) (DVarE name)]+mkSelectorDecs (DVarP v) name = return [DValD (DVarP v) (DVarE name)] mkSelectorDecs pat name-  | S.null binders+  | OS.null binders   = return [] -  | S.size binders == 1+  | [binder] <- F.toList binders   = do val_var <- newUniqueName "var"        err_var <- newUniqueName "err"-       bind    <- mk_bind val_var err_var (head $ S.elems binders)-       return [DValD (DVarPa val_var) (DVarE name),-               DValD (DVarPa err_var) (DVarE 'error `DAppE`+       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")),                bind] @@ -172,12 +257,12 @@   = do tuple_expr <- simplCaseExp [name] [DClause [pat] local_tuple]        tuple_var <- newUniqueName "tuple"        projections <- mapM (mk_projection tuple_var) [0 .. tuple_size-1]-       return (DValD (DVarPa tuple_var) tuple_expr :-               zipWith DValD (map DVarPa binders_list) projections)+       return (DValD (DVarP tuple_var) tuple_expr :+               zipWith DValD (map DVarP binders_list) projections)    where     binders = extractBoundNamesDPat pat-    binders_list = S.toAscList binders+    binders_list = F.toList binders     tuple_size = length binders_list     local_tuple = mkTupleDExp (map DVarE binders_list) @@ -187,25 +272,17 @@                   -> q DExp     mk_projection tup_name i = do       var_name <- newUniqueName "proj"-      return $ DCaseE (DVarE tup_name) [DMatch (DConPa (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                   -> Int    -- which element to get (0-indexed)                   -> [DPat]-    mk_tuple_pats elt_name i = replicate i DWildPa ++ DVarPa elt_name : replicate (tuple_size - i - 1) DWildPa+    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)]-      return (DValD (DVarPa bndr_var) (rhs_mr (DVarE err_var)))--extractBoundNamesDPat :: DPat -> S.Set Name-extractBoundNamesDPat (DLitPa _)      = S.empty-extractBoundNamesDPat (DVarPa n)      = S.singleton n-extractBoundNamesDPat (DConPa _ pats) = S.unions (map extractBoundNamesDPat pats)-extractBoundNamesDPat (DTildePa p)    = extractBoundNamesDPat p-extractBoundNamesDPat (DBangPa p)     = extractBoundNamesDPat p-extractBoundNamesDPat DWildPa         = S.empty+      rhs_mr <- simplCase [scrut_var] [EquationInfo (pat:|[]) (\_ -> DVarE bndr_var)]+      return (DValD (DVarP bndr_var) (rhs_mr (DVarE err_var)))  data PatGroup   = PgAny         -- immediate match (wilds, vars, lazies)@@ -214,20 +291,23 @@   | 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  patGroup :: DPat -> PatGroup-patGroup (DLitPa l)     = PgLit l-patGroup (DVarPa {})    = error "Internal error in th-desugar (patGroup DVarP)"-patGroup (DConPa con _) = PgCon con-patGroup (DTildePa {})  = error "Internal error in th-desugar (patGroup DTildeP)"-patGroup (DBangPa {})   = PgBang-patGroup DWildPa        = PgAny+patGroup (DLitP l)       = PgLit l+patGroup (DVarP {})      = error "Internal error in th-desugar (patGroup DVarP)"+patGroup (DConP con _ _) = PgCon con+patGroup (DTildeP {})    = error "Internal error in th-desugar (patGroup DTildeP)"+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@@ -236,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@@ -255,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 @@ -271,35 +352,43 @@   where     pat1 = firstPat eqn1 -    pat_args (DConPa _ pats) = pats-    pat_args _               = error "Internal error in th-desugar (pat_args)"+    pat_args (DConP _ _ pats) = pats+    pat_args _                = error "Internal error in th-desugar (pat_args)" -    pat_con (DConPa con _) = con-    pat_con _              = error "Internal error in th-desugar (pat_con)"+    pat_con (DConP con _ _) = con+    pat_con _               = error "Internal error in th-desugar (pat_con)"      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 (DConPa _ 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 (DConPa con (map DVarPa args)) body+        DMatch (DConP con [] (map DVarP args)) body      mk_default all_ctors fail | exhaustive_case all_ctors = []-                              | otherwise       = [DMatch DWildPa fail]+                              | 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)@@ -308,68 +397,72 @@       Just (DTyConI tycon_dec _) <- dsReify ty_name       return $ S.fromList $ map get_con_name $ get_cons tycon_dec -    get_cons (DDataD _ _ _ _ cons _)     = cons-    get_cons (DDataInstD _ _ _ _ cons _) = cons-    get_cons _                           = []+    get_cons (DDataD _ _ _ _ _ cons _)     = cons+    get_cons (DDataInstD _ _ _ _ _ cons _) = cons+    get_cons _                             = []      get_con_name (DCon _ _ n _ _) = n  matchEmpty :: DsMonad q => Name -> q [MatchResult] matchEmpty var = return [mk_seq]   where-    mk_seq fail = DCaseE (DVarE var) [DMatch DWildPa 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 DLitPa lit = firstPat (head eqns)-           match_result <- simplCase vars (shiftEqns eqns)+      = 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 $ 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 DWildPa 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 (DLitPa lit) (body_fn fail)+      = 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 (DBangPa p) = p-getBangPat _           = error "Internal error in th-desugar (getBangPat)"+getBangPat (DBangP p) = p+getBangPat _          = error "Internal error in th-desugar (getBangPat)"  mkEvalMatchResult :: Name -> MatchResult -> MatchResult 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@@ -380,13 +473,7 @@  -- from DsUtils selectMatchVar :: DsMonad q => DPat -> q Name-selectMatchVar (DBangPa pat)  = selectMatchVar pat-selectMatchVar (DTildePa pat) = selectMatchVar pat-selectMatchVar (DVarPa 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)+selectMatchVar (DBangP pat)  = selectMatchVar pat+selectMatchVar (DTildeP pat) = selectMatchVar pat+selectMatchVar (DVarP var)   = newUniqueName ('_' : nameBase var)+selectMatchVar _             = newUniqueName "_pat"
+ Language/Haskell/TH/Desugar/OMap.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Language.Haskell.TH.Desugar.OMap+-- Copyright   :  (C) 2016-2018 Daniel Wagner, 2019 Ryan Scott+-- License     :  BSD-style (see LICENSE)+-- Maintainer  :  Ryan Scott+-- Stability   :  experimental+-- Portability :  non-portable+--+-- An 'OMap' behaves much like a 'M.Map', with all the same asymptotics, but+-- also remembers the order that keys were inserted.+--+-- This module offers a simplified version of the "Data.Map.Ordered" API+-- that assumes left-biased indices everywhere and uses a different 'Semigroup'+-- instance (the one in this module uses @('<>') = 'union'@) and 'Monoid'+-- instance (the one in this module uses @'mappend' = 'union'@).+--+----------------------------------------------------------------------------+module Language.Haskell.TH.Desugar.OMap+    ( OMap(..)+    -- * Trivial maps+    , empty, singleton+    -- * Insertion+    , insertPre, insertPost, union, unionWithKey+    -- * Deletion+    , delete, filterWithKey, (\\), intersection, intersectionWithKey+    -- * Query+    , null, size, member, notMember, lookup+    -- * Indexing+    , Index, lookupIndex, lookupAt+    -- * List conversions+    , fromList, assocs, toAscList+    -- * 'M.Map' conversion+    , toMap+    ) where++import Data.Coerce+import Data.Data+import qualified Data.Map.Lazy as M (Map)+import Data.Map.Ordered (Bias(..), Index, L)+import qualified Data.Map.Ordered as OM+import Prelude hiding (filter, lookup, null)++#if !(MIN_VERSION_base(4,11,0))+import Data.Semigroup (Semigroup(..))+#endif++-- | An ordered map whose 'insertPre', 'insertPost', 'intersection',+-- 'intersectionWithKey', 'union', and 'unionWithKey' operations are biased+-- towards leftmost indices when when breaking ties between keys.+newtype OMap k v = OMap (Bias L (OM.OMap k v))+  deriving (Data, Foldable, Functor, Eq, Ord, Read, Show, Traversable)++instance Ord k => Semigroup (OMap k v) where+  (<>) = union+instance Ord k => Monoid (OMap k v) where+  mempty = empty+#if !(MIN_VERSION_base(4,11,0))+  mappend = (<>)+#endif++empty :: forall k v. OMap k v+empty = coerce (OM.empty @k @v)++singleton :: k -> v -> OMap k v+singleton k v = coerce (OM.singleton (k, v))++-- | The value's index will be lower than the indices of the values in the+-- 'OSet'.+insertPre :: Ord k => k -> v -> OMap k v -> OMap k v+insertPre k v = coerce ((k, v) OM.|<)++-- | The value's index will be higher than the indices of the values in the+-- 'OSet'.+insertPost :: Ord k => OMap k v -> k -> v -> OMap k v+insertPost m k v = coerce (coerce m OM.|> (k, v))++union :: forall k v. Ord k => OMap k v -> OMap k v -> OMap k v+union = coerce ((OM.|<>) @k @v)++unionWithKey :: Ord k => (k -> v -> v -> v) -> OMap k v -> OMap k v -> OMap k v+unionWithKey f = coerce (OM.unionWithL f)++delete :: forall k v. Ord k => k -> OMap k v -> OMap k v+delete = coerce (OM.delete @k @v)++filterWithKey :: Ord k => (k -> v -> Bool) -> OMap k v -> OMap k v+filterWithKey f = coerce (OM.filter f)++(\\) :: forall k v v'. Ord k => OMap k v -> OMap k v' -> OMap k v+(\\) = coerce ((OM.\\) @k @v @v')++intersection :: forall k v v'. Ord k => OMap k v -> OMap k v' -> OMap k v+intersection = coerce ((OM.|/\) @k @v @v')++intersectionWithKey :: Ord k => (k -> v -> v' -> v'') -> OMap k v -> OMap k v' -> OMap k v''+intersectionWithKey f = coerce (OM.intersectionWith f)++null :: forall k v. OMap k v -> Bool+null = coerce (OM.null @k @v)++size :: forall k v. OMap k v -> Int+size = coerce (OM.size @k @v)++member :: forall k v. Ord k => k -> OMap k v -> Bool+member = coerce (OM.member @k @v)++notMember :: forall k v. Ord k => k -> OMap k v -> Bool+notMember = coerce (OM.notMember @k @v)++lookup :: forall k v. Ord k => k -> OMap k v -> Maybe v+lookup = coerce (OM.lookup @k @v)++lookupIndex :: forall k v. Ord k => k -> OMap k v -> Maybe Index+lookupIndex = coerce (OM.findIndex @k @v)++lookupAt :: forall k v. Index -> OMap k v -> Maybe (k, v)+lookupAt i m = OM.elemAt @k @v (coerce m) i++fromList :: Ord k => [(k, v)] -> OMap k v+fromList l = coerce (OM.fromList l)++assocs :: forall k v. OMap k v -> [(k, v)]+assocs = coerce (OM.assocs @k @v)++toAscList :: forall k v. OMap k v -> [(k, v)]+toAscList = coerce (OM.toAscList @k @v)++toMap :: forall k v. OMap k v -> M.Map k v+toMap = coerce (OM.toMap @k @v)
+ Language/Haskell/TH/Desugar/OMap/Strict.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Language.Haskell.TH.Desugar.OMap+-- Copyright   :  (C) 2016-2018 Daniel Wagner, 2019 Ryan Scott+-- License     :  BSD-style (see LICENSE)+-- Maintainer  :  Ryan Scott+-- Stability   :  experimental+-- Portability :  non-portable+--+-- An 'OMap' behaves much like a 'M.Map', with all the same asymptotics, but+-- also remembers the order that keys were inserted.+--+-- This module offers a simplified version of the "Data.Map.Ordered.Strict" API+-- that assumes left-biased indices everywhere and uses a different 'Semigroup'+-- instance (the one in this module uses @('<>') = 'union'@) and 'Monoid'+-- instance (the one in this module uses @'mappend' = 'union'@).+--+----------------------------------------------------------------------------+module Language.Haskell.TH.Desugar.OMap.Strict+    ( OMap(..)+    -- * Trivial maps+    , empty, singleton+    -- * Insertion+    , insertPre, insertPost, union, unionWithKey+    -- * Deletion+    , delete, filterWithKey, (\\), intersection, intersectionWithKey+    -- * Query+    , null, size, member, notMember, lookup+    -- * Indexing+    , Index, lookupIndex, lookupAt+    -- * List conversions+    , fromList, assocs, toAscList+    -- * 'M.Map' conversion+    , toMap+    ) where++import Data.Coerce+import qualified Data.Map.Strict as M (Map)+import Data.Map.Ordered.Strict (Index)+import qualified Data.Map.Ordered.Strict as OM+import Language.Haskell.TH.Desugar.OMap (OMap(..))+import Prelude hiding (filter, lookup, null)++empty :: forall k v. OMap k v+empty = coerce (OM.empty @k @v)++singleton :: k -> v -> OMap k v+singleton k v = coerce (OM.singleton (k, v))++-- | The value's index will be lower than the indices of the values in the+-- 'OSet'.+insertPre :: Ord k => k -> v -> OMap k v -> OMap k v+insertPre k v = coerce ((k, v) OM.|<)++-- | The value's index will be higher than the indices of the values in the+-- 'OSet'.+insertPost :: Ord k => OMap k v -> k -> v -> OMap k v+insertPost m k v = coerce (coerce m OM.|> (k, v))++union :: forall k v. Ord k => OMap k v -> OMap k v -> OMap k v+union = coerce ((OM.|<>) @k @v)++unionWithKey :: Ord k => (k -> v -> v -> v) -> OMap k v -> OMap k v -> OMap k v+unionWithKey f = coerce (OM.unionWithL f)++delete :: forall k v. Ord k => k -> OMap k v -> OMap k v+delete = coerce (OM.delete @k @v)++filterWithKey :: Ord k => (k -> v -> Bool) -> OMap k v -> OMap k v+filterWithKey f = coerce (OM.filter f)++(\\) :: forall k v v'. Ord k => OMap k v -> OMap k v' -> OMap k v+(\\) = coerce ((OM.\\) @k @v @v')++intersection :: forall k v v'. Ord k => OMap k v -> OMap k v' -> OMap k v+intersection = coerce ((OM.|/\) @k @v @v')++intersectionWithKey :: Ord k => (k -> v -> v' -> v'') -> OMap k v -> OMap k v' -> OMap k v''+intersectionWithKey f = coerce (OM.intersectionWith f)++null :: forall k v. OMap k v -> Bool+null = coerce (OM.null @k @v)++size :: forall k v. OMap k v -> Int+size = coerce (OM.size @k @v)++member :: forall k v. Ord k => k -> OMap k v -> Bool+member = coerce (OM.member @k @v)++notMember :: forall k v. Ord k => k -> OMap k v -> Bool+notMember = coerce (OM.notMember @k @v)++lookup :: forall k v. Ord k => k -> OMap k v -> Maybe v+lookup = coerce (OM.lookup @k @v)++lookupIndex :: forall k v. Ord k => k -> OMap k v -> Maybe Index+lookupIndex = coerce (OM.findIndex @k @v)++lookupAt :: forall k v. Index -> OMap k v -> Maybe (k, v)+lookupAt i m = OM.elemAt @k @v (coerce m) i++fromList :: Ord k => [(k, v)] -> OMap k v+fromList l = coerce (OM.fromList l)++assocs :: forall k v. OMap k v -> [(k, v)]+assocs = coerce (OM.assocs @k @v)++toAscList :: forall k v. OMap k v -> [(k, v)]+toAscList = coerce (OM.toAscList @k @v)++toMap :: forall k v. OMap k v -> M.Map k v+toMap = coerce (OM.toMap @k @v)
+ Language/Haskell/TH/Desugar/OSet.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Language.Haskell.TH.Desugar.OSet+-- Copyright   :  (C) 2016-2018 Daniel Wagner, 2019 Ryan Scott+-- License     :  BSD-style (see LICENSE)+-- Maintainer  :  Ryan Scott+-- Stability   :  experimental+-- Portability :  non-portable+--+-- An 'OSet' behaves much like a 'S.Set', with all the same asymptotics, but+-- also remembers the order that values were inserted.+--+-- This module offers a simplified version of the "Data.Set.Ordered" API+-- that assumes left-biased indices everywhere.+--+----------------------------------------------------------------------------+module Language.Haskell.TH.Desugar.OSet+    ( OSet+    -- * Trivial sets+    , empty, singleton+    -- * Insertion+    , insertPre, insertPost, union+    -- * Query+    , null, size, member, notMember+    -- * Deletion+    , delete, filter, (\\), intersection+    -- * Indexing+    , Index, lookupIndex, lookupAt+    -- * List conversions+    , fromList, toAscList+    -- * 'Set' conversion+    , toSet+    ) where++import Data.Coerce+import Data.Data+import qualified Data.Set as S (Set)+import Data.Set.Ordered (Bias(..), Index, L)+import qualified Data.Set.Ordered as OS+import Language.Haskell.TH.Desugar.OMap ()+import Prelude hiding (filter, null)++#if !(MIN_VERSION_base(4,11,0))+import Data.Semigroup (Semigroup(..))+#endif++-- | An ordered set whose 'insertPre', 'insertPost', 'intersection', and 'union'+-- operations are biased towards leftmost indices when when breaking ties+-- between keys.+newtype OSet a = OSet (Bias L (OS.OSet a))+  deriving (Data, Foldable, Eq, Monoid, Ord, Read, Show)++instance Ord a => Semigroup (OSet a) where+  (<>) = union++empty :: forall a. OSet a+empty = coerce (OS.empty @a)++singleton :: a -> OSet a+singleton a = coerce (OS.singleton a)++-- | The element's index will be lower than the indices of the elements in the+-- 'OSet'.+insertPre :: Ord a => a -> OSet a -> OSet a+insertPre a = coerce (a OS.|<)++-- | The element's index will be higher than the indices of the elements in the+-- 'OSet'.+insertPost :: Ord a => OSet a -> a -> OSet a+insertPost s a = coerce (coerce s OS.|> a)++union :: forall a. Ord a => OSet a -> OSet a -> OSet a+union = coerce ((OS.|<>) @a)++null :: forall a. OSet a -> Bool+null = coerce (OS.null @a)++size :: forall a. OSet a -> Int+size = coerce (OS.size @a)++member, notMember :: Ord a => a -> OSet a -> Bool+member    a = coerce (OS.member a)+notMember a = coerce (OS.notMember a)++delete :: Ord a => a -> OSet a -> OSet a+delete a = coerce (OS.delete a)++filter :: Ord a => (a -> Bool) -> OSet a -> OSet a+filter f = coerce (OS.filter f)++(\\) :: forall a. Ord a => OSet a -> OSet a -> OSet a+(\\) = coerce ((OS.\\) @a)++intersection :: forall a. Ord a => OSet a -> OSet a -> OSet a+intersection = coerce ((OS.|/\) @a)++lookupIndex :: Ord a => a -> OSet a -> Maybe Index+lookupIndex a = coerce (OS.findIndex a)++lookupAt :: forall a. Index -> OSet a -> Maybe a+lookupAt i s = OS.elemAt @a (coerce s) i++fromList :: Ord a => [a] -> OSet a+fromList l = coerce (OS.fromList l)++toAscList :: forall a. OSet a -> [a]+toAscList = coerce (OS.toAscList @a)++toSet :: forall a. OSet a -> S.Set a+toSet = coerce (OS.toSet @a)
Language/Haskell/TH/Desugar/Reify.hs view
@@ -1,507 +1,1505 @@ {- Language/Haskell/TH/Desugar/Reify.hs  (c) Richard Eisenberg 2014-eir@cis.upenn.edu--Allows for reification from a list of declarations, without looking a name-up in the environment.--}--{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-}--module Language.Haskell.TH.Desugar.Reify (-  -- * Reification-  reifyWithLocals_maybe, reifyWithLocals, reifyWithWarning, reifyInDecs,--  -- ** Fixity reification-  qReifyFixity, reifyFixity, reifyFixityWithLocals, reifyFixityInDecs,--  -- * Datatype lookup-  getDataD, dataConNameToCon, dataConNameToDataName,--  -- * Monad support-  DsMonad(..), DsM, withLocalDeclarations-  ) where--import Control.Monad.Reader-import Control.Monad.State-import Control.Monad.Writer-import Control.Monad.RWS-import Data.List-import Data.Maybe-#if __GLASGOW_HASKELL__ < 709-import Control.Applicative-#endif-import qualified Data.Set as S-#if __GLASGOW_HASKELL__ >= 800-import qualified Control.Monad.Fail as Fail-#else-import qualified Control.Monad as Fail-#endif--import Language.Haskell.TH.Instances ()-import Language.Haskell.TH.Syntax hiding ( lift )--import Language.Haskell.TH.Desugar.Util---- | 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.--- Note that no inferred type information is available from local declarations;--- bottoms may be used if necessary.-reifyWithLocals_maybe :: DsMonad q => Name -> q (Maybe Info)-reifyWithLocals_maybe name = qRecover-  (return . reifyInDecs name =<< localDeclarations)-  (Just `fmap` qReify name)---- | Like 'reifyWithLocals_maybe', but throws an exception upon failure,--- warning the user about separating splices.-reifyWithLocals :: DsMonad q => Name -> q Info-reifyWithLocals name = do-  m_info <- reifyWithLocals_maybe name-  case m_info of-    Nothing -> reifyFail name-    Just i  -> return i---- | Reify a declaration, warning the user about splices if the reify fails.--- The warning says that reification can fail if you try to reify a type in--- the same splice as it is declared.-reifyWithWarning :: Quasi q => Name -> q Info-reifyWithWarning name = qRecover (reifyFail name) (qReify name)---- | Print out a warning about separating splices and fail.-#if __GLASGOW_HASKELL__ >= 800-reifyFail :: Fail.MonadFail m => Name -> m a-#else-reifyFail :: Monad m => Name -> m a-#endif-reifyFail name =-  Fail.fail $ "Looking up " ++ (show name) ++ " in the list of available " ++-              "declarations failed.\nThis lookup fails if the declaration " ++-              "referenced was made in the same Template\nHaskell splice as the use " ++-              "of the declaration. If this is the case, put\nthe reference to " ++-              "the declaration in a new splice."-------------------------------------- Utilities-------------------------------------- | Extract the @TyVarBndr@s and constructors given the @Name@ of a type-getDataD :: Quasi q-         => String       -- ^ Print this out on failure-         -> Name         -- ^ Name of the datatype (@data@ or @newtype@) of interest-         -> q ([TyVarBndr], [Con])-getDataD err name = do-  info <- reifyWithWarning name-  dec <- case info of-           TyConI dec -> return dec-           _ -> badDeclaration-  case dec of-#if __GLASGOW_HASKELL__ > 710-    DataD _cxt _name tvbs _mk cons _derivings -> return (tvbs, cons)-    NewtypeD _cxt _name tvbs _mk con _derivings -> return (tvbs, [con])-#else-    DataD _cxt _name tvbs cons _derivings -> return (tvbs, cons)-    NewtypeD _cxt _name tvbs con _derivings -> return (tvbs, [con])-#endif-    _ -> badDeclaration-  where badDeclaration =-          fail $ "The name (" ++ (show name) ++ ") refers to something " ++-                 "other than a datatype. " ++ err---- | From the name of a data constructor, retrive the datatype definition it--- is a part of.-dataConNameToDataName :: Quasi q => Name -> q Name-dataConNameToDataName con_name = do-  info <- reifyWithWarning con_name-  case info of-#if __GLASGOW_HASKELL__ > 710-    DataConI _name _type parent_name -> return parent_name-#else-    DataConI _name _type parent_name _fixity -> return parent_name-#endif-    _ -> fail $ "The name " ++ show con_name ++ " does not appear to be " ++-                "a data constructor."---- | From the name of a data constructor, retrieve its definition as a @Con@-dataConNameToCon :: Quasi q => Name -> q Con-dataConNameToCon con_name = do-  -- we need to get the field ordering from the constructor. We must reify-  -- the constructor to get the tycon, and then reify the tycon to get the `Con`s-  type_name <- dataConNameToDataName con_name-  (_, cons) <- getDataD "This seems to be an error in GHC." type_name-  let m_con = find (any (con_name ==) . get_con_name) cons-  case m_con of-    Just con -> return con-    Nothing -> impossible "Datatype does not contain one of its own constructors."--  where-    get_con_name (NormalC name _)     = [name]-    get_con_name (RecC name _)        = [name]-    get_con_name (InfixC _ name _)    = [name]-    get_con_name (ForallC _ _ con)    = get_con_name con-#if __GLASGOW_HASKELL__ > 710-    get_con_name (GadtC names _ _)    = names-    get_con_name (RecGadtC names _ _) = names-#endif------------------------------------------------------- DsMonad------------------------------------------------------- | A 'DsMonad' stores some list of declarations that should be considered--- in scope. 'DsM' is the prototypical inhabitant of 'DsMonad'.-class Quasi m => DsMonad m where-  -- | Produce a list of local declarations.-  localDeclarations :: m [Dec]--instance DsMonad Q where-  localDeclarations = return []-instance DsMonad IO where-  localDeclarations = return []---- | 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-#if __GLASGOW_HASKELL__ >= 800-           , Fail.MonadFail-#endif-           )--instance Quasi q => DsMonad (DsM q) where-  localDeclarations = DsM ask--instance DsMonad m => DsMonad (ReaderT r m) where-  localDeclarations = lift localDeclarations--instance DsMonad m => DsMonad (StateT s m) where-  localDeclarations = lift localDeclarations--instance (DsMonad m, Monoid w) => DsMonad (WriterT w m) where-  localDeclarations = lift localDeclarations--instance (DsMonad m, Monoid w) => DsMonad (RWST r w s m) where-  localDeclarations = lift localDeclarations---- | Add a list of declarations to be considered when reifying local--- declarations.-withLocalDeclarations :: DsMonad q => [Dec] -> DsM q a -> q a-withLocalDeclarations new_decs (DsM x) = do-  orig_decs <- localDeclarations-  runReaderT x (orig_decs ++ new_decs)-------------------------------- Reifying local declarations-------------------------------- | Look through a list of declarations and possibly return a relevant 'Info'-reifyInDecs :: Name -> [Dec] -> Maybe Info-reifyInDecs n decs = firstMatch (reifyInDec n decs) decs---- | Look through a list of declarations and possibly return a fixity.-reifyFixityInDecs :: Name -> [Dec] -> Maybe Fixity-reifyFixityInDecs n = firstMatch match_fixity-  where-    match_fixity (InfixD fixity n') | n `nameMatches` n' = Just fixity-    match_fixity _                                       = Nothing---reifyInDec :: Name -> [Dec] -> Dec -> Maybe Info-reifyInDec n decs (FunD n' _) | n `nameMatches` n' = Just $ mkVarI n decs-reifyInDec n decs (ValD pat _ _)-  | any (nameMatches n) (S.elems (extractBoundNamesPat pat)) = Just $ mkVarI n decs-#if __GLASGOW_HASKELL__ > 710-reifyInDec n _    dec@(DataD    _ n' _ _ _ _) | n `nameMatches` n' = Just $ TyConI dec-reifyInDec n _    dec@(NewtypeD _ n' _ _ _ _) | n `nameMatches` n' = Just $ TyConI dec-#else-reifyInDec n _    dec@(DataD    _ n' _ _ _) | n `nameMatches` n' = Just $ TyConI dec-reifyInDec n _    dec@(NewtypeD _ n' _ _ _) | n `nameMatches` n' = Just $ TyConI dec-#endif-reifyInDec n _    dec@(TySynD n' _ _)       | n `nameMatches` n' = Just $ TyConI dec-reifyInDec n decs dec@(ClassD _ n' _ _ _)   | n `nameMatches` n'-  = Just $ ClassI (stripClassDec dec) (findInstances n decs)-reifyInDec n decs (ForeignD (ImportF _ _ _ n' ty)) | n `nameMatches` n'-  = Just $ mkVarITy n decs ty-reifyInDec n decs (ForeignD (ExportF _ _ n' ty)) | n `nameMatches` n'-  = Just $ mkVarITy n decs ty-#if __GLASGOW_HASKELL__ > 710-reifyInDec n decs dec@(OpenTypeFamilyD (TypeFamilyHead n' _ _ _)) | n `nameMatches` n'-  = Just $ FamilyI (handleBug8884 dec) (findInstances n decs)-reifyInDec n decs dec@(DataFamilyD n' _ _) | n `nameMatches` n'-  = Just $ FamilyI (handleBug8884 dec) (findInstances n decs)-reifyInDec n _    dec@(ClosedTypeFamilyD (TypeFamilyHead n' _ _ _) _) | n `nameMatches` n'-  = Just $ FamilyI dec []-#else-reifyInDec n decs dec@(FamilyD _ n' _ _) | n `nameMatches` n'-  = Just $ FamilyI (handleBug8884 dec) (findInstances n decs)-#if __GLASGOW_HASKELL__ >= 707-reifyInDec n _    dec@(ClosedTypeFamilyD n' _ _ _) | n `nameMatches` n'-  = Just $ FamilyI dec []-#endif-#endif--#if __GLASGOW_HASKELL__ > 710-reifyInDec n decs (DataD _ ty_name tvbs _mk cons _)-  | Just info <- maybeReifyCon n decs ty_name (map tvbToType tvbs) cons-  = Just info-reifyInDec n decs (NewtypeD _ ty_name tvbs _mk con _)-  | Just info <- maybeReifyCon n decs ty_name (map tvbToType tvbs) [con]-  = Just info-#else-reifyInDec n decs (DataD _ ty_name tvbs cons _)-  | Just info <- maybeReifyCon n decs ty_name (map tvbToType tvbs) cons-  = Just info-reifyInDec n decs (NewtypeD _ ty_name tvbs con _)-  | Just info <- maybeReifyCon n decs ty_name (map tvbToType tvbs) [con]-  = Just info-#endif-#if __GLASGOW_HASKELL__ > 710-reifyInDec n _decs (ClassD _ ty_name tvbs _ sub_decs)-  | Just ty <- findType n sub_decs-  = Just $ ClassOpI n (addClassCxt ty_name tvbs ty) ty_name-#else-reifyInDec n decs (ClassD _ ty_name tvbs _ sub_decs)-  | Just ty <- findType n sub_decs-  = Just $ ClassOpI n (addClassCxt ty_name tvbs ty)-                    ty_name (fromMaybe defaultFixity $-                             reifyFixityInDecs n $ sub_decs ++ decs)-#endif-reifyInDec n decs (ClassD _ _ _ _ sub_decs)-  | Just info <- firstMatch (reifyInDec n (sub_decs ++ decs)) sub_decs-  = Just info-#if __GLASGOW_HASKELL__ >= 711-reifyInDec n decs (InstanceD _ _ _ sub_decs)-#else-reifyInDec n decs (InstanceD _ _ sub_decs)-#endif-  | Just info <- firstMatch reify_in_instance sub_decs-  = Just info-  where-    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__ > 710-reifyInDec n decs (DataInstD _ ty_name tys _ cons _)-  | Just info <- maybeReifyCon n decs ty_name tys cons-  = Just info-reifyInDec n decs (NewtypeInstD _ ty_name tys _ con _)-  | Just info <- maybeReifyCon n decs ty_name tys [con]-  = Just info-#else-reifyInDec n decs (DataInstD _ ty_name tys cons _)-  | Just info <- maybeReifyCon n decs ty_name tys cons-  = Just info-reifyInDec n decs (NewtypeInstD _ ty_name tys con _)-  | Just info <- maybeReifyCon n decs ty_name tys [con]-  = Just info-#endif--reifyInDec _ _ _ = Nothing--maybeReifyCon :: Name -> [Dec] -> Name -> [Type] -> [Con] -> Maybe Info-#if __GLASGOW_HASKELL__ > 710-maybeReifyCon n _decs ty_name ty_args cons-  | Just con <- findCon n cons-  = Just $ DataConI n (maybeForallT tvbs [] $ con_to_type con) ty_name-#else-maybeReifyCon n decs ty_name ty_args cons-  | Just con <- findCon n cons-  = Just $ DataConI n (maybeForallT tvbs [] $ con_to_type con)-                    ty_name fixity-#endif--  | Just ty <- findRecSelector n cons-      -- we don't try to ferret out naughty record selectors.-#if __GLASGOW_HASKELL__ > 710-  = Just $ VarI n (maybeForallT tvbs [] $ mkArrows [result_ty] ty) Nothing-#else-  = Just $ VarI n (maybeForallT tvbs [] $ mkArrows [result_ty] ty) Nothing fixity-#endif-  where-    result_ty = foldl AppT (ConT ty_name) ty_args--    con_to_type (NormalC _ stys) = mkArrows (map snd    stys)  result_ty-    con_to_type (RecC _ vstys)   = mkArrows (map thdOf3 vstys) result_ty-    con_to_type (InfixC t1 _ t2) = mkArrows (map snd [t1, t2]) result_ty-    con_to_type (ForallC bndrs cxt c) = ForallT bndrs cxt (con_to_type c)-#if __GLASGOW_HASKELL__ > 710-    con_to_type (GadtC _ stys rty)     = mkArrows (map snd    stys)  rty-    con_to_type (RecGadtC _ vstys rty) = mkArrows (map thdOf3 vstys) rty-#endif-#if __GLASGOW_HASKELL__ < 711-    fixity = fromMaybe defaultFixity $ reifyFixityInDecs n decs-#endif-    tvbs = map PlainTV $ S.elems $ freeNamesOfTypes ty_args-maybeReifyCon _ _ _ _ _ = Nothing--mkVarI :: Name -> [Dec] -> Info-mkVarI n decs = mkVarITy n decs (fromMaybe no_type $ findType n decs)-  where-    no_type = error $ "No type information found in local declaration for "-                      ++ show n--mkVarITy :: Name -> [Dec] -> Type -> Info-#if __GLASGOW_HASKELL__ > 710-mkVarITy n _decs ty = VarI n ty Nothing-#else-mkVarITy n decs ty = VarI n ty Nothing (fromMaybe defaultFixity $-                                        reifyFixityInDecs n decs)-#endif--findType :: Name -> [Dec] -> Maybe Type-findType n = firstMatch match_type-  where-    match_type (SigD n' ty) | n `nameMatches` n' = Just ty-    match_type _                             = Nothing--findInstances :: Name -> [Dec] -> [Dec]-findInstances n = map stripInstanceDec . concatMap match_instance-  where-#if __GLASGOW_HASKELL__ >= 711-    match_instance d@(InstanceD _ _ ty _)-#else-    match_instance d@(InstanceD _ ty _)-#endif-                                               | ConT n' <- ty_head ty-                                               , n `nameMatches` n' = [d]-#if __GLASGOW_HASKELL__ > 710-    match_instance d@(DataInstD _ n' _ _ _ _)    | n `nameMatches` n' = [d]-    match_instance d@(NewtypeInstD _ n' _ _ _ _) | n `nameMatches` n' = [d]-#else-    match_instance d@(DataInstD _ n' _ _ _)    | n `nameMatches` n' = [d]-    match_instance d@(NewtypeInstD _ n' _ _ _) | n `nameMatches` n' = [d]-#endif-#if __GLASGOW_HASKELL__ >= 707-    match_instance d@(TySynInstD n' _)         | n `nameMatches` n' = [d]-#else-    match_instance d@(TySynInstD n' _ _)       | n `nameMatches` n' = [d]-#endif--#if __GLASGOW_HASKELL__ >= 711-    match_instance (InstanceD _ _ _ decs)-#else-    match_instance (InstanceD _ _ decs)-#endif-                                        = concatMap match_instance decs-    match_instance _                    = []--    ty_head (ForallT _ _ ty) = ty_head ty-    ty_head (AppT ty _)      = ty_head ty-    ty_head (SigT ty _)      = ty_head ty-    ty_head ty               = ty--stripClassDec :: Dec -> Dec-stripClassDec (ClassD cxt name tvbs fds sub_decs)-  = ClassD cxt name tvbs fds sub_decs'-  where-    sub_decs' = mapMaybe go sub_decs-    go (SigD n ty) = Just $ SigD n $ addClassCxt name tvbs ty-#if __GLASGOW_HASKELL__ > 710-    go d@(OpenTypeFamilyD {}) = Just d-    go d@(DataFamilyD {})     = Just d-#endif-    go _           = Nothing-stripClassDec dec = dec--addClassCxt :: Name -> [TyVarBndr] -> Type -> Type-addClassCxt class_name tvbs ty = ForallT tvbs class_cxt ty-  where-#if __GLASGOW_HASKELL__ < 709-    class_cxt = [ClassP class_name (map tvbToType tvbs)]-#else-    class_cxt = [foldl AppT (ConT class_name) (map tvbToType tvbs)]-#endif--stripInstanceDec :: Dec -> Dec-#if __GLASGOW_HASKELL__ >= 711-stripInstanceDec (InstanceD over cxt ty _) = InstanceD over cxt ty []-#else-stripInstanceDec (InstanceD cxt ty _)      = InstanceD cxt ty []-#endif-stripInstanceDec dec                       = dec--mkArrows :: [Type] -> Type -> Type-mkArrows []     res_ty = res_ty-mkArrows (t:ts) res_ty = AppT (AppT ArrowT t) $ mkArrows ts res_ty--maybeForallT :: [TyVarBndr] -> Cxt -> Type -> Type-maybeForallT tvbs cxt ty-  | null tvbs && null cxt        = ty-  | ForallT tvbs2 cxt2 ty2 <- ty = ForallT (tvbs ++ tvbs2) (cxt ++ cxt2) ty2-  | otherwise                    = ForallT tvbs cxt ty--findCon :: Name -> [Con] -> Maybe Con-findCon n = find match_con-  where-    match_con (NormalC n' _)  = n `nameMatches` n'-    match_con (RecC n' _)     = n `nameMatches` n'-    match_con (InfixC _ n' _) = n `nameMatches` n'-    match_con (ForallC _ _ c) = match_con c-#if __GLASGOW_HASKELL__ > 710-    match_con (GadtC nms _ _)    = any (n `nameMatches`) nms-    match_con (RecGadtC nms _ _) = any (n `nameMatches`) nms-#endif--findRecSelector :: Name -> [Con] -> Maybe Type-findRecSelector n = firstMatch match_con-  where-    match_con (RecC _ vstys)  = firstMatch match_rec_sel vstys-    match_con (ForallC _ _ c) = match_con c-    match_con _               = Nothing--    match_rec_sel (n', _, ty) | n `nameMatches` n' = Just ty-    match_rec_sel _                     = Nothing--handleBug8884 :: Dec -> Dec-#if __GLASGOW_HASKELL__ >= 707-handleBug8884 = id-#else-handleBug8884 (FamilyD flav name tvbs m_kind)-  = FamilyD flav name tvbs (Just stupid_kind)-  where-    kind_from_maybe = fromMaybe StarT-    tvb_kind (PlainTV _)    = Nothing-    tvb_kind (KindedTV _ k) = Just k--    result_kind = kind_from_maybe m_kind-    args_kinds  = map (kind_from_maybe . tvb_kind) tvbs--    stupid_kind = mkArrows args_kinds result_kind-handleBug8884 dec = dec-#endif-------------------------------------- Reifying fixities---------------------------------------- This section allows GHC 7.x to call reifyFixity--#if __GLASGOW_HASKELL__ < 711-qReifyFixity :: Quasi m => Name -> m (Maybe Fixity)-qReifyFixity name = do-  info <- qReify name-  return $ case info of-    ClassOpI _ _ _ fixity -> Just fixity-    DataConI _ _ _ fixity -> Just fixity-    VarI _ _ _ fixity     -> Just fixity-    _                     -> Nothing--{- | @reifyFixity nm@ attempts to find a fixity declaration for @nm@. For-example, if the function @foo@ has the fixity declaration @infixr 7 foo@, then-@reifyFixity 'foo@ would return @'Just' ('Fixity' 7 'InfixR')@. If the function-@bar@ does not have a fixity declaration, then @reifyFixity 'bar@ returns-'Nothing', so you may assume @bar@ has 'defaultFixity'.--}-reifyFixity :: Name -> Q (Maybe Fixity)-reifyFixity = qReifyFixity-#endif---- | Like 'reifyWithLocals_maybe', but for fixities. Note that a return of--- @Nothing@ might mean that the name is not in scope, or it might mean--- that the name has no assigned fixity. (Use 'reifyWithLocals_maybe' if--- you really need to tell the difference.)-reifyFixityWithLocals :: DsMonad q => Name -> q (Maybe Fixity)-reifyFixityWithLocals name = qRecover-  (return . reifyFixityInDecs name =<< localDeclarations)-  (qReifyFixity name)+rae@cs.brynmawr.edu++Allows for reification from a list of declarations, without looking a name+up in the environment.+-}++{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, ScopedTypeVariables #-}++module Language.Haskell.TH.Desugar.Reify (+  -- * Reification+  reifyWithLocals_maybe, reifyWithLocals, reifyWithWarning, reifyInDecs,++  -- ** Fixity reification+  qReifyFixity, reifyFixity, reifyFixityWithLocals, reifyFixityInDecs,++  -- ** Type reification+  qReifyType, reifyType,+  reifyTypeWithLocals_maybe, reifyTypeWithLocals, reifyTypeInDecs,++  -- * Datatype lookup+  getDataD, dataConNameToCon, dataConNameToDataName,++  -- * Value and type lookup+  lookupValueNameWithLocals, lookupTypeNameWithLocals,+  mkDataNameWithLocals, mkTypeNameWithLocals,+  reifyNameSpace,++  -- * Monad support+  DsMonad(..), DsM, withLocalDeclarations+  ) where++import Control.Applicative+import qualified Control.Monad.Fail as Fail+import Control.Monad.Reader+import Control.Monad.State+import Control.Monad.Writer+import Control.Monad.RWS+import Control.Monad.Trans.Instances ()+import qualified Data.Foldable as F+import Data.Function (on)+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.Set (Set)++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 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.+-- Note that no inferred type information is available from local declarations;+-- bottoms may be used if necessary.+reifyWithLocals_maybe :: DsMonad q => Name -> q (Maybe Info)+reifyWithLocals_maybe name = qRecover+  (return . reifyInDecs name =<< localDeclarations)+  (Just `fmap` qReify name)++-- | Like 'reifyWithLocals_maybe', but throws an exception upon failure,+-- warning the user about separating splices.+reifyWithLocals :: DsMonad q => Name -> q Info+reifyWithLocals name = do+  m_info <- reifyWithLocals_maybe name+  case m_info of+    Nothing -> reifyFail name+    Just i  -> return i++-- | Reify a declaration, warning the user about splices if the reify fails.+-- The warning says that reification can fail if you try to reify a type in+-- the same splice as it is declared.+reifyWithWarning :: (Quasi q, Fail.MonadFail q) => Name -> q Info+reifyWithWarning name = qRecover (reifyFail name) (qReify name)++-- | Print out a warning about separating splices and fail.+reifyFail :: Fail.MonadFail m => Name -> m a+reifyFail name =+  Fail.fail $ "Looking up " ++ (show name) ++ " in the list of available " +++              "declarations failed.\nThis lookup fails if the declaration " +++              "referenced was made in the same Template\nHaskell splice as the use " +++              "of the declaration. If this is the case, put\nthe reference to " +++              "the declaration in a new splice."++---------------------------------+-- Utilities+---------------------------------++-- | 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 (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 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 df tvbs mk cons = do+      let k = fromMaybe (ConT typeKindName) mk+      extra_tvbs <- mkExtraKindBinders k+      let all_tvbs = tvbs ++ extra_tvbs+      return (df, all_tvbs, cons)++    badDeclaration =+          fail $ "The name (" ++ (show name) ++ ") refers to something " +++                 "other than a datatype. " ++ err++-- | Create new kind variable binder names corresponding to the return kind of+-- a data type. This is useful when you have a data type like:+--+-- @+-- data Foo :: forall k. k -> Type -> Type where ...+-- @+--+-- But you want to be able to refer to the type @Foo a b@.+-- 'mkExtraKindBinders' will take the kind @forall k. k -> Type -> Type@,+-- discover that is has two visible argument kinds, and return as a result+-- two new kind variable binders @[a :: k, b :: Type]@, where @a@ and @b@+-- are fresh type variable names.+--+-- This expands kind synonyms if necessary.+mkExtraKindBinders :: 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 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.+dataConNameToDataName :: DsMonad q => Name -> q Name+dataConNameToDataName con_name = do+  info <- reifyWithLocals con_name+  case info of+    DataConI _name _type parent_name -> return parent_name+    _ -> fail $ "The name " ++ show con_name ++ " does not appear to be " +++                "a data constructor."++-- | From the name of a data constructor, retrieve its definition as a @Con@+dataConNameToCon :: DsMonad q => Name -> q Con+dataConNameToCon con_name = do+  -- we need to get the field ordering from the constructor. We must reify+  -- the constructor to get the tycon, and then reify the tycon to get the `Con`s+  type_name <- dataConNameToDataName con_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+    Nothing -> impossible "Datatype does not contain one of its own constructors."++  where+    get_con_name (NormalC name _)     = [name]+    get_con_name (RecC name _)        = [name]+    get_con_name (InfixC _ name _)    = [name]+    get_con_name (ForallC _ _ con)    = get_con_name con+    get_con_name (GadtC names _ _)    = names+    get_con_name (RecGadtC names _ _) = names++--------------------------------------------------+-- DsMonad+--------------------------------------------------++-- | A 'DsMonad' stores some list of declarations that should be considered+-- in scope. 'DsM' is the prototypical inhabitant of 'DsMonad'.+class (Quasi m, Fail.MonadFail m) => DsMonad m where+  -- | Produce a list of local declarations.+  localDeclarations :: m [Dec]++instance DsMonad Q where+  localDeclarations = return []+instance DsMonad IO where+  localDeclarations = return []++-- | 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, Fail.MonadFail+           , Quasi, Compat.Quote+#if __GLASGOW_HASKELL__ >= 803+           , MonadIO+#endif+           )++instance (Quasi q, Fail.MonadFail q) => DsMonad (DsM q) where+  localDeclarations = DsM ask++instance DsMonad m => DsMonad (ReaderT r m) where+  localDeclarations = lift localDeclarations++instance DsMonad m => DsMonad (StateT s m) where+  localDeclarations = lift localDeclarations++instance (DsMonad m, Monoid w) => DsMonad (WriterT w m) where+  localDeclarations = lift localDeclarations++instance (DsMonad m, Monoid w) => DsMonad (RWST r w s m) where+  localDeclarations = lift localDeclarations++-- | Add a list of declarations to be considered when reifying local+-- declarations.+withLocalDeclarations :: DsMonad q => [Dec] -> DsM q a -> q a+withLocalDeclarations new_decs (DsM x) = do+  orig_decs <- localDeclarations+  runReaderT x (orig_decs ++ new_decs)++---------------------------+-- Reifying local declarations+---------------------------++-- | Look through a list of declarations and possibly return a relevant 'Info'+reifyInDecs :: Name -> [Dec] -> Maybe Info+reifyInDecs n decs = snd `fmap` firstMatch (reifyInDec n decs) decs++-- | Look through a list of declarations and possibly return a fixity.+reifyFixityInDecs :: Name -> [Dec] -> Maybe Fixity+reifyFixityInDecs n = firstMatch match_fixity+  where+    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++-- | A reified thing along with the name of that thing.+type Named a = (Name, a)++reifyInDec :: Name -> [Dec] -> Dec -> Maybe (Named Info)+reifyInDec n decs (FunD n' _) | n `nameMatches` n' = Just (n', mkVarI n decs)+reifyInDec n decs (ValD pat _ _)+  | Just n' <- List.find (nameMatches n) (F.toList (extractBoundNamesPat pat))+  = Just (n', mkVarI n decs)+reifyInDec n _    dec@(DataD    _ n' _ _ _ _) | n `nameMatches` n' = Just (n', TyConI dec)+reifyInDec n _    dec@(NewtypeD _ n' _ _ _ _) | n `nameMatches` n' = Just (n', TyConI dec)+reifyInDec n _    dec@(TySynD n' _ _)       | n `nameMatches` n' = Just (n', TyConI dec)+reifyInDec n decs dec@(ClassD _ n' _ _ _)   | n `nameMatches` n'+  = Just (n', ClassI (quantifyClassDecMethods dec) (findInstances n decs))+reifyInDec n _    (ForeignD (ImportF _ _ _ n' ty)) | n `nameMatches` n'+  = Just (n', mkVarITy n ty)+reifyInDec n _    (ForeignD (ExportF _ _ n' ty)) | n `nameMatches` n'+  = Just (n', mkVarITy n ty)+reifyInDec n decs dec@(OpenTypeFamilyD (TypeFamilyHead n' _ _ _)) | n `nameMatches` n'+  = Just (n', FamilyI dec (findInstances n decs))+reifyInDec n decs dec@(DataFamilyD n' _ _) | n `nameMatches` n'+  = Just (n', FamilyI dec (findInstances n decs))+reifyInDec n _    dec@(ClosedTypeFamilyD (TypeFamilyHead n' _ _ _) _) | n `nameMatches` n'+  = Just (n', FamilyI dec [])+#if __GLASGOW_HASKELL__ >= 801+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+                   (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+                   (matchUpSAKWithTvbsSpec decs ty_name tvbs)+                   (applyType (ConT ty_name) (map tyVarBndrVisToTypeArg tvbs))+                   [con]+  = Just info+reifyInDec n decs (ClassD _ cls_name cls_tvbs _ sub_decs)+  | Just (n', ty) <- findType n sub_decs+  = 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+                 -- above, or else type family defaults can be confused for+                 -- actual instances. See #134.+  = Just info+reifyInDec n decs (InstanceD _ _ _ sub_decs)+  | Just info <- firstMatch reify_in_instance sub_decs+  = Just info+  where+    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 _ mtvbs lhs _ cons _)+  | (ConT ty_name, tys) <- unfoldType lhs+  , 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 _ mtvbs lhs _ con _)+  | (ConT ty_name, tys) <- unfoldType lhs+  , 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+                   (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+                   (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+  -> [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+  = Just (n', DataConI n full_con_ty ty_name)++  | Just (n', rec_sel_info) <- findRecSelector n cons+  , let (tvbs, sel_ty, con_res_ty) = extract_rec_sel_info rec_sel_info+        -- See Note [Use unSigType in maybeReifyCon]+        full_sel_ty = unSigType $ maybeForallT tvbs [] $ mkArrows [con_res_ty] sel_ty+      -- we don't try to ferret out naughty record selectors.+  = Just (n', VarI n full_sel_ty Nothing)+  where+    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 ->+          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+          )++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]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Make sure to call unSigType on the type of a reified data constructor or+record selector. Otherwise, if you have this:++  data D (a :: k) = MkD { unD :: Proxy a }++Then the type of unD will be reified as:++  unD :: forall k (a :: k). D (a :: k) -> Proxy a++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 :: [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.+            -> Con -> Type+con_to_type h98_tvbs h98_result_ty con =+  case go con of+    (is_gadt, ty) | is_gadt   -> 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.+    go :: Con -> (Bool, Type) -- The Bool is True when dealing with a GADT+    go (NormalC _ stys)       = (False, mkArrows (map snd    stys)  h98_result_ty)+    go (RecC _ vstys)         = (False, mkArrows (map thdOf3 vstys) h98_result_ty)+    go (InfixC t1 _ t2)       = (False, mkArrows (map snd [t1, t2]) h98_result_ty)+    go (ForallC bndrs cxt c)  = liftSnd (ForallT bndrs cxt) (go c)+    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)++mkVarITy :: Name -> Type -> Info+mkVarITy n ty = VarI n ty Nothing++findType :: Name -> [Dec] -> Maybe (Named Type)+findType n = firstMatch match_type+  where+    match_type (SigD n' ty) | n `nameMatches` n' = Just (n', ty)+    match_type _                                 = Nothing++#if __GLASGOW_HASKELL__ >= 801+mkPatSynI :: Name -> [Dec] -> Info+mkPatSynI n decs = PatSynI n (fromMaybe (no_type n) $ findPatSynType n decs)++findPatSynType :: Name -> [Dec] -> Maybe PatSynType+findPatSynType n = firstMatch match_pat_syn_type+  where+    match_pat_syn_type (PatSynSigD n' psty) | n `nameMatches` n' = Just psty+    match_pat_syn_type _                                         = Nothing+#endif++no_type :: Name -> Type+no_type n = error $ "No type information found in local declaration for "+                    ++ show n++findInstances :: Name -> [Dec] -> [Dec]+findInstances n = map stripInstanceDec . concatMap match_instance+  where+    match_instance d@(InstanceD _ _ ty _)      | ConT n' <- ty_head ty+                                               , n `nameMatches` n' = [d]+#if __GLASGOW_HASKELL__ >= 807+    match_instance (DataInstD ctxt _ lhs mk cons derivs)+                                                  | ConT n' <- ty_head lhs+                                                  , n `nameMatches` n' = [d]+      where+        mtvbs = rejig_data_inst_tvbs ctxt lhs mk+        d = DataInstD ctxt mtvbs lhs mk cons derivs+    match_instance (NewtypeInstD ctxt _ lhs mk con derivs)+                                                  | ConT n' <- ty_head lhs+                                                  , n `nameMatches` n' = [d]+      where+        mtvbs = rejig_data_inst_tvbs ctxt lhs mk+        d = NewtypeInstD ctxt mtvbs lhs mk con derivs+#else+    match_instance d@(DataInstD _ n' _ _ _ _)    | n `nameMatches` n' = [d]+    match_instance d@(NewtypeInstD _ n' _ _ _ _) | n `nameMatches` n' = [d]+#endif+#if __GLASGOW_HASKELL__ >= 807+    match_instance (TySynInstD (TySynEqn _ lhs rhs))+                                               | ConT n' <- ty_head lhs+                                               , n `nameMatches` n' = [d]+      where+        mtvbs = rejig_tvbs [lhs, rhs]+        d = TySynInstD (TySynEqn mtvbs lhs rhs)+#else+    match_instance d@(TySynInstD n' _)         | n `nameMatches` n' = [d]+#endif++    match_instance (InstanceD _ _ _ decs)+                                        = concatMap match_instance decs+    match_instance _                    = []++#if __GLASGOW_HASKELL__ >= 807+    -- See Note [Rejigging reified type family equations variable binders]+    -- for why this is necessary.+    rejig_tvbs :: [Type] -> Maybe [TyVarBndrUnit]+    rejig_tvbs ts =+      let tvbs = freeVariablesWellScoped ts+      in if null tvbs+         then Nothing+         else Just tvbs++    rejig_data_inst_tvbs :: Cxt -> Type -> Maybe Kind -> Maybe [TyVarBndrUnit]+    rejig_data_inst_tvbs cxt lhs mk =+      rejig_tvbs $ cxt ++ [lhs] ++ maybeToList mk+#endif++    ty_head = fst . unfoldType++{-+Note [Rejigging reified type family equations variable binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When reifying a type family instance (on GHC 8.8 or later), which quantified+type variables do you use? This might seem like a strange question to ask since+these instances already come equipped with a field of type `Maybe [TyVarBndr]`,+but it's not always the case that you want to use exactly that field. Here is+an example to better explain it:++  class C a where+    type T b a+  instance C (Maybe a) where+    type forall b. T b (Maybe a) = a++If the above instance were quoted, it would give you `Just [PlainTV b]`. But if+you were to reify ''T (and therefore retrieve the instance for T), you wouldn't+want to use that as your list of type variable binders! This is because+reifiying any type family always presents the information as though the type+family were top-level. Therefore, reifying T (in GHC, at least) would yield:++  type family T b a+  type instance forall b a. T b (Maybe a) = a++Note that we quantify over `b` *and* `a` here, not just `b`. To emulate this+GHC quirk, whenever we reify any type family instance, we just ignore the field+of type `Maybe [TyVarBndr]` and quantify over the instance afresh. It's a bit+tedious, but it gets the job done. (This is accomplished by the rejig_tvbs+function.)+-}++-- Consider the following class declaration:+--+--   [d| class C a where+--         method :: a -> b -> a |]+--+-- When reifying C locally, quantifyClassDecMethods serves two purposes:+--+-- 1. It quantifies the class method's local type variables. To illustrate this+--    point, this is how GHC would reify C:+--+--      class C a where+--        method :: forall b. a -> b -> a+--+--    Notice the presence of the explicit `forall b.`. quantifyClassDecMethods+--    performs this explicit quantification if necessary (as in the case in the+--    local C declaration, where `b` is implicitly quantified.)+-- 2. It emulates a quirk in the way old versions of GHC would reify class+--    declarations (Trac #15551). On versions of GHC older than 8.8, it would+--    reify C like so:+--+--      class C a where+--        method :: forall a. C a => forall b. a -> b -> a+--+--    Notice how GHC has added the (totally extraneous) `forall a. C a =>`+--    part! This is weird, but our primary goal in this module is to mimic+--    GHC's reification, so we play the part by adding the `forall`/class+--    context to each class method in quantifyClassDecMethods.+--+--    Since Trac #15551 was fixed in GHC 8.8, this function doesn't perform+--    this step on 8.7 or later.+quantifyClassDecMethods :: Dec -> Dec+quantifyClassDecMethods (ClassD cxt cls_name cls_tvbs fds sub_decs)+  = ClassD cxt cls_name cls_tvbs fds sub_decs'+  where+    sub_decs' = mapMaybe go sub_decs+    go (SigD n ty) =+      Just $ SigD n+           $ 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+    go _           = Nothing++    -- See (2) in the comments for quantifyClassDecMethods.+    prepend_cls :: Bool+#if __GLASGOW_HASKELL__ >= 807+    prepend_cls = False+#else+    prepend_cls = True+#endif+quantifyClassDecMethods dec = dec++-- Add explicit quantification to a class method's type if necessary. In this+-- example:+--+--   [d| class C a where+--         method :: a -> b -> a |]+--+-- 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)+--+-- Whether you want `prepend` to be True or False depends on the situation.+-- When reifying an entire type class, like C, one does not need to prepend a+-- class context to each of the bundled method types (see the comments for+-- quantifyClassDecMethods), so False is appropriate. When one is only reifying+-- a single class method, like `method`, then one needs the class context to+-- appear in the reified type, so `True` is appropriate.+quantifyClassMethodType+  :: [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_tvbs cls_pred prepend meth_ty =+  add_cls_cxt quantified_meth_ty+  where+    add_cls_cxt :: Type -> Type+    add_cls_cxt+      | prepend   = ForallT all_cls_tvbs [cls_pred]+      | otherwise = id++    quantified_meth_ty :: Type+    quantified_meth_ty+      | null meth_tvbs+      = meth_ty+      | ForallT meth_tvbs' meth_ctxt meth_tau <- meth_ty+      = ForallT (meth_tvbs ++ meth_tvbs') meth_ctxt meth_tau+      | otherwise+      = ForallT meth_tvbs [] meth_ty++    meth_tvbs :: [TyVarBndrSpec]+    meth_tvbs = List.deleteFirstsBy ((==) `on` tvName)+                  (changeTVFlags SpecifiedSpec+                     (freeVariablesWellScoped [meth_ty]))+                  all_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 []+stripInstanceDec dec                       = dec++mkArrows :: [Type] -> Type -> Type+mkArrows []     res_ty = res_ty+mkArrows (t:ts) res_ty = AppT (AppT ArrowT t) $ mkArrows ts res_ty++maybeForallT :: [TyVarBndrSpec] -> Cxt -> Type -> Type+maybeForallT tvbs cxt ty+  | null tvbs && null cxt        = ty+  | 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+  where+    match_con :: Con -> Maybe (Named Con)+    match_con con =+      case con of+        NormalC n' _  | n `nameMatches` n' -> Just (n', con)+        RecC n' _     | n `nameMatches` n' -> Just (n', con)+        InfixC _ n' _ | n `nameMatches` n' -> Just (n', con)+        ForallC _ _ c -> case match_con c of+                           Just (n', _) -> Just (n', con)+                           Nothing      -> Nothing+        GadtC nms _ _    -> gadt_case con nms+        RecGadtC nms _ _ -> gadt_case con nms+        _                -> Nothing++    gadt_case :: Con -> [Name] -> Maybe (Named Con)+    gadt_case con nms = case List.find (n `nameMatches`) nms of+                          Just n' -> Just (n', con)+                          Nothing -> Nothing++data RecSelInfo+  = RecSelH98  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 Nothing)+  where+    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+---------------------------------++-- | Like 'reifyWithLocals_maybe', but for fixities. Note that a return value+-- of @Nothing@ might mean that the name is not in scope, or it might mean+-- that the name has no assigned fixity. (Use 'reifyWithLocals_maybe' if+-- you really need to tell the difference.)+reifyFixityWithLocals :: DsMonad q => Name -> q (Maybe Fixity)+reifyFixityWithLocals name = qRecover+  (return . reifyFixityInDecs name =<< localDeclarations)+  (qReifyFixity name)++--------------------------------------+-- Reifying types+--------------------------------------+--+-- This section allows GHC <8.9 to call reifyFixity++#if __GLASGOW_HASKELL__ < 809+qReifyType :: forall m. Quasi m => Name -> m Type+qReifyType name = do+  info <- qReify name+  case infoType info <|> info_kind info of+    Just t  -> return t+    Nothing -> fail $ "Could not reify the full type of " ++ nameBase name+  where+    info_kind :: Info -> Maybe Kind+    info_kind info = do+      dec <- case info of+               ClassI d _  -> Just d+               TyConI d    -> Just d+               FamilyI d _ -> Just d+               _           -> Nothing+      match_cusk name dec++{- | @reifyType nm@ attempts to find the type or kind of @nm@. For example,+@reifyType 'not@   returns @Bool -> Bool@, and+@reifyType ''Bool@ returns @Type@.+This works even if there's no explicit signature and the type or kind is inferred.+-}+reifyType :: Name -> Q Type+reifyType = qReifyType+#endif++-- | Like 'reifyTypeWithLocals_maybe', but throws an exception upon failure,+-- warning the user about separating splices.+reifyTypeWithLocals :: DsMonad q => Name -> q Type+reifyTypeWithLocals name = do+  m_info <- reifyTypeWithLocals_maybe name+  case m_info of+    Nothing -> reifyFail name+    Just i  -> return i++-- | Like 'reifyWithLocals_maybe' but for types and kinds. Note that a return+-- value of @Nothing@ might mean that the name is not in scope, or it might+-- mean that the full type of the name cannot be determined. (Use+-- 'reifyWithLocals_maybe' if you really need to tell the difference.)+reifyTypeWithLocals_maybe :: DsMonad q => Name -> q (Maybe Type)+reifyTypeWithLocals_maybe name = do+#if __GLASGOW_HASKELL__ >= 809+  cusks <- qIsExtEnabled CUSKs+#else+  -- On earlier GHCs, the behavior of -XCUSKs was the norm.+  let cusks = True+#endif+  qRecover (return . reifyTypeInDecs cusks name =<< localDeclarations)+           (Just `fmap` qReifyType name)++-- | Look through a list of declarations and return its full type, if+-- available.+reifyTypeInDecs :: Bool -> Name -> [Dec] -> Maybe Type+reifyTypeInDecs cusks name decs =+  (reifyInDecs name decs >>= infoType) <|> findKind cusks name decs++-- Extract the type information (if any) contained in an Info.+infoType :: Info -> Maybe Type+infoType info =+  case info of+    ClassOpI _ t _ -> Just t+    DataConI _ t _ -> Just t+    VarI _ t _     -> Just t+    TyVarI _ t     -> Just t+#if __GLASGOW_HASKELL__ >= 802+    PatSynI _ t    -> Just t+#endif+    _              -> Nothing++-- Like findType, but instead searching for kind signatures.+-- This mostly searches through `KiSigD`s, but if the -XCUSKs extension is+-- enabled, this also retrieves kinds for declarations with CUSKs.+findKind :: Bool -- Is -XCUSKs enabled?+         -> Name -> [Dec] -> Maybe Kind+findKind cusks name decls =+      firstMatch (match_kind_sig name decls) decls+  <|> whenAlt cusks (firstMatch (match_cusk name) decls)++-- Look for a declaration's kind by searching for its standalone kind+-- signature, if available.+match_kind_sig :: Name -> [Dec] -> Dec -> Maybe Kind+match_kind_sig n decs (ClassD _ n' tvbs _ sub_decs)+  -- If a class has a standalone kind signature, then we can determine the+  -- full kind of its associated types in 99% of cases.+  -- See Note [The limitations of standalone kind signatures] for what+  -- happens in the other 1% of cases.+  | Just ki <- firstMatch (find_kind_sig n') decs+  , let (arg_kis, _res_ki) = unravelType ki+        mb_vis_arg_kis     = map vis_arg_kind_maybe $ filterVisFunArgs arg_kis+        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 <|> 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++find_kind_sig :: Name -> Dec -> Maybe Kind+#if __GLASGOW_HASKELL__ >= 809+find_kind_sig n (KiSigD n' ki)+  | n `nameMatches` n' = Just ki+#endif+find_kind_sig _ _ = Nothing++-- Compute a declaration's kind by retrieving its CUSK, if it has one.+-- This is only done when -XCUSKs is enabled, or on older GHCs where+-- CUSKs were the only means of specifying this information.+match_cusk :: Name -> Dec -> Maybe Kind+match_cusk n (DataD _ n' tvbs m_ki _ _)+  | n `nameMatches` n'+  = datatype_kind tvbs m_ki+match_cusk n (NewtypeD _ n' tvbs m_ki _ _)+  | n `nameMatches` n'+  = datatype_kind tvbs m_ki+match_cusk n (DataFamilyD n' tvbs m_ki)+  | n `nameMatches` n'+  = open_ty_fam_kind tvbs m_ki+match_cusk n (OpenTypeFamilyD (TypeFamilyHead n' tvbs res_sig _))+  | n `nameMatches` n'+  = open_ty_fam_kind tvbs (res_sig_to_kind res_sig)+match_cusk n (ClosedTypeFamilyD (TypeFamilyHead n' tvbs res_sig _) _)+  | n `nameMatches` n'+  = closed_ty_fam_kind tvbs (res_sig_to_kind res_sig)+match_cusk n (TySynD n' tvbs rhs)+  | n `nameMatches` n'+  = ty_syn_kind tvbs rhs+match_cusk n (ClassD _ n' tvbs _ sub_decs)+  | n `nameMatches` n'+  = class_kind tvbs+  | -- An associated type family can only have a CUSK if its parent class+    -- also has a CUSK.+    all tvb_is_kinded tvbs+  , let cls_tvb_kind_map = Map.fromList [ (tvName tvb, tvb_kind)+                                        | tvb <- tvbs+                                        , 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+-- that this function should only ever be called when the kind of the+-- parent class is known (i.e., if it has a standalone kind signature or a+-- CUSK). Despite this, it is possible for this function to return Nothing.+-- See Note [The limitations of standalone kind signatures].+find_assoc_type_kind :: Name -> Map Name Kind -> Dec -> Maybe Kind+find_assoc_type_kind n cls_tvb_kind_map sub_dec =+  case sub_dec of+    DataFamilyD n' tf_tvbs m_ki+      |  n `nameMatches` n'+      -> build_kind (map ascribe_tf_tvb_kind tf_tvbs) (default_res_ki m_ki)+    OpenTypeFamilyD (TypeFamilyHead n' tf_tvbs res_sig _)+      |  n `nameMatches` n'+      -> build_kind (map ascribe_tf_tvb_kind tf_tvbs)+                    (default_res_ki $ res_sig_to_kind res_sig)+    _ -> Nothing+  where+    ascribe_tf_tvb_kind :: TyVarBndrVis -> TyVarBndrVis+    ascribe_tf_tvb_kind 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 :: [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)+  where+    ki_fvs_are_bound :: Bool+    ki_fvs_are_bound =+      let ki_fvs   = Set.fromList $ foldMap freeVariables m_ki+          tvb_vars = Set.fromList $ freeVariables $ map tvbToTypeWithSig tvbs+      in ki_fvs `Set.isSubsetOf` tvb_vars++-- Classes have CUSKs when all of their type variables have explicit kinds.+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 :: [TyVarBndrVis] -> Maybe Kind -> Maybe Kind+open_ty_fam_kind tvbs m_ki =+  build_kind (map default_tvb tvbs) (default_res_ki m_ki)++-- Closed type families have CUSKs when:+--+-- 1. All of their type variables have explicit kinds.+-- 2. An explicit return kind is supplied.+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) $+               build_kind tvbs ki+    Nothing -> Nothing++-- Type synonyms have CUSKs when:+--+-- 1. All of their type variables have explicit kinds.+-- 2. The right-hand-side type is annotated with an explicit kind.+ty_syn_kind :: [TyVarBndrVis] -> Type -> Maybe Kind+ty_syn_kind tvbs rhs =+  case rhs of+    SigT _ ki -> whenAlt (all tvb_is_kinded tvbs) $+                 build_kind tvbs ki+    _         -> Nothing++-- Attempt to construct the full kind of a type-level declaration from its+-- type variable binders and return kind. Do note that the result type of+-- 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 :: [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 :: TyVarBndrVis -> (Maybe Kind, Set Name) -> (Maybe Kind, Set Name)+    go tvb (res, res_fvs) =+      elimTV (\n ->+               ( if n `Set.member` res_fvs+                 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+                              -- only case where we return Nothing.+               , res_fvs+               ))+             (\n k ->+               ( if n `Set.member` res_fvs+                 then forall_ tvb res+                 else fmap (ArrowT `AppT` k `AppT`) res+               , Set.fromList (freeVariables k) `Set.union` res_fvs+               ))+             tvb++    forall_ :: TyVarBndrVis -> Maybe Kind -> Maybe Kind+#if __GLASGOW_HASKELL__ >= 809+    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)+      --+      -- Instead of this more compact kind:+      --+      --   forall a b c -> (a, b, c)+      --+      -- Thankfully, the difference is only cosmetic.+#else+    forall_ _   _    = Nothing+#endif++tvb_is_kinded :: TyVarBndr_ flag -> Bool+tvb_is_kinded = isJust . extractTvbKind_maybe++vis_arg_kind_maybe :: VisFunArg -> Maybe Kind+vis_arg_kind_maybe (VisFADep tvb) = extractTvbKind_maybe tvb+vis_arg_kind_maybe (VisFAAnon k)  = Just k++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++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) = extractTvbKind_maybe tvb++whenAlt :: Alternative f => Bool -> f a -> f a+whenAlt b fa = if b then fa else empty++{-+Note [The limitations of standalone kind signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A current limitation of StandaloneKindSignatures is that they cannot be applied+to associated type families. This can have some surprising consequences.+Consider the following code, taken from+https://gitlab.haskell.org/ghc/ghc/issues/17072#note_221324:++  type C :: forall a -> a -> Constraint+  class C a b where+    type T a :: Type++The parent class C has a standalone kind signature, so GHC treats its+associated types as if they had CUSKs. Can th-desugar figure out the kind+that GHC gives to T?++Unfortunately, the answer is "not easily". This is because `type T a` says+nothing about the kind of `a`, so th-desugar's only other option is to inspect+the kind signature for C. Even this is for naught, as the `forall a -> ...`+part doesn't state the kind of `a` either! The only way to know that the kind+of `a` should be Type is to infer that from the rest of the kind+(`a -> Constraint`), but this gets perilously close to requiring full kind+inference, which is rather unwieldy in Template Haskell.++In cases like T, we simply give up and return Nothing when trying to reify+its kind. It's not ideal, but them's the breaks when you try to extract kinds+from syntax. There is a rather simple workaround available: just write+`type C :: forall (a :: Type) -> a -> Constraint` instead.+-}++--------------------------------------+-- Looking up name value and type names+--------------------------------------++-- | Like 'lookupValueName' from Template Haskell, but looks also in 'Names' of+-- not-yet-typechecked declarations. To establish this list of not-yet-typechecked+-- declarations, use 'withLocalDeclarations'. Returns 'Nothing' if no value+-- with the same name can be found.+lookupValueNameWithLocals :: DsMonad q => String -> q (Maybe Name)+lookupValueNameWithLocals = lookupNameWithLocals False++-- | Like 'lookupTypeName' from Template Haskell, but looks also in 'Names' of+-- not-yet-typechecked declarations. To establish this list of not-yet-typechecked+-- declarations, use 'withLocalDeclarations'. Returns 'Nothing' if no type+-- with the same name can be found.+lookupTypeNameWithLocals :: DsMonad q => String -> q (Maybe Name)+lookupTypeNameWithLocals = lookupNameWithLocals True++lookupNameWithLocals :: forall q. DsMonad q => Bool -> String -> q (Maybe Name)+lookupNameWithLocals ns s = do+    mb_name <- qLookupName ns s+    case mb_name of+      j_name@(Just{}) -> return j_name+      Nothing         -> consult_locals+  where+    built_name = mkName s++    consult_locals = do+      decs <- localDeclarations+      let mb_infos = map (reifyInDec built_name decs) decs+          infos = catMaybes mb_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 -> 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) = 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.+--+-- Unlike 'mkDataName', this also consults the local declarations in scope when+-- determining if the name is currently bound.+mkDataNameWithLocals :: DsMonad q => String -> q Name+mkDataNameWithLocals = mkNameWith lookupValueNameWithLocals mkNameG_d++-- | Like TH's @lookupTypeName@, but if this name is not bound, then we assume+-- it is declared in the current module.+--+-- Unlike 'mkTypeName', this also consults the local declarations in scope when+-- determining if the name is currently bound.+mkTypeNameWithLocals :: DsMonad q => String -> q Name+mkTypeNameWithLocals = mkNameWith lookupTypeNameWithLocals mkNameG_tc++-- | Determines a `Name`'s 'NameSpace'. If the 'NameSpace' is attached to+-- the 'Name' itself (i.e., it is unambiguous), then that 'NameSpace' is+-- immediately returned. Otherwise, reification is used to lookup up the+-- 'NameSpace' (consulting local declarations if necessary).+--+-- Note that if a 'Name' lives in two different 'NameSpaces' (which can+-- genuinely happen--for instance, @'mkName' \"==\"@, where @==@ is both+-- a function and a type family), then this function will simply return+-- whichever 'NameSpace' is discovered first via reification. If you wish+-- to find a 'Name' in a particular 'NameSpace', use the+-- 'lookupValueNameWithLocals' or 'lookupTypeNameWithLocals' functions.+reifyNameSpace :: DsMonad q => Name -> q (Maybe NameSpace)+reifyNameSpace n@(Name _ nf) =+  case nf of+    -- NameGs are simple, as they have a NameSpace attached.+    NameG ns _ _ -> pure $ Just ns++    -- For other names, we must use reification to determine what NameSpace+    -- it lives in (if any).+    _ -> do mb_info <- reifyWithLocals_maybe n+            traverse lookupInfoNameSpace mb_info++-- | Look up a name's 'NameSpace' from its 'Info'.+lookupInfoNameSpace :: DsMonad q => Info -> q NameSpace+lookupInfoNameSpace info =+  case info of+    ClassI{}     -> pure TcClsName+    TyConI{}     -> pure TcClsName+    FamilyI{}    -> pure TcClsName+    PrimTyConI{} -> pure TcClsName+    TyVarI{}     -> pure TcClsName++    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 _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{}    -> pure DataName+#endif
+ Language/Haskell/TH/Desugar/Subst.hs view
@@ -0,0 +1,165 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Language.Haskell.TH.Desugar.Subst+-- Copyright   :  (C) 2018 Richard Eisenberg+-- License     :  BSD-style (see LICENSE)+-- Maintainer  :  Ryan Scott+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Capture-avoiding substitutions on 'DType's. (For non–capture-avoiding+-- substitution functions, use "Language.Haskell.TH.Desugar.Subst.Capturing"+-- instead.)+--+----------------------------------------------------------------------------++module Language.Haskell.TH.Desugar.Subst (+  DSubst,++  -- * Capture-avoiding substitution+  substTy, substForallTelescope, substTyVarBndrs, substTyVarBndr,+  unionSubsts, unionMaybeSubsts,++  -- * Matching a type template against a type+  IgnoreKinds(..), matchTy+  ) where++import qualified Data.List as L+import qualified Data.Map as M+import qualified Data.Set as S++import Language.Haskell.TH.Desugar.AST+import Language.Haskell.TH.Desugar.Util+import Language.Haskell.TH.Syntax++-- | A substitution is just a map from names to types.+type DSubst = M.Map Name DType++-- | 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+  ty' <- substTy vars' ty+  return $ DForallT tele' ty'+substTy vars (DConstrainedT cxt ty) =+  DConstrainedT <$> mapM (substTy vars) cxt <*> substTy vars ty+substTy vars (DAppT t1 t2) =+  DAppT <$> substTy vars t1 <*> substTy vars t2+substTy vars (DAppKindT t k) =+  DAppKindT <$> substTy vars t <*> substTy vars k+substTy vars (DSigT ty ki) =+  DSigT <$> substTy vars ty <*> substTy vars ki+substTy vars (DVarT n)+  | Just ty <- M.lookup n vars+  = return ty+  | otherwise+  = return $ DVarT n+substTy _ ty@(DConT _)  = return ty+substTy _ ty@DArrowT    = return ty+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 =+  case tele of+    DForallVis tvbs -> do+      (vars', tvbs') <- substTyVarBndrs vars tvbs+      return (vars', DForallVis tvbs')+    DForallInvis tvbs -> do+      (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 substTyVarBndr++-- | 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)+substTyVarBndr vars (DPlainTV n flag) = do+  new_n <- qNewName (nameBase n)+  return (M.insert n (DVarT new_n) vars, DPlainTV new_n flag)+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')++-- | Computes the union of two substitutions. Fails if both subsitutions map+-- the same variable to different types.+unionSubsts :: DSubst -> DSubst -> Maybe DSubst+unionSubsts a b =+  let shared_key_set = M.keysSet a `S.intersection` M.keysSet b+      matches_up     = S.foldr (\name -> ((a M.! name) == (b M.! name) &&))+                               True shared_key_set+  in+  if matches_up then return (a `M.union` b) else Nothing++---------------------------+-- Matching++-- | Ignore kind annotations in @matchTy@?+data IgnoreKinds = YesIgnore | NoIgnore++-- | @matchTy ign 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.+--+-- The first argument @ign@ tells @matchTy@ whether to ignore kind signatures+-- in the template. A kind signature in the template might mean that a type+-- variable has a more restrictive kind than otherwise possible, and that+-- mapping that type variable to a type of a different kind could be disastrous.+-- So, if we don't ignore kind signatures, this function returns @Nothing@ if+-- the template has a signature anywhere. If we do ignore kind signatures, it's+-- possible the returned map will be ill-kinded. Use at your own risk.+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+  -- the following two cases wrong.+matchTy ign (DSigT ty _ki) arg = case ign of+  YesIgnore -> matchTy ign ty arg+  NoIgnore  -> Nothing+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 {}) =+  error "Cannot match a forall in a target"+matchTy ign (DAppT pat1 pat2) (DAppT arg1 arg2) =+  unionMaybeSubsts [matchTy ign pat1 arg1, matchTy ign pat2 arg2]+matchTy _   (DConT pat_con) (DConT arg_con)+  | pat_con == arg_con = Just M.empty+matchTy _   DArrowT DArrowT = Just M.empty+matchTy _   (DLitT pat_lit) (DLitT arg_lit)+  | pat_lit == arg_lit = Just M.empty+matchTy _ _ _ = Nothing++unionMaybeSubsts :: [Maybe DSubst] -> Maybe DSubst+unionMaybeSubsts = L.foldl' union_subst1 (Just M.empty)+  where+    union_subst1 :: Maybe DSubst -> Maybe DSubst -> Maybe DSubst+    union_subst1 ma mb = do+      a <- ma+      b <- mb+      unionSubsts a b
+ 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
@@ -1,20 +1,20 @@ {- Language/Haskell/TH/Desugar/Sweeten.hs  (c) Richard Eisenberg 2013-eir@cis.upenn.edu+rae@cs.brynmawr.edu  Converts desugared TH back into real TH. -}  {-# LANGUAGE CPP #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TemplateHaskellQuotes #-}  ----------------------------------------------------------------------------- -- | -- Module      :  Language.Haskell.TH.Desugar.Sweeten -- Copyright   :  (C) 2014 Richard Eisenberg -- License     :  BSD-style (see LICENSE)--- Maintainer  :  Richard Eisenberg (eir@cis.upenn.edu)+-- Maintainer  :  Ryan Scott -- Stability   :  experimental -- Portability :  non-portable --@@ -28,301 +28,504 @@   letDecToTH, typeToTH,    conToTH, foreignToTH, pragmaToTH, ruleBndrToTH,-  clauseToTH, tvbToTH, cxtToTH, predToTH+  clauseToTH, tvbToTH, cxtToTH, predToTH, derivClauseToTH,+#if __GLASGOW_HASKELL__ >= 801+  patSynDirToTH,+#endif++  typeArgToTH   ) where  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.Core+import Language.Haskell.TH.Desugar.AST+import Language.Haskell.TH.Desugar.Core (DTypeArg(..)) import Language.Haskell.TH.Desugar.Util -import Data.Maybe ( maybeToList )- expToTH :: DExp -> Exp expToTH (DVarE n)            = VarE n 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)-#if __GLASGOW_HASKELL__ < 709-expToTH (DStaticE _)         = error "Static expressions supported only in GHC 7.10+"-#else expToTH (DStaticE exp)       = StaticE (expToTH exp)+#if __GLASGOW_HASKELL__ >= 801+expToTH (DAppTypeE exp ty)   = AppTypeE (expToTH exp) (typeToTH ty)+#else+-- In the event that we're on a version of Template Haskell without support for+-- 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)) []  patToTH :: DPat -> Pat-patToTH (DLitPa lit)    = LitP lit-patToTH (DVarPa n)      = VarP n-patToTH (DConPa n pats) = ConP n (map patToTH pats)-patToTH (DTildePa pat)  = TildeP (patToTH pat)-patToTH (DBangPa pat)   = BangP (patToTH pat)-patToTH DWildPa         = WildP+patToTH (DLitP lit)         = LitP lit+patToTH (DVarP n)           = VarP n+patToTH (DConP n _tys pats) = ConP n+#if __GLASGOW_HASKELL__ >= 901+                                   (map typeToTH _tys)+#endif+                                   (map patToTH pats)+patToTH (DTildeP pat)       = TildeP (patToTH pat)+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 = concatMap decToTH+decsToTH = map decToTH  -- | This returns a list of @Dec@s because GHC 7.6.3 does not have -- a one-to-one mapping between 'DDec' and @Dec@.-decToTH :: DDec -> [Dec]-decToTH (DLetDec d) = [letDecToTH d]-decToTH (DDataD Data cxt n tvbs cons derivings) =-#if __GLASGOW_HASKELL__ > 710-  [DataD (cxtToTH cxt) n (map tvbToTH tvbs) Nothing (map conToTH cons)-         (cxtToTH derivings)]-#else-  [DataD (cxtToTH cxt) n (map tvbToTH tvbs) (map conToTH cons)-         (map derivingToTH derivings)]-#endif-decToTH (DDataD Newtype cxt n tvbs [con] derivings) =-#if __GLASGOW_HASKELL__ > 710-  [NewtypeD (cxtToTH cxt) n (map tvbToTH tvbs) Nothing (conToTH con)-            (cxtToTH derivings)]-#else-  [NewtypeD (cxtToTH cxt) n (map tvbToTH tvbs) (conToTH con)-            (map derivingToTH derivings)]-#endif-decToTH (DTySynD n tvbs ty) = [TySynD n (map tvbToTH tvbs) (typeToTH ty)]+decToTH :: DDec -> Dec+decToTH (DLetDec d) = letDecToTH d+decToTH (DDataD Data cxt n tvbs _mk cons derivings) =+  DataD (cxtToTH cxt) n (map tvbToTH tvbs) (fmap typeToTH _mk) (map conToTH cons)+        (concatMap derivClauseToTH derivings)+decToTH (DDataD Newtype cxt n tvbs _mk [con] derivings) =+  NewtypeD (cxtToTH cxt) n (map tvbToTH tvbs) (fmap typeToTH _mk) (conToTH con)+           (concatMap derivClauseToTH derivings)+decToTH (DDataD Newtype _cxt _n _tvbs _mk _cons _derivings) =+  error "Newtype declaration without exactly 1 constructor."+decToTH (DTySynD n tvbs ty) = TySynD n (map tvbToTH tvbs) (typeToTH ty) decToTH (DClassD cxt n tvbs fds decs) =-  [ClassD (cxtToTH cxt) n (map tvbToTH tvbs) fds (decsToTH decs)]-#if __GLASGOW_HASKELL__ >= 711-decToTH (DInstanceD over cxt ty decs) =-  [InstanceD over (cxtToTH cxt) (typeToTH ty) (decsToTH decs)]-#else-decToTH (DInstanceD _ cxt ty decs) =-  [InstanceD (cxtToTH cxt) (typeToTH ty) (decsToTH decs)]-#endif-decToTH (DForeignD f) = [ForeignD (foreignToTH f)]-decToTH (DPragmaD prag) = maybeToList $ fmap PragmaD (pragmaToTH prag)-#if __GLASGOW_HASKELL__ > 710+  ClassD (cxtToTH cxt) n (map tvbToTH tvbs) fds (decsToTH decs)+decToTH (DInstanceD over _mtvbs cxt ty decs) =+  -- We deliberately avoid sweetening _mtvbs. See #151.+  instanceDToTH over cxt ty decs+decToTH (DForeignD f) = ForeignD (foreignToTH f) decToTH (DOpenTypeFamilyD (DTypeFamilyHead n tvbs frs ann)) =-  [OpenTypeFamilyD (TypeFamilyHead n (map tvbToTH tvbs) (frsToTH frs) ann)]+  OpenTypeFamilyD (TypeFamilyHead n (map tvbToTH tvbs) (frsToTH frs) ann)+decToTH (DDataFamilyD n tvbs mk) =+  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+              (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) #else-decToTH (DOpenTypeFamilyD (DTypeFamilyHead n tvbs frs _ann)) =-  [FamilyD TypeFam n (map tvbToTH tvbs) (frsToTH frs)]+decToTH (DTySynInstD eqn) =+  let (n, eqn') = tySynEqnToTH eqn in+  TySynInstD n eqn' #endif-decToTH (DDataFamilyD n tvbs) =-#if __GLASGOW_HASKELL__ > 710-  [DataFamilyD n (map tvbToTH tvbs) Nothing]+decToTH (DClosedTypeFamilyD (DTypeFamilyHead n tvbs frs ann) eqns) =+  ClosedTypeFamilyD (TypeFamilyHead n (map tvbToTH tvbs) (frsToTH frs) ann)+                    (map (snd . tySynEqnToTH) eqns)+decToTH (DRoleAnnotD n roles) = RoleAnnotD n roles+decToTH (DStandaloneDerivD mds _mtvbs cxt ty) =+  -- We deliberately avoid sweetening _mtvbs. See #151.+  standaloneDerivDToTH mds cxt ty+decToTH (DDefaultSigD n ty)        = DefaultSigD n (typeToTH ty)+#if __GLASGOW_HASKELL__ >= 801+decToTH (DPatSynD n args dir pat) = PatSynD n args (patSynDirToTH dir) (patToTH pat)+decToTH (DPatSynSigD n ty)        = PatSynSigD n (typeToTH ty) #else-  [FamilyD DataFam n (map tvbToTH tvbs) Nothing]+decToTH DPatSynD{}    = patSynErr+decToTH DPatSynSigD{} = patSynErr #endif-decToTH (DDataInstD Data cxt n tys cons derivings) =-#if __GLASGOW_HASKELL__ > 710-  [DataInstD (cxtToTH cxt) n (map typeToTH tys) Nothing (map conToTH cons)-             (cxtToTH derivings)-  ]+#if __GLASGOW_HASKELL__ >= 809+decToTH (DKiSigD n ki) = KiSigD n (typeToTH ki) #else-  [DataInstD (cxtToTH cxt) n (map typeToTH tys) (map conToTH cons)-             (map derivingToTH derivings)-  ]+decToTH (DKiSigD {})   =+  error "Standalone kind signatures supported only in GHC 8.10+" #endif-decToTH (DDataInstD Newtype cxt n tys [con] derivings) =-#if __GLASGOW_HASKELL__ > 710-  [NewtypeInstD (cxtToTH cxt) n (map typeToTH tys) Nothing (conToTH con)-                (cxtToTH derivings)-  ]+#if __GLASGOW_HASKELL__ >= 903+decToTH (DDefaultD tys) = DefaultD (map typeToTH tys) #else-  [NewtypeInstD (cxtToTH cxt) n (map typeToTH tys) (conToTH con)-                (map derivingToTH derivings)-  ]+decToTH (DDefaultD{})   =+  error "Default declarations supported only in GHC 9.4+" #endif-#if __GLASGOW_HASKELL__ < 707-decToTH (DTySynInstD n eqn) = [tySynEqnToTHDec n eqn]-decToTH (DClosedTypeFamilyD (DTypeFamilyHead n tvbs frs _ann) eqns) =-  (FamilyD TypeFam n (map tvbToTH tvbs) (frsToTH frs)) :-  (map (tySynEqnToTHDec n) eqns)-decToTH (DRoleAnnotD {}) = []-#else-decToTH (DTySynInstD n eqn) = [TySynInstD n (tySynEqnToTH eqn)]-#if __GLASGOW_HASKELL__ > 710-decToTH (DClosedTypeFamilyD (DTypeFamilyHead n tvbs frs ann) eqns) =-  [ClosedTypeFamilyD (TypeFamilyHead n (map tvbToTH tvbs) (frsToTH frs) ann)-                     (map tySynEqnToTH eqns)-  ]+#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 (DClosedTypeFamilyD (DTypeFamilyHead n tvbs frs _ann) eqns) =-  [ClosedTypeFamilyD n (map tvbToTH tvbs) (frsToTH frs) (map tySynEqnToTH eqns)]+decToTH (DDataD TypeData _cxt _n _tvbs _mk _cons _derivings) =+  error "`type data` declarations supported only in GHC 9.6+" #endif-decToTH (DRoleAnnotD n roles) = [RoleAnnotD n roles]++#if __GLASGOW_HASKELL__ < 801+patSynErr :: a+patSynErr = error "Pattern synonyms supported only in GHC 8.2+" #endif-#if __GLASGOW_HASKELL__ < 709-decToTH (DStandaloneDerivD {}) =-  error "Standalone deriving supported only in GHC 7.10+"-decToTH (DDefaultSigD {})      =-  error "Default method signatures supported only in GHC 7.10+"++-- | Indicates whether something is a newtype or data type, bundling its+-- constructor(s) along with it.+data DNewOrDataCons+  = DNewtypeCon DCon+  | DDataCons   [DCon]++-- | Sweeten a 'DDataInstD'.+dataInstDecToTH :: DNewOrDataCons -> DCxt -> Maybe [DTyVarBndrUnit] -> DType+                -> Maybe DKind -> [DDerivClause] -> Dec+dataInstDecToTH ndc cxt _mtvbs lhs _mk derivings =+  case ndc of+    DNewtypeCon con ->+#if __GLASGOW_HASKELL__ >= 807+      NewtypeInstD (cxtToTH cxt) (fmap (fmap tvbToTH) _mtvbs) (typeToTH lhs)+                   (fmap typeToTH _mk) (conToTH con)+                   (concatMap derivClauseToTH derivings) #else-decToTH (DStandaloneDerivD cxt ty) =-  [StandaloneDerivD (cxtToTH cxt) (typeToTH ty)]-decToTH (DDefaultSigD n ty)        = [DefaultSigD n (typeToTH ty)]+      NewtypeInstD (cxtToTH cxt) _n _lhs_args (fmap typeToTH _mk) (conToTH con)+                   (concatMap derivClauseToTH derivings) #endif-decToTH _ = error "Newtype declaration without exactly 1 constructor." -#if __GLASGOW_HASKELL__ > 710+    DDataCons cons ->+#if __GLASGOW_HASKELL__ >= 807+      DataInstD (cxtToTH cxt) (fmap (fmap tvbToTH) _mtvbs) (typeToTH lhs)+                (fmap typeToTH _mk) (map conToTH cons)+                (concatMap derivClauseToTH derivings)+#else+      DataInstD (cxtToTH cxt) _n _lhs_args (fmap typeToTH _mk) (map conToTH cons)+                (concatMap derivClauseToTH derivings)+#endif+  where+    _lhs' = typeToTH lhs+    (_n, _lhs_args) =+      case unfoldType _lhs' of+        (ConT n, lhs_args) -> (n, filterTANormals lhs_args)+        (_, _) -> error $ "Illegal data instance LHS: " ++ pprint _lhs'+ frsToTH :: DFamilyResultSig -> FamilyResultSig frsToTH DNoSig          = NoSig frsToTH (DKindSig k)    = KindSig (typeToTH k) frsToTH (DTyVarSig tvb) = TyVarSig (tvbToTH tvb)-#else-frsToTH :: DFamilyResultSig -> Maybe Kind-frsToTH DNoSig                      = Nothing-frsToTH (DKindSig k)                = Just (typeToTH k)-frsToTH (DTyVarSig (DPlainTV _))    = Nothing-frsToTH (DTyVarSig (DKindedTV _ k)) = Just (typeToTH k)-#endif -#if __GLASGOW_HASKELL__ <= 710-derivingToTH :: DPred -> Name-derivingToTH (DConPr nm) = nm-derivingToTH p =-  error ("Template Haskell in GHC < 8.0 only allows simple derivings: " ++ show p)-#endif-+-- | Sweeten a 'DLetDec'. letDecToTH :: DLetDec -> Dec 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-#if __GLASGOW_HASKELL__ > 710-conToTH (DCon [] [] n (DNormalC stys) (Just rty)) =+conToTH (DCon [] [] n (DNormalC _ stys) rty) =   GadtC [n] (map (second typeToTH) stys) (typeToTH rty)-conToTH (DCon [] [] n (DRecC vstys) (Just rty)) =+conToTH (DCon [] [] n (DRecC vstys) rty) =   RecGadtC [n] (map (thirdOf3 typeToTH) vstys) (typeToTH rty)-#endif-conToTH (DCon [] [] n (DNormalC stys) _) =-#if __GLASGOW_HASKELL__ > 710-  NormalC n (map (second typeToTH) stys)-#else-  NormalC n (map (bangToStrict *** typeToTH) stys)-#endif-conToTH (DCon [] [] n (DRecC vstys) _) =-#if __GLASGOW_HASKELL__ > 710-  RecC n (map (thirdOf3 typeToTH) vstys)-#else-  RecC n (map (\(v,b,t) -> (v,bangToStrict b,typeToTH t)) vstys)-#endif+-- On GHC 8.0 or later, we sweeten every constructor to GADT syntax, so it is+-- perfectly OK to put all of the quantified type variables+-- (both universal and existential) in a ForallC. conToTH (DCon tvbs cxt n fields rty) =   ForallC (map tvbToTH tvbs) (cxtToTH cxt) (conToTH $ DCon [] [] n fields rty) +instanceDToTH :: Maybe Overlap -> DCxt -> DType -> [DDec] -> Dec+instanceDToTH over cxt ty decs =+  InstanceD over (cxtToTH cxt) (typeToTH ty) (decsToTH decs)++standaloneDerivDToTH :: Maybe DDerivStrategy -> DCxt -> DType -> Dec+standaloneDerivDToTH _mds cxt ty =+  StandaloneDerivD+#if __GLASGOW_HASKELL__ >= 802+                   (fmap derivStrategyToTH _mds)+#endif+                   (cxtToTH cxt) (typeToTH ty)+ foreignToTH :: DForeign -> Foreign foreignToTH (DImportF cc safety str n ty) =   ImportF cc safety str n (typeToTH ty) foreignToTH (DExportF cc str n ty) = ExportF cc str n (typeToTH ty) -pragmaToTH :: DPragma -> Maybe Pragma-pragmaToTH (DInlineP n inl rm phases) = Just $ InlineP n inl rm phases+pragmaToTH :: DPragma -> Pragma+pragmaToTH (DInlineP n inl rm phases) = InlineP n inl rm phases pragmaToTH (DSpecialiseP n ty m_inl phases) =-  Just $ SpecialiseP n (typeToTH ty) m_inl phases-pragmaToTH (DSpecialiseInstP ty) = Just $ SpecialiseInstP (typeToTH ty)-pragmaToTH (DRuleP str rbs lhs rhs phases) =-  Just $ RuleP str (map ruleBndrToTH rbs) (expToTH lhs) (expToTH rhs) phases-#if __GLASGOW_HASKELL__ < 707-pragmaToTH (DAnnP {}) = Nothing+  SpecialiseP n (typeToTH ty) m_inl phases+pragmaToTH (DSpecialiseInstP ty) = SpecialiseInstP (typeToTH ty)+#if __GLASGOW_HASKELL__ >= 807+pragmaToTH (DRuleP str mtvbs rbs lhs rhs phases) =+  RuleP str (fmap (fmap tvbToTH) mtvbs) (map ruleBndrToTH rbs)+        (expToTH lhs) (expToTH rhs) phases #else-pragmaToTH (DAnnP target exp) = Just $ AnnP target (expToTH exp)+pragmaToTH (DRuleP str _ rbs lhs rhs phases) =+  RuleP str (map ruleBndrToTH rbs) (expToTH lhs) (expToTH rhs) phases #endif-#if __GLASGOW_HASKELL__ < 709-pragmaToTH (DLineP {}) = Nothing+pragmaToTH (DAnnP target exp) = AnnP target (expToTH exp)+pragmaToTH (DLineP n str) = LineP n str+#if __GLASGOW_HASKELL__ < 801+pragmaToTH (DCompleteP {}) = error "COMPLETE pragmas only supported in GHC 8.2+" #else-pragmaToTH (DLineP n str) = Just $ LineP n str+pragmaToTH (DCompleteP cls mty) = CompleteP cls mty #endif+#if __GLASGOW_HASKELL__ >= 903+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 ruleBndrToTH (DRuleVar n) = RuleVar n ruleBndrToTH (DTypedRuleVar n ty) = TypedRuleVar n (typeToTH ty) -#if __GLASGOW_HASKELL__ < 707--- | GHC 7.6.3 doesn't have TySynEqn, so we sweeten to a Dec in GHC 7.6.3;--- GHC 7.8+ does not use this function-tySynEqnToTHDec :: Name -> DTySynEqn -> Dec-tySynEqnToTHDec n (DTySynEqn lhs rhs) =-  TySynInstD n (map typeToTH lhs) (typeToTH rhs)+#if __GLASGOW_HASKELL__ >= 807+-- | It's convenient to also return a 'Name' here, since some call sites make+-- use of it.+tySynEqnToTH :: DTySynEqn -> (Name, TySynEqn)+tySynEqnToTH (DTySynEqn tvbs lhs rhs) =+  let lhs' = typeToTH lhs in+  case unfoldType lhs' of+    (ConT n, _lhs_args) -> (n, TySynEqn (fmap (fmap tvbToTH) tvbs) lhs' (typeToTH rhs))+    (_, _) -> error $ "Illegal type instance LHS: " ++ pprint lhs' #else-tySynEqnToTH :: DTySynEqn -> TySynEqn-tySynEqnToTH (DTySynEqn lhs rhs) = TySynEqn (map typeToTH lhs) (typeToTH rhs)+tySynEqnToTH :: DTySynEqn -> (Name, TySynEqn)+tySynEqnToTH (DTySynEqn _ lhs rhs) =+  let lhs' = typeToTH lhs in+  case unfoldType lhs' of+    (ConT n, lhs_args) -> (n, TySynEqn (filterTANormals lhs_args) (typeToTH rhs))+    (_, _) -> error $ "Illegal type instance LHS: " ++ pprint lhs' #endif  clauseToTH :: DClause -> Clause clauseToTH (DClause pats exp) = Clause (map patToTH pats) (NormalB (expToTH exp)) []  typeToTH :: DType -> Type-typeToTH (DForallT tvbs cxt ty) = ForallT (map tvbToTH tvbs) (map predToTH cxt) (typeToTH ty)+-- We need a special case for DForallT ForallInvis followed by DConstrainedT+-- so that we may collapse them into a single ForallT when sweetening.+-- See Note [Desugaring and sweetening ForallT] in L.H.T.Desugar.Core.+typeToTH (DForallT (DForallInvis tvbs) (DConstrainedT ctxt ty)) =+  ForallT (map tvbToTH tvbs) (map predToTH ctxt) (typeToTH ty)+typeToTH (DForallT tele ty) =+  case tele of+    DForallInvis  tvbs -> ForallT (map tvbToTH tvbs) [] ty'+    DForallVis   _tvbs ->+#if __GLASGOW_HASKELL__ >= 809+      ForallVisT (map tvbToTH _tvbs) ty'+#else+      error "Visible dependent quantification supported only in GHC 8.10+"+#endif+  where+    ty'   = typeToTH ty+typeToTH (DConstrainedT cxt ty) = ForallT [] (map predToTH cxt) (typeToTH ty) typeToTH (DAppT t1 t2)          = AppT (typeToTH t1) (typeToTH t2) typeToTH (DSigT ty ki)          = SigT (typeToTH ty) (typeToTH ki) typeToTH (DVarT n)              = VarT n typeToTH (DConT n)              = tyconToTH n typeToTH DArrowT                = ArrowT typeToTH (DLitT lit)            = LitT lit-#if __GLASGOW_HASKELL__ > 710 typeToTH DWildCardT = WildCardT+#if __GLASGOW_HASKELL__ >= 807+typeToTH (DAppKindT t k)        = AppKindT (typeToTH t) (typeToTH k) #else-typeToTH DWildCardT = error "Wildcards supported only in GHC 8.0+"+-- In the event that we're on a version of Template Haskell without support for+-- kind applications, we will simply drop the applied kind.+typeToTH (DAppKindT t _)        = typeToTH t #endif-typeToTH DStarT = StarT -tvbToTH :: DTyVarBndr -> TyVarBndr-tvbToTH (DPlainTV n)           = PlainTV n-tvbToTH (DKindedTV n k)        = KindedTV n (typeToTH k)+tvbToTH :: DTyVarBndr flag -> TyVarBndr_ flag+tvbToTH (DPlainTV n flag)    = plainTVFlag n flag+tvbToTH (DKindedTV n flag k) = kindedTVFlag n flag (typeToTH k)  cxtToTH :: DCxt -> Cxt cxtToTH = map predToTH -predToTH :: DPred -> Pred-#if __GLASGOW_HASKELL__ < 709-predToTH = go []-  where-    go acc (DAppPr p t) = go (typeToTH t : acc) p-    go acc (DSigPr p _) = go acc                p  -- this shouldn't happen.-    go _   (DVarPr _)-      = error "Template Haskell in GHC <= 7.8 does not support variable constraints."-    go acc (DConPr n)-      | nameBase n == "~"-      , [t1, t2] <- acc-      = EqualP t1 t2-      | otherwise-      = ClassP n acc-    go _ DWildCardPr-      = error "Wildcards supported only in GHC 8.0+"+#if __GLASGOW_HASKELL__ >= 801+derivClauseToTH :: DDerivClause -> [DerivClause]+derivClauseToTH (DDerivClause mds cxt) =+  [DerivClause (fmap derivStrategyToTH mds) (cxtToTH cxt)] #else-predToTH (DAppPr p t) = AppT (predToTH p) (typeToTH t)-predToTH (DSigPr p k) = SigT (predToTH p) (typeToTH k)-predToTH (DVarPr n)   = VarT n-predToTH (DConPr n)   = typeToTH (DConT n)-#if __GLASGOW_HASKELL__ > 710-predToTH DWildCardPr  = WildCardT+derivClauseToTH :: DDerivClause -> Cxt+derivClauseToTH (DDerivClause _ cxt) = cxtToTH cxt+#endif++#if __GLASGOW_HASKELL__ >= 801+derivStrategyToTH :: DDerivStrategy -> DerivStrategy+derivStrategyToTH DStockStrategy    = StockStrategy+derivStrategyToTH DAnyclassStrategy = AnyclassStrategy+derivStrategyToTH DNewtypeStrategy  = NewtypeStrategy+#if __GLASGOW_HASKELL__ >= 805+derivStrategyToTH (DViaStrategy ty) = ViaStrategy (typeToTH ty) #else-predToTH DWildCardPr  = error "Wildcards supported only in GHC 8.0+"+derivStrategyToTH (DViaStrategy _)  = error "DerivingVia supported only in GHC 8.6+" #endif #endif +#if __GLASGOW_HASKELL__ >= 801+patSynDirToTH :: DPatSynDir -> PatSynDir+patSynDirToTH DUnidir              = Unidir+patSynDirToTH DImplBidir           = ImplBidir+patSynDirToTH (DExplBidir clauses) = ExplBidir (map clauseToTH clauses)+#endif++predToTH :: DPred -> Pred+predToTH (DAppT p t) = AppT (predToTH p) (typeToTH t)+predToTH (DSigT p k) = SigT (predToTH p) (typeToTH k)+predToTH (DVarT n)   = VarT n+predToTH (DConT n)   = typeToTH (DConT n)+predToTH DArrowT     = ArrowT+predToTH (DLitT lit) = LitT lit+predToTH DWildCardT  = WildCardT+#if __GLASGOW_HASKELL__ >= 805+-- We need a special case for DForallT ForallInvis followed by DConstrainedT+-- so that we may collapse them into a single ForallT when sweetening.+-- See Note [Desugaring and sweetening ForallT] in L.H.T.Desugar.Core.+predToTH (DForallT (DForallInvis tvbs) (DConstrainedT ctxt p)) =+  ForallT (map tvbToTH tvbs) (map predToTH ctxt) (predToTH p)+predToTH (DForallT tele p) =+  case tele of+    DForallInvis tvbs -> ForallT (map tvbToTH tvbs) [] (predToTH p)+    DForallVis _      -> error "Visible dependent quantifier spotted at head of a constraint"+predToTH (DConstrainedT cxt p) = ForallT [] (map predToTH cxt) (predToTH p)+#else+predToTH (DForallT {})      = error "Quantified constraints supported only in GHC 8.6+"+predToTH (DConstrainedT {}) = error "Quantified constraints supported only in GHC 8.6+"+#endif+#if __GLASGOW_HASKELL__ >= 807+predToTH (DAppKindT p k) = AppKindT (predToTH p) (typeToTH k)+#else+-- In the event that we're on a version of Template Haskell without support for+-- kind applications, we will simply drop the applied kind.+predToTH (DAppKindT p _) = predToTH p+#endif+ tyconToTH :: Name -> Type tyconToTH n+  | n == ''(->)                 = ArrowT -- Work around Trac #14888   | n == ''[]                   = ListT-#if __GLASGOW_HASKELL__ >= 709   | n == ''(~)                  = EqualityT-#endif   | n == '[]                    = PromotedNilT   | n == '(:)                   = PromotedConsT-  | Just deg <- tupleNameDegree_maybe n        = if isDataName n-                                                 then PromotedTupleT deg-                                                 else TupleT deg+  | Just deg <- tupleNameDegree_maybe n+                                = if isDataName n+#if __GLASGOW_HASKELL__ >= 805+                                  then PromotedTupleT deg+#else+                                  then PromotedT n -- Work around Trac #14843+#endif+                                  else TupleT deg   | Just deg <- unboxedTupleNameDegree_maybe n = UnboxedTupleT deg+#if __GLASGOW_HASKELL__ >= 801+  | Just deg <- unboxedSumNameDegree_maybe n   = UnboxedSumT deg+#endif   | otherwise                   = ConT n -#if __GLASGOW_HASKELL__ <= 710--- | Convert a 'Bang' to a 'Strict'-bangToStrict :: Bang -> Strict-bangToStrict (Bang SourceUnpack _) = Unpacked-bangToStrict (Bang _ SourceStrict) = IsStrict-bangToStrict (Bang _ _)            = NotStrict-#endif+typeArgToTH :: DTypeArg -> TypeArg+typeArgToTH (DTANormal t) = TANormal (typeToTH t)+typeArgToTH (DTyArg k)    = TyArg    (typeToTH k)
Language/Haskell/TH/Desugar/Util.hs view
@@ -1,264 +1,1243 @@ {- Language/Haskell/TH/Desugar/Util.hs  (c) Richard Eisenberg 2013-eir@cis.upenn.edu--Utility functions for th-desugar package.--}--{-# LANGUAGE CPP, TupleSections #-}--module Language.Haskell.TH.Desugar.Util (-  newUniqueName,-  impossible,-  nameOccursIn, allNamesIn, mkTypeName, mkDataName, isDataName,-  stripVarP_maybe, extractBoundNamesStmt,-  concatMapM, mapMaybeM, expectJustM,-  stripPlainTV_maybe,-  thirdOf3, splitAtList, extractBoundNamesDec,-  extractBoundNamesPat,-  tvbName, tvbToType, nameMatches, freeNamesOfTypes, thdOf3, firstMatch,-  tupleDegree_maybe, tupleNameDegree_maybe, unboxedTupleDegree_maybe,-  unboxedTupleNameDegree_maybe, splitTuple_maybe-  ) where--import Prelude hiding (mapM, foldl, concatMap, any)--import Language.Haskell.TH hiding ( cxt )-import Language.Haskell.TH.Syntax--import qualified Data.Set as S-import Data.Foldable-import Data.Generics hiding ( Fixity )-import Data.Traversable-import Data.Maybe-import Data.Monoid--------------------------------------------- TH manipulations--------------------------------------------- | Like newName, but even more unique (unique across different splices),--- and with unique @nameBase@s. Precondition: the string is a valid Haskell--- alphanumeric identifier (could be upper- or lower-case).-newUniqueName :: Quasi q => String -> q Name-newUniqueName str = do-  n <- qNewName str-  qNewName $ show n---- | Like TH's @lookupTypeName@, but if this name is not bound, then we assume--- it is declared in the current module.-mkTypeName :: Quasi q => String -> q Name-mkTypeName str = do-  m_name <- qLookupName True str-  case m_name of-    Just name -> return name-    Nothing -> do-      Loc { loc_package = pkg, loc_module = modu } <- qLocation-      return $ mkNameG_tc pkg modu str---- | Like TH's @lookupDataName@, but if this name is not bound, then we assume--- it is declared in the current module.-mkDataName :: Quasi q => String -> q Name-mkDataName str = do-  m_name <- qLookupName False str-  case m_name of-    Just name -> return name-    Nothing -> do-      Loc { loc_package = pkg, loc_module = modu } <- qLocation-      return $ mkNameG_d pkg modu str---- | Is this name a data constructor name? A 'False' answer means "unsure".-isDataName :: Name -> Bool-isDataName (Name _ (NameG DataName _ _)) = True-isDataName _                             = False---- | Extracts the name out of a variable pattern, or returns @Nothing@-stripVarP_maybe :: Pat -> Maybe Name-stripVarP_maybe (VarP name) = Just name-stripVarP_maybe _           = Nothing---- | Extracts the name out of a @PlainTV@, or returns @Nothing@-stripPlainTV_maybe :: TyVarBndr -> Maybe Name-stripPlainTV_maybe (PlainTV n) = Just n-stripPlainTV_maybe _           = Nothing---- | Report that a certain TH construct is impossible-impossible :: Monad q => String -> q a-impossible err = fail (err ++ "\n    This should not happen in Haskell.\n    Please email eir@cis.upenn.edu with your code if you see this.")---- | Extract a 'Name' from a 'TyVarBndr'-tvbName :: TyVarBndr -> Name-tvbName (PlainTV n)    = n-tvbName (KindedTV n _) = n---- | Convert a 'TyVarBndr' into a 'Type'-tvbToType :: TyVarBndr -> Type-tvbToType = VarT . tvbName---- | Do two names name the same thing?-nameMatches :: Name -> Name -> Bool-nameMatches n1@(Name occ1 flav1) n2@(Name occ2 flav2)-  | NameS <- flav1 = occ1 == occ2-  | NameS <- flav2 = occ1 == occ2-  | NameQ mod1 <- flav1-  , NameQ mod2 <- flav2-  = mod1 == mod2 && occ1 == occ2-  | NameQ mod1 <- flav1-  , NameG _ _ mod2 <- flav2-  = mod1 == mod2 && occ1 == occ2-  | NameG _ _ mod1 <- flav1-  , NameQ mod2 <- flav2-  = mod1 == mod2 && occ1 == occ2-  | 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-tupleNameDegree_maybe :: Name -> Maybe Int-tupleNameDegree_maybe = tupleDegree_maybe . nameBase---- | Extract the degree of an unboxed tuple-unboxedTupleDegree_maybe :: String -> Maybe Int-unboxedTupleDegree_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-unboxedTupleNameDegree_maybe :: Name -> Maybe Int-unboxedTupleNameDegree_maybe = unboxedTupleDegree_maybe . nameBase---- | If the argument is a tuple type, return the components-splitTuple_maybe :: Type -> Maybe [Type]-splitTuple_maybe t = go [] t-  where go args (t1 `AppT` t2) = go (t2:args) t1-        go args (t1 `SigT` _k) = go args t1-        go args (ConT con_name)-          | Just degree <- tupleNameDegree_maybe con_name-          , length args == degree-          = Just args-        go args (TupleT degree)-          | length args == degree-          = Just args-        go _ _ = Nothing--------------------------------------------- Free names, etc.--------------------------------------------- | Check if a name occurs anywhere within a TH tree.-nameOccursIn :: Data a => Name -> a -> Bool-nameOccursIn n = everything (||) $ mkQ False (== n)---- | Extract all Names mentioned in a TH tree.-allNamesIn :: Data a => a -> [Name]-allNamesIn = everything (++) $ mkQ [] (:[])---- | Extract the names bound in a @Stmt@-extractBoundNamesStmt :: Stmt -> S.Set Name-extractBoundNamesStmt (BindS pat _) = extractBoundNamesPat pat-extractBoundNamesStmt (LetS decs)   = foldMap extractBoundNamesDec decs-extractBoundNamesStmt (NoBindS _)   = S.empty-extractBoundNamesStmt (ParS stmtss) = foldMap (foldMap extractBoundNamesStmt) stmtss---- | Extract the names bound in a @Dec@ that could appear in a @let@ expression.-extractBoundNamesDec :: Dec -> S.Set Name-extractBoundNamesDec (FunD name _)  = S.singleton name-extractBoundNamesDec (ValD pat _ _) = extractBoundNamesPat pat-extractBoundNamesDec _              = S.empty---- | Extract the names bound in a @Pat@-extractBoundNamesPat :: Pat -> S.Set Name-extractBoundNamesPat (LitP _)            = S.empty-extractBoundNamesPat (VarP name)         = S.singleton name-extractBoundNamesPat (TupP pats)         = foldMap extractBoundNamesPat pats-extractBoundNamesPat (UnboxedTupP pats)  = foldMap extractBoundNamesPat pats-extractBoundNamesPat (ConP _ pats)       = foldMap extractBoundNamesPat pats-extractBoundNamesPat (InfixP p1 _ p2)    = extractBoundNamesPat p1 `S.union`-                                           extractBoundNamesPat p2-extractBoundNamesPat (UInfixP p1 _ p2)   = extractBoundNamesPat p1 `S.union`-                                           extractBoundNamesPat p2-extractBoundNamesPat (ParensP pat)       = extractBoundNamesPat pat-extractBoundNamesPat (TildeP pat)        = extractBoundNamesPat pat-extractBoundNamesPat (BangP pat)         = extractBoundNamesPat pat-extractBoundNamesPat (AsP name pat)      = S.singleton name `S.union` extractBoundNamesPat pat-extractBoundNamesPat WildP               = S.empty-extractBoundNamesPat (RecP _ field_pats) = let (_, pats) = unzip field_pats in-                                           foldMap extractBoundNamesPat pats-extractBoundNamesPat (ListP pats)        = foldMap extractBoundNamesPat pats-extractBoundNamesPat (SigP pat _)        = extractBoundNamesPat pat-extractBoundNamesPat (ViewP _ pat)       = extractBoundNamesPat pat--freeNamesOfTypes :: [Type] -> S.Set Name-freeNamesOfTypes = mconcat . map go-  where-    go (ForallT tvbs cxt ty) = (go ty <> mconcat (map go_pred cxt))-                               S.\\ S.fromList (map tvbName tvbs)-    go (AppT t1 t2)          = go t1 <> go t2-    go (SigT ty _)           = go ty-    go (VarT n)              = S.singleton n-    go _                     = S.empty--#if __GLASGOW_HASKELL__ >= 709-    go_pred = go-#else-    go_pred (ClassP _ tys) = freeNamesOfTypes tys-    go_pred (EqualP t1 t2) = go t1 <> go t2-#endif--------------------------------------------- General utility--------------------------------------------- like GHC's-splitAtList :: [a] -> [b] -> ([b], [b])-splitAtList [] x = ([], x)-splitAtList (_ : t) (x : xs) =-  let (as, bs) = splitAtList t xs in-  (x : as, bs)-splitAtList (_ : _) [] = ([], [])--thdOf3 :: (a,b,c) -> c-thdOf3 (_,_,c) = c--thirdOf3 :: (a -> b) -> (c, d, a) -> (c, d, b)-thirdOf3 f (c, d, a) = (c, d, f a)---- lift concatMap into a monad--- could this be more efficient?--- | Concatenate the result of a @mapM@-concatMapM :: (Monad monad, Monoid monoid, Traversable t)-           => (a -> monad monoid) -> t a -> monad monoid-concatMapM fn list = do-  bss <- mapM fn list-  return $ fold bss---- like GHC's-mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b]-mapMaybeM _ [] = return []-mapMaybeM f (x:xs) = do-  y <- f x-  ys <- mapMaybeM f xs-  return $ case y of-    Nothing -> ys-    Just z  -> z : ys--expectJustM :: Monad m => String -> Maybe a -> m a-expectJustM _   (Just x) = return x-expectJustM err Nothing  = fail err--firstMatch :: (a -> Maybe b) -> [a] -> Maybe b-firstMatch f xs = listToMaybe $ mapMaybe f xs+rae@cs.brynmawr.edu++Utility functions for th-desugar package.+-}++{-# LANGUAGE CPP, DeriveDataTypeable, DeriveGeneric, DeriveLift, RankNTypes,+             ScopedTypeVariables, TupleSections, AllowAmbiguousTypes,+             TemplateHaskellQuotes, TypeApplications, MagicHash #-}++module Language.Haskell.TH.Desugar.Util (+  newUniqueName,+  impossible,+  nameOccursIn, allNamesIn, mkTypeName, mkDataName, mkNameWith, isDataName,+  stripVarP_maybe, extractBoundNamesStmt,+  concatMapM, mapAccumLM, mapMaybeM, expectJustM,+  stripPlainTV_maybe, extractTvbKind_maybe,+  thirdOf3, splitAtList, extractBoundNamesDec,+  extractBoundNamesPat,+  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,+  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 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+----------------------------------------++-- | Like newName, but even more unique (unique across different splices),+-- and with unique @nameBase@s. Precondition: the string is a valid Haskell+-- alphanumeric identifier (could be upper- or lower-case).+newUniqueName :: Quasi q => String -> q Name+newUniqueName str = do+  n <- qNewName str+  qNewName $ show n++-- | @mkNameWith lookup_fun mkName_fun str@ looks up the exact 'Name' of @str@+-- using the function @lookup_fun@. If it finds 'Just' the 'Name', meaning+-- that it is bound in the current scope, then it is returned. If it finds+-- 'Nothing', it assumes that @str@ is declared in the current module, and+-- uses @mkName_fun@ to construct the appropriate 'Name' to return.+mkNameWith :: Quasi q => (String -> q (Maybe Name))+                      -> (String -> String -> String -> Name)+                      -> String -> q Name+mkNameWith lookup_fun mkName_fun str = do+  m_name <- lookup_fun str+  case m_name of+    Just name -> return name+    Nothing -> do+      Loc { loc_package = pkg, loc_module = modu } <- qLocation+      return $ mkName_fun pkg modu str++-- | Like TH's @lookupTypeName@, but if this name is not bound, then we assume+-- it is declared in the current module.+mkTypeName :: Quasi q => String -> q Name+mkTypeName = mkNameWith (qLookupName True) mkNameG_tc++-- | Like TH's @lookupDataName@, but if this name is not bound, then we assume+-- it is declared in the current module.+mkDataName :: Quasi q => String -> q Name+mkDataName = mkNameWith (qLookupName False) mkNameG_d++-- | Is this name a data constructor name? A 'False' answer means "unsure".+isDataName :: Name -> Bool+isDataName (Name _ (NameG DataName _ _)) = True+isDataName _                             = False++-- | Extracts the name out of a variable pattern, or returns @Nothing@+stripVarP_maybe :: Pat -> Maybe Name+stripVarP_maybe (VarP name) = Just name+stripVarP_maybe _           = Nothing++-- | Extracts the name out of a @PlainTV@, or returns @Nothing@+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.")++-- | Convert a 'TyVarBndr' into a 'Type', dropping the kind signature+-- (if it has one).+tvbToType :: TyVarBndr_ flag -> Type+tvbToType = VarT . tvName++-- | Convert a 'TyVarBndr' into a 'Type', preserving the kind signature+-- (if it has one).+tvbToTypeWithSig :: TyVarBndr_ flag -> Type+tvbToTypeWithSig = elimTV VarT (\n k -> SigT (VarT n) k)++-- | Do two names name the same thing?+nameMatches :: Name -> Name -> Bool+nameMatches n1@(Name occ1 flav1) n2@(Name occ2 flav2)+  | NameS <- flav1 = occ1 == occ2+  | NameS <- flav2 = occ1 == occ2+  | NameQ mod1 <- flav1+  , NameQ mod2 <- flav2+  = mod1 == mod2 && occ1 == occ2+  | NameQ mod1 <- flav1+  , NameG _ _ mod2 <- flav2+  = mod1 == mod2 && occ1 == occ2+  | NameG _ _ mod1 <- flav1+  , NameQ mod2 <- flav2+  = mod1 == mod2 && occ1 == occ2+  | otherwise+  = n1 == n2++-- | 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 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'.+--+-- 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 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+unboxedTupleDegree_maybe = unboxedSumTupleDegree_maybe ','++-- | Extract the degree of an unboxed sum or tuple+unboxedSumTupleDegree_maybe :: Char -> String -> Maybe Int+unboxedSumTupleDegree_maybe sep s = do+  '(' : '#' : s1 <- return s+  (seps, "#)") <- return $ span (== sep) s1+  let degree+        | "" <- seps = 0+        | otherwise  = length seps + 1+  return degree++-- | 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 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]+splitTuple_maybe t = go [] t+  where go args (t1 `AppT` t2) = go (t2:args) t1+        go args (t1 `SigT` _k) = go args t1+        go args (ConT con_name)+          | Just degree <- tupleNameDegree_maybe con_name+          , length args == degree+          = Just args+        go args (TupleT degree)+          | length args == degree+          = Just args+        go _ _ = Nothing++-- | The type variable binders in a @forall@. This is not used by the TH AST+-- itself, but this is used as an intermediate data type in 'FAForalls'.+data ForallTelescope+  = ForallVis [TyVarBndrUnit]+    -- ^ A visible @forall@ (e.g., @forall a -> {...}@).+    --   These do not have any notion of specificity, so we use+    --   '()' as a placeholder value in the 'TyVarBndr's.+  | ForallInvis [TyVarBndrSpec]+    -- ^ An invisible @forall@ (e.g., @forall a {b} c -> {...}@),+    --   where each binder has a 'Specificity'.+  deriving (Eq, Show, Data)++-- | The list of arguments in a function 'Type'.+data FunArgs+  = FANil+    -- ^ No more arguments.+  | FAForalls ForallTelescope FunArgs+    -- ^ A series of @forall@ed type variables followed by a dot (if+    --   'ForallInvis') or an arrow (if 'ForallVis'). For example,+    --   the type variables @a1 ... an@ in @forall a1 ... an. r@.+  | FACxt Cxt FunArgs+    -- ^ A series of constraint arguments followed by @=>@. For example,+    --   the @(c1, ..., cn)@ in @(c1, ..., cn) => r@.+  | FAAnon Type FunArgs+    -- ^ An anonymous argument followed by an arrow. For example, the @a@+    --   in @a -> r@.+  deriving (Eq, Show, Data)++-- | A /visible/ function argument type (i.e., one that must be supplied+-- explicitly in the source code). This is in contrast to /invisible/+-- arguments (e.g., the @c@ in @c => r@), which are instantiated without+-- the need for explicit user input.+data VisFunArg+  = VisFADep TyVarBndrUnit+    -- ^ A visible @forall@ (e.g., @forall a -> a@).+  | VisFAAnon Type+    -- ^ An anonymous argument followed by an arrow (e.g., @a -> r@).+  deriving (Eq, Show, Data)++-- | Filter the visible function arguments from a list of 'FunArgs'.+filterVisFunArgs :: FunArgs -> [VisFunArg]+filterVisFunArgs FANil = []+filterVisFunArgs (FAForalls tele args) =+  case tele of+    ForallVis tvbs -> map VisFADep tvbs ++ args'+    ForallInvis _  -> args'+  where+    args' = filterVisFunArgs args+filterVisFunArgs (FACxt _ args) =+  filterVisFunArgs args+filterVisFunArgs (FAAnon t args) =+  VisFAAnon t:filterVisFunArgs args++-- | Reconstruct an arrow 'Type' from its argument and result types.+ravelType :: FunArgs -> Type -> Type+ravelType FANil res = res+-- We need a special case for FAForalls ForallInvis followed by FACxt so that we may+-- collapse them into a single ForallT when raveling.+-- See Note [Desugaring and sweetening ForallT] in L.H.T.Desugar.Core.+ravelType (FAForalls (ForallInvis tvbs) (FACxt p args)) res =+  ForallT tvbs p (ravelType args res)+ravelType (FAForalls (ForallInvis  tvbs)  args)  res = ForallT tvbs [] (ravelType args res)+ravelType (FAForalls (ForallVis   _tvbs) _args) _res =+#if __GLASGOW_HASKELL__ >= 809+      ForallVisT _tvbs (ravelType _args _res)+#else+      error "Visible dependent quantification supported only on GHC 8.10+"+#endif+ravelType (FACxt cxt args) res = ForallT [] cxt (ravelType args res)+ravelType (FAAnon t args)  res = AppT (AppT ArrowT t) (ravelType args res)++-- | Decompose a function 'Type' into its arguments (the 'FunArgs') and its+-- result type (the 'Type).+unravelType :: Type -> (FunArgs, Type)+unravelType (ForallT tvbs cxt ty) =+  let (args, res) = unravelType ty in+  (FAForalls (ForallInvis tvbs) (FACxt cxt args), res)+unravelType (AppT (AppT ArrowT t1) t2) =+  let (args, res) = unravelType t2 in+  (FAAnon t1 args, res)+#if __GLASGOW_HASKELL__ >= 809+unravelType (ForallVisT tvbs ty) =+  let (args, res) = unravelType ty in+  (FAForalls (ForallVis tvbs) args, res)+#endif+unravelType t = (FANil, t)++-- | Remove all of the explicit kind signatures from a 'Type'.+unSigType :: Type -> Type+unSigType (SigT t _) = t+unSigType (AppT f x) = AppT (unSigType f) (unSigType x)+unSigType (ForallT tvbs ctxt t) =+  ForallT tvbs (map unSigPred ctxt) (unSigType t)+unSigType (InfixT t1 n t2)  = InfixT (unSigType t1) n (unSigType t2)+unSigType (UInfixT t1 n t2) = UInfixT (unSigType t1) n (unSigType t2)+unSigType (ParensT t)       = ParensT (unSigType t)+#if __GLASGOW_HASKELL__ >= 807+unSigType (AppKindT t k)       = AppKindT (unSigType t) (unSigType k)+unSigType (ImplicitParamT n t) = ImplicitParamT n (unSigType t)+#endif+unSigType t = t++-- | Remove all of the explicit kind signatures from a 'Pred'.+unSigPred :: Pred -> Pred+unSigPred = unSigType++-- | Decompose an applied type into its individual components. For example, this:+--+-- @+-- Proxy \@Type Char+-- @+--+-- would be unfolded to this:+--+-- @+-- ('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 (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+#endif+#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').+--+-- 'TypeArg' is useful when decomposing an application of a 'Type' to its+-- arguments (e.g., in 'unfoldType').+data TypeArg+  = TANormal Type+  | TyArg Kind+  deriving (Eq, Show, Data)++-- | Apply one 'Type' to a list of arguments.+applyType :: Type -> [TypeArg] -> Type+applyType = foldl apply+  where+    apply :: Type -> TypeArg -> Type+    apply f (TANormal x) = f `AppT` x+    apply f (TyArg _x)   =+#if __GLASGOW_HASKELL__ >= 807+                           f `AppKindT` _x+#else+                           -- VKA isn't supported, so+                           -- conservatively drop the argument+                           f+#endif++-- | Filter the normal type arguments from a list of 'TypeArg's.+filterTANormals :: [TypeArg] -> [Type]+filterTANormals = mapMaybe getTANormal+  where+    getTANormal :: TypeArg -> Maybe Type+    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.+probablyWrongUnTypeArg :: TypeArg -> Type+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.+----------------------------------------++-- | Check if a name occurs anywhere within a TH tree.+nameOccursIn :: Data a => Name -> a -> Bool+nameOccursIn n = everything (||) $ mkQ False (== n)++-- | Extract all Names mentioned in a TH tree.+allNamesIn :: Data a => a -> [Name]+allNamesIn = everything (++) $ mkQ [] (:[])++-- | 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+extractBoundNamesStmt (NoBindS _)   = OS.empty+extractBoundNamesStmt (ParS stmtss) = foldMap (foldMap extractBoundNamesStmt) stmtss+#if __GLASGOW_HASKELL__ >= 807+extractBoundNamesStmt (RecS stmtss) = foldMap extractBoundNamesStmt stmtss+#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@.+--+-- 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+extractBoundNamesPat (TupP pats)           = foldMap extractBoundNamesPat pats+extractBoundNamesPat (UnboxedTupP pats)    = foldMap extractBoundNamesPat pats+extractBoundNamesPat (ConP _+#if __GLASGOW_HASKELL__ >= 901+                             _+#endif+                               pats)       = foldMap extractBoundNamesPat pats+extractBoundNamesPat (InfixP p1 _ p2)      = extractBoundNamesPat p1 `OS.union`+                                             extractBoundNamesPat p2+extractBoundNamesPat (UInfixP p1 _ p2)     = extractBoundNamesPat p1 `OS.union`+                                             extractBoundNamesPat p2+extractBoundNamesPat (ParensP pat)         = extractBoundNamesPat pat+extractBoundNamesPat (TildeP pat)          = extractBoundNamesPat pat+extractBoundNamesPat (BangP pat)           = extractBoundNamesPat pat+extractBoundNamesPat (AsP name pat)        = OS.singleton name `OS.union`+                                             extractBoundNamesPat pat+extractBoundNamesPat WildP                 = OS.empty+extractBoundNamesPat (RecP _ field_pats)   = let (_, pats) = unzip field_pats in+                                             foldMap extractBoundNamesPat pats+extractBoundNamesPat (ListP pats)          = foldMap extractBoundNamesPat pats+extractBoundNamesPat (SigP pat _)          = extractBoundNamesPat pat+extractBoundNamesPat (ViewP _ pat)         = extractBoundNamesPat pat+#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+----------------------------------------++-- dirty implementation of explicit-to-implicit conversion+newtype MagicIP name a r = MagicIP (IP name a => r)++-- | Get an implicit param constraint (@IP name a@, which is the desugared+-- form of @(?name :: a)@) from an explicit value.+--+-- This function is only available with GHC 8.0 or later.+bindIP :: forall name a r. a -> (IP name a => r) -> r+bindIP val k = (unsafeCoerce (MagicIP @name k) :: a -> r) val++-- like GHC's+splitAtList :: [a] -> [b] -> ([b], [b])+splitAtList [] x = ([], x)+splitAtList (_ : t) (x : xs) =+  let (as, bs) = splitAtList t xs in+  (x : as, bs)+splitAtList (_ : _) [] = ([], [])++thdOf3 :: (a,b,c) -> c+thdOf3 (_,_,c) = c++liftFst :: (a -> b) -> (a, c) -> (b, c)+liftFst f (a,c) = (f a, c)++liftSnd :: (a -> b) -> (c, a) -> (c, b)+liftSnd f (c,a) = (c, f a)++thirdOf3 :: (a -> b) -> (c, d, a) -> (c, d, b)+thirdOf3 f (c, d, a) = (c, d, f a)++-- lift concatMap into a monad+-- could this be more efficient?+-- | Concatenate the result of a @mapM@+concatMapM :: (Monad monad, Monoid monoid, Traversable t)+           => (a -> monad monoid) -> t a -> monad monoid+concatMapM fn list = do+  bss <- mapM fn list+  return $ fold bss++-- like GHC's+-- | Monadic version of mapAccumL+mapAccumLM :: Monad m+            => (acc -> x -> m (acc, y)) -- ^ combining function+            -> acc                      -- ^ initial state+            -> [x]                      -- ^ inputs+            -> m (acc, [y])             -- ^ final state, outputs+mapAccumLM _ s []     = return (s, [])+mapAccumLM f s (x:xs) = do+    (s1, x')  <- f s x+    (s2, xs') <- mapAccumLM f s1 xs+    return    (s2, x' : xs')++-- like GHC's+mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b]+mapMaybeM _ [] = return []+mapMaybeM f (x:xs) = do+  y <- f x+  ys <- mapMaybeM f xs+  return $ case y of+    Nothing -> ys+    Just z  -> z : ys++expectJustM :: Fail.MonadFail m => String -> Maybe a -> m a+expectJustM _   (Just x) = return x+expectJustM err Nothing  = Fail.fail err++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)+-- Identity ([10,20,30],"foo")+--+-- >>> everywhereM (mkM (pure . fmap (*10) :: [Integer] -> Identity [Integer])) ([1,2,3] :: [Integer], "foo" :: String)+-- Identity ([10,200,3000],"foo")+topEverywhereM :: (Typeable a, Data b, Monad m) => (a -> m a) -> b -> m b+topEverywhereM handler =+  gmapM (topEverywhereM handler) `extM` handler++-- Checks if a String names a valid Haskell infix data constructor+-- (i.e., does it begin with a colon?).+isInfixDataCon :: String -> Bool+isInfixDataCon (':':_) = True+isInfixDataCon _ = False++-- | Returns 'True' if the argument 'Name' is that of 'Kind.Type'+-- (or @*@ or 'Kind.★', to support older GHCs).+isTypeKindName :: Name -> Bool+isTypeKindName n = n == typeKindName+#if __GLASGOW_HASKELL__ < 805+                || n == starKindName+                || n == uniStarKindName+#endif++-- | The 'Name' of the kind 'Kind.Type'.+-- 2. The kind @*@ on older GHCs.+typeKindName :: Name+typeKindName = ''Kind.Type++#if __GLASGOW_HASKELL__ < 805+-- | The 'Name' of the kind @*@.+starKindName :: Name+starKindName = ''(Kind.*)++-- | The 'Name' of the kind 'Kind.★'.+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
@@ -1,7 +1,8 @@ `th-desugar` Package ==================== -[![Build Status](https://travis-ci.org/goldfirere/th-desugar.png?branch=master)](https://travis-ci.org/goldfirere/th-desugar)+[![Hackage](https://img.shields.io/hackage/v/th-desugar.svg)](http://hackage.haskell.org/package/th-desugar)+[![Build Status](https://github.com/goldfirere/th-desugar/workflows/Haskell-CI/badge.svg)](https://github.com/goldfirere/th-desugar/actions?query=workflow%3AHaskell-CI)  This package provides the `Language.Haskell.TH.Desugar` module, which desugars Template Haskell's rich encoding of Haskell syntax into a simpler encoding.@@ -22,3 +23,389 @@ possible.  I will try to keep this package up-to-date with respect to changes in GHC.+The minimum supported version of GHC is 8.0, which was chosen to avoid various+Template Haskell bugs in older GHC versions that affect how this library+desugars code. If this choice negatively impacts you, please submit a bug+report.++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.+For instance, `th-desugar` desugars all Haskell98-style constructors to use+GADT syntax, so the following:++```haskell+data T (a :: k) = MkT (Proxy a)+```++Will be desugared to something like this:++```haskell+data T (a :: k) where+  MkT :: forall k (a :: k). Proxy a -> T (a :: k)+```++Notice that `k` is explicitly quantified in the type of `MkT`. This is due to+an additional pass that `th-desugar` performs over the type variable binders+of `T` to extract all implicitly quantified variables and make them explicit.+This makes the desugared types forwards-compatible with a+[future version of GHC](https://github.com/goldfirere/ghc-proposals/blob/bbefbee6fc0cddb10bbacc85f79e66c2706ce13f/proposals/0000-no-kind-vars.rst)+that requires all kind variables in a top-level `forall` to be explicitly+quantified.++This process of extracting all implicitly quantified kind variables is not+perfect, however. There are some obscure programs that will cause `th-desugar`+to produce type variable binders that are ill scoped. Here is one example:++```haskell+data P k (a :: k)+data Foo (a :: Proxy j) (b :: k) c = MkFoo c (P k j)+```++If you squint hard at `MkFoo`, you'll notice that `j :: k`. However, this+relationship is not expressed _syntactically_, which means that `th-desugar`+will not be aware of it. Therefore, `th-desugar` will desugar `Foo` to:++```haskell+data Foo (a :: Proxy j) (b :: k) c where+  MkFoo :: forall j k (a :: Proxy j) (b :: k) c.+           c -> P k j -> Foo (a :: Proxy j) (b :: k) c+```++This is incorrect since `k` must come before `j` in order to be well scoped.+There is a workaround to this issue, however: add more explicit kind+information. If you had instead written this:++```haskell+data Foo (a :: Proxy (j :: k)) (b :: k) c = MkFoo c (P k j)+```++Then the fact that `j :: k` is expressed directly in the AST, so `th-desugar`+is able to pick up on it and pick `forall k j (a :: Proxy j) (b :: k) c. <...>`+as the telescope for the type of `MkFoo`.++The following constructs are known to be susceptible to this issue:++1. Desugared Haskell98-style constructors+2. Locally reified class methods+3. Locally reified record selectors+4. Locally reified data constructors+5. Locally reified type family instances (on GHC 8.8 and later, in which the+   Template Haskell AST supports explicit `foralls` in type family equations)++## Limited support for linear types++Currently, the `th-desugar` AST deliberately makes it impossible to represent+linear types, and desugaring a linear function arrow will simply turn into a+normal function arrow `(->)`. This choice is partly motivated by issues in the+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
@@ -1,24 +1,24 @@ {- Tests for the th-desugar package  (c) Richard Eisenberg 2013-eir@cis.upenn.edu+rae@cs.brynmawr.edu -}  {-# LANGUAGE TemplateHaskell, GADTs, PolyKinds, TypeFamilies,              MultiParamTypeClasses, FunctionalDependencies,              FlexibleInstances, DataKinds, CPP, RankNTypes,              StandaloneDeriving, DefaultSignatures,-             ConstraintKinds #-}-#if __GLASGOW_HASKELL__ >= 707-{-# LANGUAGE RoleAnnotations #-}+             ConstraintKinds, RoleAnnotations, DeriveAnyClass #-}+#if __GLASGOW_HASKELL__ >= 810+{-# LANGUAGE StandaloneKindSignatures #-} #endif--{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-name-shadowing #-}--#if __GLASGOW_HASKELL__ >= 711-{-# OPTIONS_GHC -Wno-redundant-constraints #-}+#if __GLASGOW_HASKELL__ >= 907+{-# LANGUAGE TypeAbstractions #-} #endif +{-# OPTIONS_GHC -Wno-orphans -Wno-name-shadowing+                -Wno-redundant-constraints #-}+ module Dec where  import qualified Splices as S@@ -34,11 +34,30 @@ $(S.dectest8) $(S.dectest9) $(S.dectest10)-#if __GLASGOW_HASKELL__ >= 709 $(S.dectest11)-#endif $(S.dectest12) $(S.dectest13)+$(S.dectest14)++$(S.dectest15)++#if __GLASGOW_HASKELL__ >= 802+$(S.dectest16)+$(S.dectest17)+#endif++#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
@@ -1,32 +1,36 @@ {- Tests for the th-desugar package  (c) Richard Eisenberg 2013-eir@cis.upenn.edu+rae@cs.brynmawr.edu -}  {-# LANGUAGE TemplateHaskell, GADTs, PolyKinds, TypeFamilies,              MultiParamTypeClasses, FunctionalDependencies,              FlexibleInstances, DataKinds, CPP, RankNTypes,              StandaloneDeriving, DefaultSignatures,-             ConstraintKinds #-}-#if __GLASGOW_HASKELL__ >= 707-{-# LANGUAGE RoleAnnotations #-}+             ConstraintKinds, RoleAnnotations, DeriveAnyClass,+             TypeApplications #-}+#if __GLASGOW_HASKELL__ >= 801+{-# LANGUAGE DerivingStrategies #-} #endif--{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-incomplete-patterns-                -fno-warn-name-shadowing #-}--#if __GLASGOW_HASKELL__ >= 711-{-# OPTIONS_GHC -Wno-redundant-constraints #-}+#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 #-}+ module DsDec where  import qualified Splices as S import Splices ( dsDecSplice, unqualify ) -import Language.Haskell.TH  ( reportError )+import qualified Language.Haskell.TH.Datatype.TyVarBndr as THAbs import Language.Haskell.TH.Desugar+import Language.Haskell.TH.Syntax ( qReport )  import Control.Monad @@ -47,34 +51,53 @@ $(dsDecSplice (fmap unqualify S.imp_inst_test3)) $(dsDecSplice (fmap unqualify S.imp_inst_test4)) -#if __GLASGOW_HASKELL__ < 707-$(return $ decsToTH [S.ds_dectest10])-#else $(dsDecSplice S.dectest10)-#endif -#if __GLASGOW_HASKELL__ >= 709 $(dsDecSplice S.dectest11) $(dsDecSplice S.standalone_deriving_test)++#if __GLASGOW_HASKELL__ >= 801+$(dsDecSplice S.deriv_strat_test) #endif  $(dsDecSplice S.dectest12) $(dsDecSplice S.dectest13)+$(dsDecSplice S.dectest14) +$(dsDecSplice S.dectest15)++#if __GLASGOW_HASKELL__ >= 802+$(return $ decsToTH [S.ds_dectest16])+$(return $ decsToTH [S.ds_dectest17])+#endif++#if __GLASGOW_HASKELL__ >= 809+$(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-     [DDataD nd [] name [DPlainTV tvbName] cons []] <- dsDecs decs-     let arg_ty = (DConT name) `DAppT` (DVarT tvbName)-     recsels <- fmap concat $ mapM (getRecordSelectors arg_ty) cons-     let num_sels = length recsels `div` 2 -- ignore type sigs-     when (num_sels /= S.rec_sel_test_num_sels) $-       reportError $ "Wrong number of record selectors extracted.\n"-                  ++ "Wanted " ++ show S.rec_sel_test_num_sels-                  ++ ", Got " ++ show num_sels-     let unrecord c@(DCon _ _ _ (DNormalC {}) _) = c-         unrecord (DCon tvbs cxt con_name (DRecC fields) rty) =-           let (_names, stricts, types) = unzip3 fields-               fields' = zip stricts types-           in-           DCon tvbs cxt con_name (DNormalC fields') rty-         plaindata = [DDataD nd [] name [DPlainTV tvbName] (map unrecord cons) []]-     return (decsToTH plaindata ++ map letDecToTH recsels))+     withLocalDeclarations decs $ do+       [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) $+         qReport True $ "Wrong number of record selectors extracted.\n"+                     ++ "Wanted " ++ show S.rec_sel_test_num_sels+                     ++ ", Got " ++ show num_sels+       let unrecord c@(DCon _ _ _ (DNormalC {}) _) = c+           unrecord (DCon tvbs cxt con_name (DRecC fields) rty) =+             let (_names, stricts, types) = unzip3 fields+                 fields' = zip stricts types+             in+             DCon tvbs cxt con_name (DNormalC False fields') rty+           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
@@ -0,0 +1,121 @@+{-# 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+-- This is kept in a separate module from ReifyTypeSigs to isolate the use of+-- the -XCUSKs language extension.+module ReifyTypeCUSKs where++import Data.Kind (Type)+import GHC.Exts (Constraint)+import Language.Haskell.TH.Desugar+import Language.Haskell.TH.Syntax hiding (Type)+import Splices (eqTH)++test_reify_type_cusks, test_reify_type_no_cusks :: [Bool]+(test_reify_type_cusks, test_reify_type_no_cusks) =+  $(do cusk_decls <-+         [d| data A1 (a :: Type)+             type A2 (a :: Type) = (a :: Type)+             type family A3 a+             data family A4 a+             type family A5 (a :: Type) :: Type where+               A5 a = a+             class A6 (a :: Type) where+               type A7 a b++             data A8 (a :: k) :: k -> Type+#if __GLASGOW_HASKELL__ >= 804+             data A9 (a :: j) :: forall k. k -> Type+#endif+#if __GLASGOW_HASKELL__ >= 809+             data A10 (k :: Type) (a :: k)+             data A11 :: forall k -> k -> Type+#endif+           |]++       no_cusk_decls <-+         [d| data B1 a+             type B2 (a :: Type) = a+             type B3 a = (a :: Type)+             type family B4 (a :: Type) where+               B4 a = a+             type family B5 a :: Type where+               B5 a = a+             class B6 a where+               type B7 (a :: Type) (b :: Type) :: Type++             data B8 :: k -> Type+#if __GLASGOW_HASKELL__ >= 804+             data B9 :: forall j. j -> k -> Type+#endif+           |]++       let test_reify_kind :: DsMonad q+                           => String -> (Int, Maybe DKind) -> q Bool+           test_reify_kind prefix (i, expected_kind) = do+             actual_kind <- dsReifyType $ mkName $ prefix ++ show i+             return $ expected_kind `eqTH` actual_kind++           typeKind :: DKind+           typeKind = DConT typeKindName++           type_to_type :: DKind+           type_to_type = DArrowT `DAppT` typeKind `DAppT` typeKind++       cusk_decl_bools <-+         withLocalDeclarations cusk_decls $+         traverse (\(i, k) -> test_reify_kind "A" (i, Just k)) $+           [ (1, type_to_type)+           , (2, type_to_type)+           , (3, type_to_type)+           , (4, type_to_type)+           , (5, type_to_type)+           , (6, DArrowT `DAppT` typeKind `DAppT` DConT ''Constraint)+           , (7, DArrowT `DAppT` typeKind `DAppT` type_to_type)+           ]+           +++           [ (8, let k = mkName "k" in+                 DForallT (DForallInvis [DPlainTV k SpecifiedSpec]) $+                 DArrowT `DAppT` DVarT k `DAppT`+                   (DArrowT `DAppT` DVarT k `DAppT` typeKind))+           ]+#if __GLASGOW_HASKELL__ >= 804+           +++           [ (9, let j = mkName "j"+                     k = mkName "k" in+                 DForallT (DForallInvis [DPlainTV j SpecifiedSpec]) $+                 DArrowT `DAppT` DVarT j `DAppT`+                   (DForallT (DForallInvis [DPlainTV k SpecifiedSpec]) $+                    DArrowT `DAppT` DVarT k `DAppT` typeKind))+           ]+#endif+#if __GLASGOW_HASKELL__ >= 809+           +++           [ (10, let k = mkName "k" in+                  DForallT (DForallVis [DKindedTV k () typeKind]) $+                  DArrowT `DAppT` DVarT k `DAppT` typeKind)+           , (11, let k = mkName "k" in+                  DForallT (DForallVis [DPlainTV k ()]) $+                  DArrowT `DAppT` DVarT k `DAppT` typeKind)+           ]+#endif++       no_cusk_decl_bools <-+         withLocalDeclarations no_cusk_decls $+         traverse (test_reify_kind "B") $+           map (, Nothing) $+                [1..7]+             ++ [8]+#if __GLASGOW_HASKELL__ >= 804+             ++ [9]+#endif+       lift (cusk_decl_bools, no_cusk_decl_bools))
+ Test/ReifyTypeSigs.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+#if __GLASGOW_HASKELL__ >= 809+{-# LANGUAGE StandaloneKindSignatures #-}+#endif+module ReifyTypeSigs where++#if __GLASGOW_HASKELL__ >= 809+import Data.Kind+import Data.Proxy+#endif+import Language.Haskell.TH.Desugar+import Language.Haskell.TH.Syntax hiding (Type)+import Splices (eqTH)++test_reify_kind_sigs :: [Bool]+test_reify_kind_sigs =+  $(do kind_sig_decls <-+         [d|+#if __GLASGOW_HASKELL__ >= 809+             type A1 :: forall k. k -> Type+             data A1 a++             type A2 :: k -> Type+             type A2 a = a++             type A3 :: forall k. k -> Type+             type family A3++             type A4 :: forall k. k -> Type+             data family A4 a++             type A5 :: k -> Type+             type family A5 a where+               A5 a = a++             type A6 :: forall (k :: Bool) -> Proxy k -> Constraint+             class A6 a b where+               type A7 a c+#endif+           |]++       let test_reify_kind :: DsMonad q+                           => (Int, DKind) -> q Bool+           test_reify_kind (i, expected_kind) = do+             actual_kind <- dsReifyType $ mkName $ "A" ++ show i+             return $ Just expected_kind `eqTH` actual_kind++       kind_sig_decl_bools <-+         withLocalDeclarations kind_sig_decls $+         traverse test_reify_kind $+           []+#if __GLASGOW_HASKELL__ >= 809+           +++           let k = mkName "k"+               typeKind = DConT typeKindName+               boolKind = DConT ''Bool+               k_to_type = DArrowT `DAppT` DVarT k `DAppT` typeKind+               forall_k_invis_k_to_type =+                 DForallT (DForallInvis [DPlainTV k SpecifiedSpec]) k_to_type in+           [ (1, forall_k_invis_k_to_type)+           , (2, k_to_type)+           , (3, forall_k_invis_k_to_type)+           , (4, forall_k_invis_k_to_type)+           , (5, k_to_type)+           , (6, DForallT (DForallVis [DKindedTV k () boolKind]) $+                 DArrowT `DAppT` (DConT ''Proxy `DAppT` DVarT k)+                         `DAppT` DConT ''Constraint)+           , (7, DArrowT `DAppT` boolKind `DAppT`+                   (DArrowT `DAppT` typeKind `DAppT` typeKind))+           ]+#endif++       lift kind_sig_decl_bools)
Test/Run.hs view
@@ -1,24 +1,53 @@ {- Tests for the th-desugar package  (c) Richard Eisenberg 2013-eir@cis.upenn.edu+rae@cs.brynmawr.edu -}  {-# LANGUAGE TemplateHaskell, UnboxedTuples, ParallelListComp, CPP,-             RankNTypes, ImpredicativeTypes, TypeFamilies,+             RankNTypes, TypeFamilies,              DataKinds, ConstraintKinds, PolyKinds, MultiParamTypeClasses,-             FlexibleInstances, ExistentialQuantification #-}-{-# OPTIONS -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns-            -fno-warn-unused-matches -fno-warn-type-defaults-            -fno-warn-missing-signatures -fno-warn-unused-do-bind #-}+             FlexibleInstances, ExistentialQuantification,+             ScopedTypeVariables, GADTs, ViewPatterns, TupleSections,+             TypeOperators, PartialTypeSignatures, PatternSynonyms,+             TypeApplications, MagicHash #-}+{-# OPTIONS -Wno-incomplete-patterns -Wno-overlapping-patterns+            -Wno-unused-matches -Wno-type-defaults+            -Wno-missing-signatures -Wno-unused-do-bind+            -Wno-missing-fields -Wno-incomplete-record-updates+            -Wno-partial-type-signatures -Wno-redundant-constraints #-} -#if __GLASGOW_HASKELL__ >= 711-{-# LANGUAGE PartialTypeSignatures #-}-{-# OPTIONS_GHC -Wno-partial-type-signatures -Wno-redundant-constraints #-}+#if __GLASGOW_HASKELL__ >= 805+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE QuantifiedConstraints #-} #endif -module Run where+#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 )  import Test.HUnit@@ -29,22 +58,44 @@ import qualified DsDec import qualified Dec import Dec ( RecordSel )+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-#if __GLASGOW_HASKELL__ >= 707+import qualified Language.Haskell.TH.Desugar.OSet as OS import Language.Haskell.TH.Desugar.Expand  ( expandUnsoundly )-#endif 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-#if __GLASGOW_HASKELL__ < 709-import Control.Applicative-#endif -#if __GLASGOW_HASKELL__ >= 707+import qualified Data.Map as M 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.@@ -74,10 +125,8 @@              , "case"     ~: $test8_case      @=? $(dsSplice test8_case)              , "do"       ~: $test9_do        @=? $(dsSplice test9_do)              , "comp"     ~: $test10_comp     @=? $(dsSplice test10_comp)-#if __GLASGOW_HASKELL__ >= 707              , "parcomp"  ~: $test11_parcomp  @=? $(dsSplice test11_parcomp)              , "parcomp2" ~: $test12_parcomp2 @=? $(dsSplice test12_parcomp2)-#endif              , "sig"      ~: $test13_sig      @=? $(dsSplice test13_sig)              , "record"   ~: $test14_record   @=? $(dsSplice test14_record)              , "litp"     ~: $test15_litp     @=? $(dsSplice test15_litp)@@ -88,8 +137,9 @@              , "asp"      ~: $test20_asp      @=? $(dsSplice test20_asp)              , "wildp"    ~: $test21_wildp    @=? $(dsSplice test21_wildp)              , "listp"    ~: $test22_listp    @=? $(dsSplice test22_listp)--- type signatures in patterns not yet handled by Template Haskell---           , "sigp"     ~: $test23_sigp     @=? $(dsSplice test23_sigp)+#if __GLASGOW_HASKELL__ >= 801+             , "sigp"     ~: $test23_sigp     @=? $(dsSplice test23_sigp)+#endif              , "fun"      ~: $test24_fun      @=? $(dsSplice test24_fun)              , "fun2"     ~: $test25_fun2     @=? $(dsSplice test25_fun2)              , "forall"   ~: $test26_forall   @=? $(dsSplice test26_forall)@@ -101,14 +151,70 @@              , "tylit"    ~: $test32_tylit    @=? $(dsSplice test32_tylit)              , "tvbs"     ~: $test33_tvbs     @=? $(dsSplice test33_tvbs)              , "let_as"   ~: $test34_let_as   @=? $(dsSplice test34_let_as)-#if __GLASGOW_HASKELL__ >= 709              , "pred"     ~: $test37_pred     @=? $(dsSplice test37_pred)              , "pred2"    ~: $test38_pred2    @=? $(dsSplice test38_pred2)              , "eq"       ~: $test39_eq       @=? $(dsSplice test39_eq)-#endif-#if __GLASGOW_HASKELL__ >= 711              , "wildcard" ~: $test40_wildcards@=? $(dsSplice test40_wildcards)+#if __GLASGOW_HASKELL__ >= 801+             , "typeapps"   ~: $test41_typeapps   @=? $(dsSplice test41_typeapps)+             , "scoped_tvs" ~: $test42_scoped_tvs @=? $(dsSplice test42_scoped_tvs)+             , "ubx_sums"   ~: $test43_ubx_sums   @=? $(dsSplice test43_ubx_sums) #endif+             , "let_pragma" ~: $test44_let_pragma @=? $(dsSplice test44_let_pragma)+--             , "empty_rec"  ~: $test45_empty_record_con @=? $(dsSplice test45_empty_record_con)+        -- This one can't be tested by this means, because it contains an "undefined"+#if __GLASGOW_HASKELL__ >= 803+             , "over_label" ~: $test46_overloaded_label @=? $(dsSplice test46_overloaded_label)+#endif+             , "do_partial_match" ~: $test47_do_partial_match @=? $(dsSplice test47_do_partial_match)+#if __GLASGOW_HASKELL__ >= 805+             , "quantified_constraints" ~: $test48_quantified_constraints @=? $(dsSplice test48_quantified_constraints)+#endif+#if __GLASGOW_HASKELL__ >= 807+             , "implicit_params" ~: $test49_implicit_params @=? $(dsSplice test49_implicit_params)+             , "vka"             ~: $test50_vka             @=? $(dsSplice test50_vka)+#endif+#if __GLASGOW_HASKELL__ >= 809+             , "tuple_sections"  ~: $test51_tuple_sections  @=? $(dsSplice test51_tuple_sections)+#endif+#if __GLASGOW_HASKELL__ >= 900+             , "qual_do"         ~: $test52_qual_do         @=? $(dsSplice test52_qual_do)+#endif+#if __GLASGOW_HASKELL__ >= 901+             , "vta_in_con_pats" ~: $test53_vta_in_con_pats @=? $(dsSplice test53_vta_in_con_pats)+#endif+#if __GLASGOW_HASKELL__ >= 902+             , "overloaded_record_dot" ~: $test54_overloaded_record_dot @=? $(dsSplice test54_overloaded_record_dot)+#endif+#if __GLASGOW_HASKELL__ >= 903+             , "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@@ -119,7 +225,6 @@ test_e3b = $(test_expand3 >>= dsExp >>= expand >>= return . expToTH) test_e4a = $test_expand4 test_e4b = $(test_expand4 >>= dsExp >>= expand >>= return . expToTH)-#if __GLASGOW_HASKELL__ >= 707 test_e5a = $test_expand5 test_e5b = $(test_expand5 >>= dsExp >>= expand >>= return . expToTH) test_e6a = $test_expand6@@ -127,11 +232,16 @@ test_e7a = $test_expand7 test_e7b = $(test_expand7 >>= dsExp >>= expand >>= return . expToTH) test_e7c = $(test_expand7 >>= dsExp >>= expandUnsoundly >>= return . expToTH)+#if __GLASGOW_HASKELL__ < 801 test_e8a = $(test_expand8 >>= dsExp >>= expand >>= return . expToTH)-  -- the line above should fail once GHC#8953 is fixed for closed type-  -- families-test_e8b = $(test_expand8 >>= dsExp >>= expandUnsoundly >>= return . expToTH)+  -- This won't expand on recent GHCs now that GHC Trac #8953 is fixed for+  -- closed type families. #endif+test_e8b = $(test_expand8 >>= dsExp >>= expandUnsoundly >>= return . expToTH)+test_e9a = $test_expand9  -- requires GHC #9262+test_e9b = $(test_expand9 >>= dsExp >>= expand >>= return . expToTH)+test_e10a = $test_expand10+test_e10b = $(test_expand10 >>= dsExp >>= expand >>= return . expToTH)  hasSameType :: a -> a -> Bool hasSameType _ _ = True@@ -141,13 +251,16 @@                   , hasSameType test36a test36b                   , hasSameType test_e3a test_e3b                   , hasSameType test_e4a test_e4b-#if __GLASGOW_HASKELL__ >= 707                   , hasSameType test_e5a test_e5b                   , hasSameType test_e6a test_e6b                   , hasSameType test_e7a test_e7b                   , hasSameType test_e7a test_e7c+#if __GLASGOW_HASKELL__ < 801                   , hasSameType test_e8a test_e8a #endif+                  , hasSameType test_e8b test_e8b+                  , hasSameType test_e9a test_e9b+                  , hasSameType test_e10a test_e10b                   ]  test_dec :: [Bool]@@ -168,14 +281,12 @@ test_bug8884 :: Bool test_bug8884 = $(do info <- reify ''Poly                     dinfo@(DTyConI (DOpenTypeFamilyD (DTypeFamilyHead _name _tvbs (DKindSig resK) _ann))-                                   (Just [DTySynInstD _name2 (DTySynEqn lhs _rhs)]))+                                   (Just [DTySynInstD (DTySynEqn _ lhs _rhs)]))                       <- dsInfo info-                    case (resK, lhs) of-#if __GLASGOW_HASKELL__ < 709-                      (DStarT, [DVarT _]) -> [| True |]-#else-                      (DStarT, [DSigT (DVarT _) (DVarT _)]) -> [| True |]-#endif+                    let isTypeKind (DConT n) = isTypeKindName n+                        isTypeKind _         = False+                    case (isTypeKind resK, lhs) of+                      (True, _ `DAppT` DSigT (DVarT _) (DVarT _)) -> [| True |]                       _                                     -> do                         runIO $ do                           putStrLn "Failed bug8884 test:"@@ -184,10 +295,10 @@  flatten_dvald :: Bool flatten_dvald = let s1 = $(flatten_dvald_test)-                    s2 = $(do exp <- flatten_dvald_test-                              DLetE ddecs dexp <- dsExp exp+                    s2 = $(do expr <- flatten_dvald_test+                              DLetE ddecs dexpr <- dsExp expr                               flattened <- fmap concat $ mapM flattenDValD ddecs-                              return $ expToTH $ DLetE flattened dexp ) in+                              return $ expToTH $ DLetE flattened dexpr ) in                 s1 == s2  test_rec_sels :: Bool@@ -195,12 +306,614 @@                          return $ ListE bools)  test_standalone_deriving :: Bool-#if __GLASGOW_HASKELL__ >= 709 test_standalone_deriving = (MkBlarggie 5 'x') == (MkBlarggie 5 'x')++test_deriving_strategies :: Bool+#if __GLASGOW_HASKELL__ >= 801+test_deriving_strategies = compare (MkBlarggie 5 'x') (MkBlarggie 5 'x') == EQ #else-test_standalone_deriving = True+test_deriving_strategies = True #endif +test_local_tyfam_expansion :: Bool+test_local_tyfam_expansion =+  $(do fam_name <- newName "Fam"+       let orig_ty = DConT fam_name+       exp_ty <- withLocalDeclarations+                   (decsToTH [ DOpenTypeFamilyD (DTypeFamilyHead fam_name [] DNoSig Nothing)+                             , DTySynInstD (DTySynEqn Nothing+                                                      (DConT fam_name) (DConT ''Int)) ])+                   (expandType orig_ty)+       orig_ty `eqTHSplice` exp_ty)++test_stuck_tyfam_expansion :: Bool+test_stuck_tyfam_expansion =+  $(do fam_name <- newName "F"+       x        <- newName "x"+       k        <- newName "k"+       let orig_ty = DConT fam_name `DAppT` DConT '() -- F '()+       exp_ty <- withLocalDeclarations+                   (decsToTH [ -- type family F (x :: k) :: k+                               DOpenTypeFamilyD+                                 (DTypeFamilyHead fam_name+                                                  [DKindedTV x THAbs.BndrReq (DVarT k)]+                                                  (DKindSig (DVarT k))+                                                  Nothing)+                               -- type instance F (x :: ()) = x+                             , DTySynInstD+                                 (DTySynEqn Nothing+                                            (DConT fam_name `DAppT`+                                               DSigT (DVarT x) (DConT ''()))+                                            (DVarT x))+                             ])+                   (expandType orig_ty)+       orig_ty `eqTHSplice` exp_ty)++test_t85 :: Bool+test_t85 =+  $(do let orig_ty =+             (DConT ''Constant `DAppT` DConT ''Int `DAppT` DConT 'True)+             `DSigT` (DConT ''Constant `DAppT` DConT ''Char `DAppT` DConT ''Bool)+           expected_ty = DConT 'True `DSigT` DConT ''Bool+       expanded_ty <- expandType orig_ty+       expected_ty `eqTHSplice` expanded_ty)++test_t92 :: Bool+test_t92 =+  $(do a <- newName "a"+       f <- newName "f"+       let t = DForallT (DForallInvis [DPlainTV f SpecifiedSpec])+                        (DVarT f `DAppT` DVarT a)+       toposortTyVarsOf [t] `eqTHSplice` [DPlainTV a ()])++test_t97 :: Bool+test_t97 =+  $(do a <- newName "a"+       k <- newName "k"+       let orig_ty = DForallT+                       (DForallInvis+                         [DKindedTV a SpecifiedSpec+                                      (DConT ''Constant `DAppT` DConT ''Int+                                                        `DAppT` DVarT k)])+                       (DVarT a)+           expected_ty = DForallT (DForallInvis+                                    [DKindedTV a SpecifiedSpec (DVarT k)])+                                  (DVarT a)+       expanded_ty <- expandType orig_ty+       expected_ty `eqTHSplice` expanded_ty)++test_getDataD_kind_sig :: Bool+test_getDataD_kind_sig =+  3 == $(do data_name <- newName "TestData"+            a         <- newName "a"+            let type_kind     = DConT typeKindName+                data_kind_sig = DArrowT `DAppT` type_kind `DAppT`+                                  (DArrowT `DAppT` type_kind `DAppT` type_kind)+            (_, tvbs, _) <-+              withLocalDeclarations+                [decToTH (DDataD Data [] data_name [DPlainTV a THAbs.BndrReq]+                                 (Just data_kind_sig) [] [])]+                (getDataD "th-desugar: Impossible" data_name)+            [| $(Syn.lift (length tvbs)) |])++test_t100 :: Bool+test_t100 =+  $(do decs <- [d| data T b where+                     MkT :: forall a. { unT :: a } -> T a |]+       info <- withLocalDeclarations decs (dsReify (mkName "unT"))+       let -- forall a. T a -> a+           exp_ty = DForallT (DForallInvis [DPlainTV (mkName "a") SpecifiedSpec]) $+                    DArrowT `DAppT` (DConT (mkName "T") `DAppT` DVarT (mkName "a"))+                            `DAppT` DVarT (mkName "a")+       case info of+         Just (DVarI _ actual_ty _) -> exp_ty `eqTHSplice` actual_ty+         _                          -> [| False |])++test_t102 :: [Bool]+test_t102 =+  $(do decs1 <- [d| data Foo x where MkFoo :: forall a. { unFoo :: a } -> Foo a |]+       let b1 = withLocalDeclarations decs1 $ do+                  [DDataD _ _ _ _ _ cons1 _] <- dsDecs decs1+                  recs1 <- getRecordSelectors cons1+                  (length recs1 `div` 2) `eqTHSplice` 1+       decs2 <- [d| data HList l where+                      Nil  :: HList '[]+                      (:>) :: { hhead :: x, htail :: HList xs } -> HList (x ': xs) |]+       let b2 = withLocalDeclarations decs2 $ do+                  [DDataD _ _ _ _ _ cons2 _] <- dsDecs decs2+                  recs2 <- getRecordSelectors cons2+                  (length recs2 `div` 2) `eqTHSplice` 2+       [| [$b1, $b2] |])++test_t103 :: Bool+test_t103 =+  $(do decs <- [d| data P (a :: k) = MkP |]+       [DDataD _ _ _ _ _ [DCon tvbs _ _ _ _] _] <- dsDecs decs+       case tvbs of+         [DPlainTV k SpecifiedSpec, DKindedTV a SpecifiedSpec (DVarT k')]+           |  nameBase k == "k"+           ,  nameBase a == "a"+           ,  k == k'+           -> [| True |]+           |  otherwise+           -> [| False |])++test_t112 :: [Bool]+test_t112 =+  $(do a <- newName "a"+       b <- newName "b"+       let aVar = DVarT a+           bVar = DVarT b+           aTvb = DPlainTV a ()+           bTvb = DPlainTV b ()++           fvsABExpected = [aTvb, bTvb]+           fvsABActual   = toposortTyVarsOf [aVar, bVar]++           fvsBAExpected = [bTvb, aTvb]+           fvsBAActual   = toposortTyVarsOf [bVar, aVar]++           eqAB = fvsABExpected `eqTH` fvsABActual+           eqBA = fvsBAExpected `eqTH` fvsBAActual+       [| [eqAB, eqBA] |])++test_t132 :: Bool+test_t132 =+  $(do let c      = mkName "C"+           m      = mkName "m"+           a      = mkName "a"+           fixity = Fixity 5 InfixR+           -- Defines a class with a fixity declaration inside, i.e.,+           --+           --   class C a where+           --     infixr 5 `m`+           --     m :: a+           --+           -- We define this by hand to avoid GHC#17608 on pre-9.0 GHCs.+           decs = sweeten [ DClassD [] c [DPlainTV a THAbs.BndrReq] []+                            [ DLetDec (DInfixD fixity NoNamespaceSpecifier m)+                            , DLetDec (DSigD m (DVarT a))+                            ]+                          ]+           expected = Just fixity+       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+                     (:$$:) :: Int -> Int -> T+                  |]+       ddecs <- dsDecs decs+       let mb_is_infix = case ddecs of+                           [DDataD _ _ _ _ _ [DCon _ _ _ (DNormalC is_infix _) _] _]+                             -> Just is_infix+                           _ -> Nothing+       mb_is_infix `eqTHSplice` Just False)++-- Regression test for #159 which ensures that non-exhaustive functions throw+-- a runtime error before forcing their arguments.+test_t159 :: Expectation+test_t159 = do+  -- NB: Catch ErrorCall here, not PatternMatchFail. This is because we desugar+  -- non-exhaustive patterns into a custom `error` expression.+  let testOne f = f (let x = x in x) `shouldThrow` \(_ :: ErrorCall) -> True+  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 =+  $(do a <- newName "a"++       let -- (Show a => Show (Maybe a)) => String+           ty1 = DConstrainedT+                   [DConstrainedT [DConT ''Show `DAppT` DVarT a]+                                  (DConT ''Show `DAppT` (DConT ''Maybe `DAppT` DVarT a))]+                   (DConT ''String)+           b1 = fvDType ty1 `eqTH` OS.singleton a -- #93++       [| [b1] |])++test_kind_substitution :: [Bool]+test_kind_substitution =+  $(do a <- newName "a"+       b <- newName "b"+       c <- newName "c"+       k <- newName "k"+       let subst = M.singleton a (DVarT b)++                 -- (Nothing :: Maybe a)+           ty1 = DSigT (DConT 'Nothing) (DConT ''Maybe `DAppT` DVarT a)+                 -- forall (c :: a). c+           ty2 = DForallT (DForallInvis [DKindedTV c SpecifiedSpec (DVarT a)])+                          (DVarT c)+                 -- forall a (c :: a). c+           ty3 = DForallT (DForallInvis [ DPlainTV  a SpecifiedSpec+                                        , DKindedTV c SpecifiedSpec (DVarT a)+                                        ])+                          (DVarT c)+                 -- forall (a :: k) k (b :: k). Proxy b -> Proxy a+           ty4 = DForallT (DForallInvis+                             [ DKindedTV a SpecifiedSpec (DVarT k)+                             , DPlainTV  k SpecifiedSpec+                             , DKindedTV b SpecifiedSpec (DVarT k)+                             ])+                          (DArrowT `DAppT` (DConT ''Proxy `DAppT` DVarT b)+                                   `DAppT` (DConT ''Proxy `DAppT` DVarT a))++       substTy1 <- substTy subst ty1+       substTy2 <- substTy subst ty2+       substTy3 <- substTy subst ty3+       substTy4 <- substTy subst ty4++       let freeVars1 = fvDType substTy1+           freeVars2 = fvDType substTy2+           freeVars3 = fvDType substTy3+           freeVars4 = fvDType substTy4++           b1 = freeVars1 `eqTH` OS.singleton b+           b2 = freeVars2 `eqTH` OS.singleton b+           b3 = freeVars3 `eqTH` OS.empty+           b4 = freeVars4 `eqTH` OS.singleton k+       [| [b1, b2, b3, b4] |])++test_lookup_value_type_names :: [Bool]+test_lookup_value_type_names =+  $(do let nameStr = "***"+       valName  <- newName nameStr+       typeName <- newName nameStr+       let tyDec = DTySynD typeName [] (DConT ''Bool)+           decs  = decsToTH [ DLetDec (DSigD valName (DConT ''Bool))+                            , DLetDec (DValD (DVarP valName) (DConE 'False))+                            , tyDec ]+           lookupReify lookup_fun = withLocalDeclarations decs $ do+                                      Just n <- lookup_fun nameStr+                                      Just i <- dsReify n+                                      return i+       reifiedVal  <- lookupReify lookupValueNameWithLocals+       reifiedType <- lookupReify lookupTypeNameWithLocals+       let b1 = reifiedVal  `eqTH` DVarI valName (DConT ''Bool) Nothing+       let b2 = reifiedType `eqTH` DTyConI tyDec Nothing+       [| [b1, b2] |])+ local_reifications :: [String] local_reifications = $(do decs <- reifyDecs                           m_infos <- withLocalDeclarations decs $@@ -208,6 +921,14 @@                           let m_infos' = assumeStarT m_infos                           ListE <$> mapM (Syn.lift . show) (unqualify m_infos')) +type T123G = Either () ()+type T123F = Either T123G T123G+type T123E = Either T123F T123F+type T123D = Either T123E T123E+type T123C = Either T123D T123D+type T123B = Either T123C T123C+type T123A = Either T123B T123B+ $reifyDecs  $(return [])  -- somehow, this is necessary to get the staging correct for the@@ -216,7 +937,7 @@ normal_reifications :: [String] normal_reifications = $(do infos <- mapM reify reifyDecsNames                            ListE <$> mapM (Syn.lift . show . Just)-                                          (dropTrailing0s $ unqualify infos))+                                          (dropTrailing0s $ delinearize $ unqualify infos))  zipWith3M :: Monad m => (a -> b -> c -> m d) -> [a] -> [b] -> [c] -> m [d] zipWith3M f (a:as) (b:bs) (c:cs) = liftM2 (:) (f a b c) (zipWith3M f as bs cs)@@ -240,6 +961,45 @@                        let bools = zipWith eqTH ds_exprs2 ds_exprs3                        Syn.lift bools ) +test_matchTy :: [Bool]+test_matchTy =+  [ matchTy NoIgnore (DVarT a) (DConT ''Bool) == Just (M.singleton a (DConT ''Bool))+  , matchTy NoIgnore (DVarT a) (DVarT a) == Just (M.singleton a (DVarT a))+  , matchTy NoIgnore (DVarT a) (DVarT b) == Just (M.singleton a (DVarT b))+  , matchTy NoIgnore (DConT ''Either `DAppT` DVarT a `DAppT` DVarT b)+                     (DConT ''Either `DAppT` DConT ''Int `DAppT` DConT ''Bool)+    == Just (M.fromList [(a, DConT ''Int), (b, DConT ''Bool)])+  , matchTy NoIgnore (DConT ''Either `DAppT` DVarT a `DAppT` DVarT a)+                     (DConT ''Either `DAppT` DConT ''Int `DAppT` DConT ''Int)+    == Just (M.singleton a (DConT ''Int))+  , matchTy NoIgnore (DConT ''Either `DAppT` DVarT a `DAppT` DVarT a)+                     (DConT ''Either `DAppT` DConT ''Int `DAppT` DConT ''Bool)+    == Nothing+  , 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"+    b = mkName "b"++-- Test that type synonym expansion is efficient+test_t123 :: ()+test_t123 =+  $(do _ <- expand (DConT ''T123A)+       [| () |])+ main :: IO () main = hspec $ do   describe "th-desugar library" $ do@@ -254,10 +1014,6 @@                                      [inst1, inst2] <- reifyInstances ''Show [ty]                                      inst1 `eqTHSplice` inst2) -#if __GLASGOW_HASKELL__ < 707-    it "passes roles test" $ (decsToTH [ds_role_test]) `eqTH` role_test-#endif-     it "makes type names" $ test_mkName      it "fixes bug 8884" $ test_bug8884@@ -268,6 +1024,73 @@      it "works with standalone deriving" $ test_standalone_deriving +    it "works with deriving strategies" $ test_deriving_strategies++    it "doesn't expand local type families" $ test_local_tyfam_expansion++    it "doesn't crash on a stuck type family application" $ test_stuck_tyfam_expansion++    it "expands type synonyms in kinds" $ test_t85++    it "toposorts free variables in polytypes" $ test_t92++    it "expands type synonyms in type variable binders" $ test_t97++    it "reifies GADT record selectors correctly" $ test_t100++    zipWithM (\b n -> it ("collects GADT record selectors correctly" ++ show n) b)+      test_t102 [1..]++    it "quantifies kind variables in desugared ADT constructors" $ test_t103++    it "reifies data type return kinds accurately" $ test_getDataD_kind_sig++    zipWithM (\b n -> it ("toposorts free variables deterministically " ++ show n) b)+      test_t112 [1..]++    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..]++    it "desugars non-infix GADT constructors with symbolic names correctly" $ test_t154++    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)@@ -275,11 +1098,29 @@                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..]      zipWithM (\b n -> it ("round-trip successfully on case " ++ show n) b) test_roundtrip [1..]++    zipWithM (\b n -> it ("lookups up local value and type names " ++ show n) b)+      test_lookup_value_type_names [1..]++    zipWithM (\b n -> it ("substitutes tyvar binder kinds " ++ show n) b)+      test_kind_substitution [1..]++    zipWithM (\b n -> it ("matches types " ++ show n) b)+      test_matchTy [1..]++    zipWithM (\b n -> it ("reifies kinds of declarations with CUSKs " ++ show n) b)+      test_reify_type_cusks [1..]++    zipWithM (\b n -> it ("reifies kinds of declarations without CUSKs " ++ show n) b)+      test_reify_type_no_cusks [1..]++    zipWithM (\b n -> it ("reifies the kinds of declarations with signatures " ++ show n) b)+      test_reify_kind_sigs [1..]      fromHUnitTest tests
Test/Splices.hs view
@@ -1,7 +1,7 @@ {- Tests for the th-desugar package  (c) Richard Eisenberg 2013-eir@cis.upenn.edu+rae@cs.brynmawr.edu -}  {-# LANGUAGE TemplateHaskell, LambdaCase, MagicHash, UnboxedTuples,@@ -9,25 +9,83 @@              ScopedTypeVariables, RankNTypes, TypeFamilies, ImpredicativeTypes,              DataKinds, PolyKinds, GADTs, MultiParamTypeClasses,              FunctionalDependencies, FlexibleInstances, StandaloneDeriving,-             DefaultSignatures, ConstraintKinds #-}-{-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-type-defaults-                -fno-warn-name-shadowing #-}+             DefaultSignatures, ConstraintKinds, GADTs, ViewPatterns,+             TupleSections, NoMonomorphismRestriction, TypeOperators,+             TypeApplications #-} +#if __GLASGOW_HASKELL__ >= 801+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE UnboxedSums #-}+#endif++#if __GLASGOW_HASKELL__ >= 803+{-# LANGUAGE OverloadedLabels #-}+{-# OPTIONS_GHC -Wno-orphans #-}  -- IsLabel is an orphan+#endif++#if __GLASGOW_HASKELL__ >= 805+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE QuantifiedConstraints #-}+#endif++#if __GLASGOW_HASKELL__ < 806+{-# LANGUAGE TypeInType #-}+#endif++#if __GLASGOW_HASKELL__ >= 807+{-# LANGUAGE ImplicitParams #-}+#endif++#if __GLASGOW_HASKELL__ >= 809+{-# LANGUAGE StandaloneKindSignatures #-}+#endif++#if __GLASGOW_HASKELL__ >= 900+{-# LANGUAGE QualifiedDo #-}+#endif++#if __GLASGOW_HASKELL__ >= 902+{-# 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 Data.List+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 import GHC.TypeLits  import Language.Haskell.TH+import Language.Haskell.TH.Datatype.TyVarBndr import Language.Haskell.TH.Desugar+import Language.Haskell.TH.Syntax (Quasi) import Data.Generics -#if __GLASGOW_HASKELL__ < 707-data Proxy a = Proxy+#if __GLASGOW_HASKELL__ >= 803+import GHC.OverloadedLabels ( IsLabel(..) ) #endif +import Prelude as P+ dsSplice :: Q Exp -> Q Exp dsSplice expq = expq >>= dsExp >>= (return . expToTH) @@ -40,76 +98,80 @@       regName = mkName $ "Dec.Dec" ++ show n   infoDs  <- reify dsName   infoReg <- reify regName-#if __GLASGOW_HASKELL__ < 707-  eqTHSplice infoDs infoReg-#else   rolesDs  <- reifyRoles dsName   rolesReg <- reifyRoles regName-#if __GLASGOW_HASKELL__ < 711-  eqTHSplice (infoDs, rolesDs) (infoReg, rolesReg)-#else   fixityDs  <- reifyFixity dsName   fixityReg <- reifyFixity regName   eqTHSplice (infoDs, rolesDs, fixityDs) (infoReg, rolesReg, fixityReg)-#endif-#endif  unqualify :: Data a => a -> a unqualify = everywhere (mkT (mkName . nameBase))  assumeStarT :: Data a => a -> a-#if __GLASGOW_HASKELL__ < 709-assumeStarT = id-#else-assumeStarT = everywhere (mkT go)+assumeStarT = everywhere (assume_spec_t . assume_vis_t . assume_unit_t)   where-    go :: TyVarBndr -> TyVarBndr-    go (PlainTV n) = KindedTV n StarT-    go (KindedTV n k) = KindedTV n (assumeStarT k)+    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_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))+ dropTrailing0s :: Data a => a -> a dropTrailing0s = everywhere (mkT (mkName . frob . nameBase))   where-    frob str-      | head str == 'r' = str-      | head str == 'R' = str-      | otherwise       = 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.+-- See Note [Gracefully handling linear types] in L.H.TH.Desugar.Core.+delinearize :: Data a => a -> a+delinearize = everywhere (mkT no_mul)+  where+    no_mul :: Type -> Type+#if __GLASGOW_HASKELL__ >= 900+    no_mul (MulArrowT `AppT` _) = ArrowT+#endif+    no_mul t                    = t+ eqTH :: (Data a, Show a) => a -> a -> Bool eqTH a b = show (unqualify a) == show (unqualify b) -eqTHSplice :: (Data a, Show a) => a -> a -> Q Exp-eqTHSplice a b =+eqTHSplice :: (Quasi q, Data a, Show a) => a -> a -> q Exp+eqTHSplice a b = runQ $   if a `eqTH` b   then [| True |]   else [| False |] --- Note [Annotating list elements]------ Type annotations on list elements are needed to satisfy GHC 8.0-rc1, otherwise--- we get errors like:------    Test/Run.hs:63:53: error:---        • Couldn't match type ‘Maybe Integer’ with ‘forall a. Maybe a’---          Expected type: [forall a. Maybe a]---            Actual type: [Maybe Integer]---        • In the second argument of ‘(:)’, namely---            ‘(:) (Just 19) ((:) (Nothing :: Maybe Integer) [])’---          In the second argument of ‘(:)’, namely---            ‘(:) Nothing ((:) (Just 19) ((:) (Nothing :: Maybe Integer) []))’---          In the second argument of ‘map’, namely---            ‘(:)---               (Just 1)---               ((:) Nothing ((:) (Just 19) ((:) (Nothing :: Maybe Integer) [])))’------ This is probably a bug in the GHC type checker, but I haven't been able to--- reduce it yet- test1_sections = [| map ((* 3) . (4 +) . (\x -> x * x)) [10, 11, 12] |] test2_lampats = [| (\(Just x) (Left z) -> x + z) (Just 5) (Left 10) |]--- See Note [Annotating list elements]-test3_lamcase = [| foldr (-) 0 (map (\case { Just x -> x ; Nothing -> (-3) }) [Just 1, Nothing :: Maybe Integer, Just 19, Nothing :: Maybe Integer]) |]+test3_lamcase = [| foldr (-) 0 (map (\case { Just x -> x ; Nothing -> (-3) }) [Just 1, Nothing, Just 19, Nothing]) |] test4_tuples = [| (\(a, _) (# b, _ #) -> a + b) (1,2) (# 3, 4 #) |] test5_ifs = [| if (5 > 7) then "foo" else if | Nothing <- Just "bar", True -> "blargh" | otherwise -> "bum" |] test6_ifs2 = [| if | Nothing <- Nothing, False -> 3 | Just _ <- Just "foo" -> 5 |]@@ -117,24 +179,22 @@ test8_case = [| case Just False of { Just True -> 1 ; Just _ -> 2 ; Nothing -> 3 } |] test9_do = [| show $ do { foo <- Just "foo"                         ; let fool = foo ++ "l"-                        ; elemIndex 'o' fool-                        ; x <- elemIndex 'l' fool+                        ; L.elemIndex 'o' fool+                        ; x <- L.elemIndex 'l' fool                         ; return (x + 10) } |] test10_comp = [| [ (x, x+1) | x <- [1..10], x `mod` 2 == 0 ] |]-#if __GLASGOW_HASKELL__ >= 707 test11_parcomp = [| [ (x,y) | x <- [1..10], x `mod` 2 == 0 | y <- [2,5..20] ] |] test12_parcomp2 = [| [ (x,y,z) | x <- [1..10], z <- [3..100], x + z `mod` 2 == 0 | y <- [2,5..20] ] |]-#endif test13_sig = [| show (read "[10, 11, 12]" :: [Int]) |]  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)] |]@@ -143,28 +203,25 @@   deriving (Show, Eq)  test17_infixp = [| map (\(x :+: y) -> if y then x + 1 else x - 1) [5 :+: True, 10 :+: False] |]--- See Note [Annotating list elements]-test18_tildep = [| map (\ ~() -> Nothing :: Maybe Int) [undefined :: (), ()] |]+test18_tildep = [| map (\ ~() -> Nothing :: Maybe Int) [undefined, ()] |] test19_bangp = [| map (\ !() -> 5) [()] |] test20_asp = [| map (\ a@(b :+: c) -> (if c then b + 1 else b - 1, a)) [5 :+: True, 10 :+: False] |] test21_wildp = [| zipWith (\_ _ -> 10) [1,2,3] ['a','b','c'] |] test22_listp = [| map (\ [a,b,c] -> a + b + c) [[1,2,3],[4,5,6]] |]--- type signatures in patterns not yet handled by Template Haskell--- test23_sigp = [| map (\ (a :: Int) -> a + a) [5, 10] |]+#if __GLASGOW_HASKELL__ >= 801+test23_sigp = [| map (\ (a :: Int) -> a + a) [5, 10] |]+#endif --- See Note [Annotating list elements]-test24_fun = [| let f :: Maybe (Maybe a) -> Maybe a-                    f (Just x) = x+test24_fun = [| let f (Just x) = x                     f Nothing = Nothing in                 f (Just (Just 10)) |] --- See Note [Annotating list elements] test25_fun2 = [| let f (Just x)                        | x > 0 = x                        | x < 0 = x + 10                      f Nothing = 0                      f _ = 18 in-                 map f [Just (-5), Just 5, Just 10, Nothing :: Maybe Integer, Just 0] |]+                 map f [Just (-5), Just 5, Just 10, Nothing, Just 0] |]  test26_forall = [| let f :: Num a => a -> a                        f x = x + 10 in@@ -176,41 +233,262 @@ 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                      f Proxy Proxy |]-test31_constraint = [| let f :: Proxy (c :: * -> Constraint) -> ()+test31_constraint = [| let f :: Proxy (c :: Kind.Type -> Constraint) -> ()                            f _ = () in                        [f (Proxy :: Proxy Eq), f (Proxy :: Proxy Show)] |] test32_tylit = [| let f :: Proxy (a :: Symbol) -> Proxy (b :: Nat) -> ()                       f _ _ = () in                   f (Proxy :: Proxy "Hi there!") (Proxy :: Proxy 10) |]-test33_tvbs = [| let f :: forall a (b :: * -> *). Monad b => a -> b a+test33_tvbs = [| let f :: forall a (b :: Kind.Type -> Kind.Type). Monad b => a -> b a                      f = return in                  [f 1, f 2] :: [Maybe Int] |] -test34_let_as = [| let a@(Just x) = Just 5 in-                   show x ++ show a |]+test34_let_as = [| let a@(x, y) = (5, 6) in+                   show x ++ show y ++ show a |]  type Pair a = (a, a) test35_expand = [| let f :: Pair a -> a                        f = fst in                    f |] -type Const a b = b-test36_expand = [| let f :: Const Int (,) Bool Char -> Char+type Constant a b = b+test36_expand = [| let f :: Constant Int (,) Bool Char -> Char                        f = snd in                    f |] -#if __GLASGOW_HASKELL__ >= 711 test40_wildcards = [| let f :: (Show a, _) => a -> a -> _                           f x y = if x == y then show x else "bad" in                       f True False :: String |]++#if __GLASGOW_HASKELL__ >= 801+test41_typeapps = [| let f :: forall a. (a -> Bool) -> Bool+                         f g = g (undefined @_ @a) in+                     f (const True) |]++test42_scoped_tvs = [| let f :: (Read a, Show a) => a -> String -> String+                           f (_ :: b) (x :: String) = show (read x :: b)+                       in f True "True" |]++test43_ubx_sums = [| let f :: (# Bool | String #) -> Bool+                         f (# b |   #) = not b+                         f (#   | c #) = c == "c" in+                     f (# | "a" #) |] #endif +test44_let_pragma = [| let x :: Int+                           x = 1+                           {-# INLINE x #-}+                       in x |]++test45_empty_record_con = [| let j :: Maybe Int+                                 j = Just{}+                             in case j of+                                Nothing -> j+                                Just{}  -> j |]++#if __GLASGOW_HASKELL__ >= 803+data Label (l :: Symbol) = Get++class Has a l b | a l -> b where+  from :: a -> Label l -> b++data Point = Point Int Int deriving Show++instance Has Point "x" Int where from (Point x _) _ = x+instance Has Point "y" Int where from (Point _ y) _ = y++instance Has a l b => IsLabel l (a -> b) where+  fromLabel x = from x (Get :: Label l)++test46_overloaded_label = [| let p = Point 3 4 in+                             #x p - #y p |]+#endif++test47_do_partial_match = [| do { Just () <- [Nothing]; return () } |]++#if __GLASGOW_HASKELL__ >= 805+test48_quantified_constraints =+  [| let f :: forall f a. (forall x. Eq x => Eq (f x), Eq a) => f a -> f a -> Bool+         f = (==)+     in f (Proxy @Int) (Proxy @Int) |]+#endif++#if __GLASGOW_HASKELL__ >= 807+test49_implicit_params = [| let f :: (?x :: Int, ?y :: Int) => (Int, Int)+                                f =+                                  let ?x = ?y+                                      ?y = ?x+                                  in (?x, ?y)+                            in (let ?x = 42+                                    ?y = 27+                                in f) |]++test50_vka = [| let hrefl :: (:~~:) @Bool @Bool 'True 'True+                    hrefl = HRefl+                in hrefl |]+#endif++#if __GLASGOW_HASKELL__ >= 809+test51_tuple_sections =+  [| let f1 :: String -> Char -> (String, Int, Char)+         f1 = (,5,)++         f2 :: String -> Char -> (# String, Int, Char #)+         f2 = (#,5,#)+     in case (#,#) (f1 "a" 'a') (f2 "b" 'b') of+          (#,#) ((,,) _ a _) ((#,,#) _ b _) -> a + b |]+#endif++#if __GLASGOW_HASKELL__ >= 900+test52_qual_do =+  [| P.do x <- [1, 2]+          y@1 <- [x]+          [1, 2]+          P.return y |]+#endif++#if __GLASGOW_HASKELL__ >= 901+test53_vta_in_con_pats =+  [| let f :: Maybe Int -> Int+         f (Just @Int x)  = x+         f (Nothing @Int) = 42+     in f (Just @Int 27) |]+#endif++#if __GLASGOW_HASKELL__ >= 902+data ORD1 = MkORD1 { unORD1 :: Int }+data ORD2 = MkORD2 { unORD2 :: ORD1 }++test54_overloaded_record_dot =+  [| let ord1 :: ORD1+         ord1 = MkORD1 1++         ord2 :: ORD2+         ord2 = MkORD2 ord1++     in (ord2.unORD2.unORD1, (.unORD2.unORD1) ord2) |]+#endif++#if __GLASGOW_HASKELL__ >= 903+test55_opaque_pragma =+  [| let f :: String -> String+         f x = x+         {-# OPAQUE f #-}+     in f "Hello, World!" |]++test56_lambda_cases =+  [| (\cases (Just x) (Just y) -> x ++ y+             _        _        -> "") (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]@@ -221,7 +499,6 @@                       f [True, False] = () in                   f |] -#if __GLASGOW_HASKELL__ >= 707 type family ClosedTF a where   ClosedTF Int = Bool   ClosedTF x   = Char@@ -233,8 +510,11 @@                       f 'x' = () in                   f |] -type family PolyTF (x :: k) :: * where-  PolyTF (x :: *) = Bool+#if __GLASGOW_HASKELL__ >= 809+type PolyTF :: forall k. k -> Kind.Type+#endif+type family PolyTF (x :: k) :: Kind.Type where+  PolyTF (x :: Kind.Type) = Bool  test_expand7 = [| let f :: PolyTF Int -> ()                       f True = () in@@ -243,9 +523,18 @@                       f True = () in                   f |] -#endif -#if __GLASGOW_HASKELL__ >= 709+test_expand9 = [| let f :: TFExpand (Maybe (IO a)) -> IO ()+                      f actions = sequence_ actions in+                  f |]++type family TFExpandClosed a where+  TFExpandClosed (Maybe a) = [a]++test_expand10 = [| let f :: TFExpandClosed (Maybe (IO a)) -> IO ()+                       f actions = sequence_ actions in+                   f |]+ test37_pred = [| let f :: (Read a, (Show a, Num a)) => a -> a                      f x = read (show x) + x in                  (f 3, f 4.5) |]@@ -257,60 +546,40 @@ test39_eq = [| let f :: (a ~ b) => a -> b                    f x = x in                (f ()) |]-#endif -#if __GLASGOW_HASKELL__ < 707-dec_test_nums = [1..9] :: [Int]-#elif __GLASGOW_HASKELL__ < 709-dec_test_nums = [1..10] :: [Int]-#else dec_test_nums = [1..11] :: [Int]-#endif -dectest1 = [d| data Dec1 = Foo | Bar Int |]-dectest2 = [d| data Dec2 a = forall b. (Show b, Eq a) => MkDec2 a b Bool |]-dectest3 = [d| data Dec3 a = forall b. MkDec3 { foo :: a, bar :: b }-#if __GLASGOW_HASKELL__ >= 707+dectest1 = [d| data Dec1 where+                 Foo :: Dec1+                 Bar :: Int -> Dec1 |]+dectest2 = [d| data Dec2 a where+                 MkDec2 :: forall a b. (Show b, Eq a) => a -> b -> Bool -> Dec2 a |]+dectest3 = [d| data Dec3 a where+                 MkDec3 :: forall a b. { foo :: a, bar :: b } -> Dec3 a                type role Dec3 nominal-#endif                |]-dectest4 = [d| newtype Dec4 a = MkDec4 (a, Int) |]+dectest4 = [d| newtype Dec4 a where+                 MkDec4 :: (a, Int) -> Dec4 a |] dectest5 = [d| type Dec5 a b = (a b, Maybe b) |]-dectest6 = [d| class (Monad m1, Monad m2) => Dec6 (m1 :: * -> *) m2 | m1 -> m2  where+dectest6 = [d| class (Monad m1, Monad m2) => Dec6 (m1 :: Kind.Type -> Kind.Type) m2 | m1 -> m2  where                  lift :: forall a. m1 a -> m2 a-                 type M2 m1 :: * -> * |]-dectest7 = [d| type family Dec7 a (b :: *) (c :: Bool) :: * -> * |]+                 type M2 m1 :: Kind.Type -> Kind.Type |]+dectest7 = [d| type family Dec7 a (b :: Kind.Type) (c :: Bool) :: Kind.Type -> Kind.Type |] dectest8 = [d| type family Dec8 a |]-dectest9 = [d| data family Dec9 a (b :: * -> *) :: * -> * |]-#if __GLASGOW_HASKELL__ < 707-ds_dectest10 = DClosedTypeFamilyD-                 (DTypeFamilyHead-                    (mkName "Dec10")-                    [DPlainTV (mkName "a")]-                    (DKindSig (DAppT (DAppT DArrowT DStarT) DStarT))-                    Nothing)-                 [ DTySynEqn [DConT ''Int]  (DConT ''Maybe)-                 , DTySynEqn [DConT ''Bool] (DConT ''[]) ]-dectest10 = [d| type family Dec10 a :: * -> *-                type instance Dec10 Int = Maybe-                type instance Dec10 Bool = [] |]--ds_role_test = DRoleAnnotD (mkName "Dec3") [NominalR]-role_test = []-#else-dectest10 = [d| type family Dec10 a :: * -> * where+dectest9 = [d| data family Dec9 a (b :: Kind.Type -> Kind.Type) :: Kind.Type -> Kind.Type |]+dectest10 = [d| type family Dec10 a :: Kind.Type -> Kind.Type where                   Dec10 Int = Maybe                   Dec10 Bool = [] |]-#endif  data Blarggie a = MkBlarggie Int a-#if __GLASGOW_HASKELL__ >= 709 dectest11 = [d| class Dec11 a where                   meth13 :: a -> a -> Bool                   default meth13 :: Eq a => a -> a -> Bool                   meth13 = (==)               |] standalone_deriving_test = [d| deriving instance Eq a => Eq (Blarggie a) |]+#if __GLASGOW_HASKELL__ >= 801+deriv_strat_test = [d| deriving stock instance Ord a => Ord (Blarggie a) |] #endif  dectest12 = [d| data Dec12 a where@@ -319,10 +588,75 @@                |] -dectest13 = [d| data Dec13 :: (* -> Constraint) -> * where+dectest13 = [d| data Dec13 :: (Kind.Type -> Constraint) -> Kind.Type where                   MkDec13 :: c a => a -> Dec13 c               |] +dectest14 = [d| data InfixADT = Int `InfixADT` Int |]++dectest15 = [d| infixl 5 :**:, :&&:, :^^:, `ActuallyPrefix`+                data InfixGADT a where+                  (:**:) :: Int -> b -> InfixGADT (Maybe b) -- Only this one is infix+                  (:&&:) :: { infixGADT1 :: b, infixGADT2 :: Int } -> InfixGADT [b]+                  ActuallyPrefix :: Char -> Bool -> InfixGADT Double+                  (:^^:) :: Int -> Int -> Int -> InfixGADT Int+                  (:!!:) :: Char -> Char -> InfixGADT Char |]++class ExCls a+data ExData1 a+data ExData2 a++-- ds_dectest{16,17} demonstrate instance declarations with outermost foralls,+-- a feature which Template Haskell itself does not yet support (see #151).+-- For this reason, the closest we can get to this in TH is to construct+-- equivalent Decs, dectest{16,17}, that drop the outermost foralls. The test+-- suite ensures that this process happens automatically during sweetening by+-- checking that the sweetened versions of ds_dectest{16,17} equal+-- dectest{16,17}.++ds_dectest16 = DInstanceD Nothing (Just [DPlainTV (mkName "a") ()]) []+                (DConT ''ExCls `DAppT`+                  (DConT ''ExData1 `DAppT` DVarT (mkName "a"))) []+dectest16 :: Q [Dec]+dectest16 = return [ InstanceD+                       Nothing+                       [] (ConT ''ExCls `AppT`+                            (ConT ''ExData1 `AppT` VarT (mkName "a"))) [] ]+ds_dectest17 = DStandaloneDerivD Nothing (Just [DPlainTV (mkName "a") ()]) []+                (DConT ''ExCls `DAppT`+                  (DConT ''ExData2 `DAppT` DVarT (mkName "a")))+dectest17 :: Q [Dec]+dectest17 = return [ StandaloneDerivD+#if __GLASGOW_HASKELL__ >= 802+                       Nothing+#endif+                       [] (ConT ''ExCls `AppT`+                            (ConT ''ExData2 `AppT` VarT (mkName "a"))) ]++#if __GLASGOW_HASKELL__ >= 809+dectest18 = [d| data Dec18 :: forall k -> k -> Kind.Type where+                  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" |] @@ -332,45 +666,43 @@                        lift (Just x) = Right x                        type M2 Maybe = Either () |] -data family Dec9 a (b :: * -> *) :: * -> *-imp_inst_test2 = [d| data instance Dec9 Int Maybe a = MkIMB [a] | forall b. MkIMB2 (b a) |]-imp_inst_test3 = [d| newtype instance Dec9 Bool m x = MkBMX (m x) |]+data family Dec9 a (b :: Kind.Type -> Kind.Type) :: Kind.Type -> Kind.Type+imp_inst_test2 = [d| data instance Dec9 Int Maybe a where+                       MkIMB  ::             [a] -> Dec9 Int Maybe a+                       MkIMB2 :: forall a b. b a -> Dec9 Int Maybe a |]+imp_inst_test3 = [d| newtype instance Dec9 Bool m x where+                       MkBMX :: m x -> Dec9 Bool m x |]  type family Dec8 a imp_inst_test4 = [d| type instance Dec8 Int = Bool |]  -- used for bug8884 test-type family Poly (a :: k) :: *+type family Poly (a :: k) :: Kind.Type type instance Poly x = Int  flatten_dvald_test = [| let (a,b,c) = ("foo", 4, False) in                         show a ++ show b ++ show c |] -rec_sel_test = [d| data RecordSel a = forall b. (Show a, Eq b) =>+rec_sel_test = [d| data RecordSel a = Show a =>                                       MkRecord { recsel1 :: (Int, a)-                                            , recsel_naughty :: (a, b)-                                            , recsel2 :: (forall b. b -> a)-                                            , recsel3 :: Bool }-                                    | MkRecord2 { recsel4 :: (a, a) } |]-rec_sel_test_num_sels = 4 :: Int   -- exclude naughty one+                                               , recsel2 :: (forall b. b -> a)+                                               , recsel3 :: Bool }+                                    | MkRecord2 { recsel3 :: Bool+                                                , recsel4 :: (a, a) } |]+rec_sel_test_num_sels = 4 :: Int  testRecSelTypes :: Int -> Q Exp testRecSelTypes n = do-#if __GLASGOW_HASKELL__ > 710   VarI _ ty1 _ <- reify (mkName ("DsDec.recsel" ++ show n))   VarI _ ty2 _ <- reify (mkName ("Dec.recsel"   ++ show n))-#else-  VarI _ ty1 _ _ <- reify (mkName ("DsDec.recsel" ++ show n))-  VarI _ ty2 _ _ <- reify (mkName ("Dec.recsel"   ++ show n))-#endif   let ty1' = return $ unqualify ty1       ty2' = return $ unqualify ty2   [| let x :: $ty1'-         x = undefined+         x _ = undefined          y :: $ty2'-         y = undefined+         y _ = undefined      in-     $(return $ VarE $ mkName "hasSameType") x y |]+     $(return $ VarE $ mkName "hasSameType") (\d -> x d) (\d -> y d) |]   -- used for expand@@ -378,13 +710,20 @@  reifyDecs :: Q [Dec] reifyDecs = [d|-  r1 :: a -> a+  -- NB: Use a forall here! If you don't, when you splice r1 in and then reify+  -- it, GHC will add an explicit forall behind the scenes, which will cause an+  -- incongruity with the locally reified declaration (which would lack an+  -- explicit forall).+  r1 :: forall a. a -> a   r1 x = x    class R2 a b where     r3 :: a -> b -> c -> a-    type R4 b a :: *-    data R5 a :: *+    type R4 b a :: Kind.Type+    -- Only define this on GHC 8.0 or later, since TH had trouble quoting+    -- associated type family defaults before then.+    type R4 b a = Either a b+    data R5 a :: Kind.Type    data R6 a = R7 { r8 :: a -> a, r9 :: Bool } @@ -393,9 +732,9 @@     type R4 a (R6 a) = a     data R5 (R6 a) = forall b. Show b => R10 { r11 :: a, naughty :: b } -  type family R12 a b :: *+  type family R12 a b :: Kind.Type -  data family R13 a :: *+  data family R13 a :: Kind.Type    data instance R13 Int = R14 { r15 :: Bool } @@ -405,27 +744,114 @@   newtype R18 = R19 Bool    type R20 = Bool-#if __GLASGOW_HASKELL__ >= 707-  type family R21 (a :: k) (b :: k) :: k where R21 a b = b+  type family R21 (a :: k) (b :: k) :: k where+#if __GLASGOW_HASKELL__ >= 801+#if __GLASGOW_HASKELL__ >= 807+    forall k (a :: k) (b :: k). #endif+      R21 (a :: k) (b :: k) = b+#else+    -- Due to GHC Trac #12646, R21 will get reified without kind signatures on+    -- a and b on older GHCs, so we must reflect that here.+    R21 a b = b+#endif   class XXX a where     r22 :: a -> a     r22 = id   -- test #32 +  data R23 a = MkR23 { getR23 :: a }++  r23Test :: R23 a -> a+  r23Test (MkR23 { getR23 = x }) = x++#if __GLASGOW_HASKELL__ >= 801+  pattern Point :: Int -> Int -> (Int, Int)+  pattern Point{x, y} = (x, y)++  data T a where+    MkT :: Eq b => a -> b -> T a++  foo :: Show a => a -> Bool+  foo x = show x == "foo"++  pattern P :: Show a => Eq b => b -> T a+  pattern P x <- MkT (foo -> True) x++  pattern HeadC :: a -> [a]+  pattern HeadC x <- x:_ where+    HeadC x = [x]++  class LL f where+    llMeth :: f a -> ()++  instance LL [] where+    llMeth _ = ()++  pattern LLMeth :: LL f => f a+  pattern LLMeth <- (llMeth -> ())++  {-# COMPLETE LLMeth :: [] #-}++  llEx :: [a] -> Int+  llEx LLMeth = 5+#endif++#if __GLASGOW_HASKELL__ >= 805+  newtype Id a = MkId a+    deriving stock Eq++  newtype R24 a = MkR24 [a]+    deriving Eq via (Id [a])+#endif++  class R25 (f :: k -> Kind.Type) where+    r26 :: forall (a :: k). f a++  data R27 (a :: k) = R28 { r29 :: Proxy a }++  class R30 a where+    r31 :: a -> b -> a++#if __GLASGOW_HASKELL__ >= 809+  type R32 :: forall k -> k -> Kind.Type+  type family R32 :: forall k -> k -> Kind.Type where+#endif++  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] reifyDecsNames = map mkName   [ "r1"-#if __GLASGOW_HASKELL__ < 711-  , "R2", "r3"      -- these fail due to GHC#11797-#endif   , "R4", "R5", "R6", "R7", "r8", "r9", "R10", "r11"   , "R12", "R13", "R14", "r15", "r16", "r17", "R18", "R19", "R20"-#if __GLASGOW_HASKELL__ >= 707   , "R21"-#endif   , "r22"+  , "R25", "r26", "R28", "r29"+  , "R30", "r31"+#if __GLASGOW_HASKELL__ >= 809+  , "R32"+#endif+  , "R33", "R34", "r35"+#if __GLASGOW_HASKELL__ >= 906+  , "R36", "R37", "R38", "R39"+#endif+  , "R40"+  , "R41", "R42"   ]  simplCaseTests :: [Q Exp]@@ -436,6 +862,11 @@      |]   , [| let foo [] = True            foo _  = False in (foo [], foo "hi") |]+#if __GLASGOW_HASKELL__ >= 801+  , [| let foo ([] :: String) = True+           foo (_  :: String) = False+        in foo "hello" |]+#endif   ]  -- These foralls are needed because of bug trac9262, fixed in ghc-7.10.@@ -456,10 +887,8 @@              , test8_case              , test9_do              , test10_comp-#if __GLASGOW_HASKELL__ >= 707              , test11_parcomp              , test12_parcomp2-#endif              , test13_sig              , test14_record              , test15_litp@@ -470,6 +899,9 @@              , test20_asp              , test21_wildp              , test22_listp+#if __GLASGOW_HASKELL__ >= 801+             , test23_sigp+#endif              , test24_fun              , test25_fun2              , test26_forall@@ -481,9 +913,66 @@              , test32_tylit              , test33_tvbs              , test34_let_as-#if __GLASGOW_HASKELL__ >= 709              , test37_pred              , test38_pred2              , test39_eq+#if __GLASGOW_HASKELL__ >= 801+             , test41_typeapps+             , test42_scoped_tvs+             , test43_ubx_sums+#endif+             , test44_let_pragma+             , test45_empty_record_con+#if __GLASGOW_HASKELL__ >= 803+             , test46_overloaded_label+#endif+             , test47_do_partial_match+#if __GLASGOW_HASKELL__ >= 805+             , test48_quantified_constraints+#endif+#if __GLASGOW_HASKELL__ >= 807+             , test49_implicit_params+             , test50_vka+#endif+#if __GLASGOW_HASKELL__ >= 809+             , test51_tuple_sections+#endif+#if __GLASGOW_HASKELL__ >= 900+             , test52_qual_do+#endif+#if __GLASGOW_HASKELL__ >= 901+             , test53_vta_in_con_pats+#endif+#if __GLASGOW_HASKELL__ >= 902+             , test54_overloaded_record_dot+#endif+#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
@@ -0,0 +1,15 @@+{-# 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 in its own module, without UnboxedTuples enabled, to ensure that users+-- do not have to enable the extension themselves.+module T158Exp where++import Language.Haskell.TH.Desugar++t158 :: ()+t158 =+  $([| (\27# 42# -> ()) 27# 42# |] >>= dsExp >>= return . expToTH)
+ Test/T159Decs.hs view
@@ -0,0 +1,20 @@+{-# OPTIONS_GHC -Wno-incomplete-patterns #-}+{-# OPTIONS_GHC -Wno-unused-matches #-}++-- | Defines two non-exhaustive functions that roundtrip through desugaring+-- and sweetening. Both of these functions should desugar to definitions that+-- throw a runtime exception before forcing their argument.+--+-- Because these functions are non-exhaustive (and therefore emit warnings), we+-- put them in their own module so that we can disable the appropriate warnings+-- without needing to disable the warnings globally.+module T159Decs+  ( t159A, t159B+  ) where++import Splices ( dsDecSplice )++$(dsDecSplice [d| t159A, t159B :: () -> IO ()+                  t159A x | False = return ()+                  t159B x = case x of y | False -> return ()+                |])
+ 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,17 +1,31 @@ name:           th-desugar-version:        1.6+version:        1.19 cabal-version:  >= 1.10 synopsis:       Functions to desugar Template Haskell-homepage:       http://www.cis.upenn.edu/~eir/packages/th-desugar+homepage:       https://github.com/goldfirere/th-desugar category:       Template Haskell-author:         Richard Eisenberg <eir@cis.upenn.edu>-maintainer:     Richard Eisenberg <eir@cis.upenn.edu>+author:         Richard Eisenberg <rae@cs.brynmawr.edu>+maintainer:     Ryan Scott <ryan.gl.scott@gmail.com> bug-reports:    https://github.com/goldfirere/th-desugar/issues stability:      experimental extra-source-files: README.md, CHANGES.md license:        BSD3 license-file:   LICENSE build-type:     Simple+tested-with:    GHC == 8.0.2+              , GHC == 8.2.2+              , GHC == 8.4.4+              , GHC == 8.6.5+              , GHC == 8.8.4+              , GHC == 8.10.7+              , GHC == 9.0.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.@@ -26,49 +40,71 @@ source-repository this   type:     git   location: https://github.com/goldfirere/th-desugar.git-  tag:      v1.6+  tag:      v1.10 +source-repository head+  type:     git+  location: https://github.com/goldfirere/th-desugar.git+  branch:   master+ library   build-depends:-      base >= 4 && < 5,-      template-haskell,+      base >= 4.9 && < 5,+      ghc-prim,+      template-haskell >= 2.11 && < 2.25,       containers >= 0.5,-      mtl >= 2.1,+      mtl >= 2.1 && < 2.4,+      ordered-containers >= 0.2.2,       syb >= 0.4,-      th-lift >= 0.6.1,-      th-orphans >= 0.9.1,-      th-expand-syns >= 0.3.0.6+      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,-                      Language.Haskell.TH.Desugar.Sweeten,-                      Language.Haskell.TH.Desugar.Lift,+  exposed-modules:    Language.Haskell.TH.Desugar                       Language.Haskell.TH.Desugar.Expand-  other-modules:      Language.Haskell.TH.Desugar.Core,-                      Language.Haskell.TH.Desugar.Match,-                      Language.Haskell.TH.Desugar.Util,+                      Language.Haskell.TH.Desugar.Lift+                      Language.Haskell.TH.Desugar.OMap+                      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+                      Language.Haskell.TH.Desugar.FV+                      Language.Haskell.TH.Desugar.Match                       Language.Haskell.TH.Desugar.Reify+                      Language.Haskell.TH.Desugar.Util   default-language:   Haskell2010   ghc-options:        -Wall   test-suite spec   type:               exitcode-stdio-1.0-  ghc-options:        -Wall -main-is Run+  ghc-options:        -Wall   default-language:   Haskell2010   default-extensions: TemplateHaskell   hs-source-dirs:     Test   main-is:            Run.hs-  other-modules:      Splices, Dec, DsDec+  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-desugar,-      th-lift >= 0.6.1,-      th-orphans >= 0.9.1,-      th-expand-syns >= 0.3.0.6+      th-abstraction,+      th-desugar