packages feed

th-desugar 1.14 → 1.15

raw patch · 27 files changed

+9117/−8634 lines, 27 filesdep −th-liftdep ~template-haskelldep ~th-abstractionsetup-changed

Dependencies removed: th-lift

Dependency ranges changed: template-haskell, th-abstraction

Files

CHANGES.md view
@@ -1,561 +1,591 @@-`th-desugar` release notes-==========================--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.-  This means that several core datatypes have changed: partcularly, we now have-  `DTypeFamilyHead` and fixities are now reified separately from other things.--* `DKind` is merged with `DType`.--* `Generic` instances for everything.--Version 1.5.5----------------* Fix issue #34. This means that desugaring (twice) is idempotent over-expressions, after the second time. That is, if you desugar an expression,-sweeten it, desugar again, sweeten again, and then desugar a third time, you-get the same result as when you desugared the second time. (The extra-round-trip is necessary there to make the output smaller in certain common-cases.)--Version 1.5.4.1-----------------* Fix issue #32, concerning reification of classes with default methods.--Version 1.5.4---------------* Added `expandUnsoundly`--Version 1.5.3---------------* More `DsMonad` instances, thanks to David Fox.--Version 1.5.2---------------* Sweeten kinds more, too.--Version 1.5.1---------------* Thanks to David Fox (@ddssff), sweetening now tries to use more of TH's `Type`-constructors.--* Also thanks to David Fox, depend usefully on the th-orphans package.--Version 1.5-------------* There is now a facility to register a list of `Dec` that internal reification-  should use when necessary. This avoids the user needing to break up their-  definition across different top-level splices. See `withLocalDeclarations`.-  This has a side effect of changing the `Quasi` typeclass constraint on many-  functions to be the new `DsMonad` constraint. Happily, there are `DsMonad`-  instances for `Q` and `IO`, the two normal inhabitants of `Quasi`.--* "Match flattening" is implemented! The functions `scExp` and `scLetDec` remove-  any nested pattern matches.--* More is now exported from `Language.Haskell.TH.Desugar` for ease of use.--* `expand` can now expand closed type families! It still requires that the-  type to expand contain no type variables.--* Support for standalone-deriving and default signatures in GHC 7.10.-  This means that there are now two new constructors for `DDec`.--* Support for `static` expressions, which are new in GHC 7.10.--Version 1.4.2---------------* `expand` functions now consider open type families, as long as the type-   to be expanded has no free variables.--Version 1.4.1---------------* Added `Language.Haskell.TH.Desugar.Lift`, which provides `Lift` instances-for all of the th-desugar types, as well as several Template Haskell types.--* Added `applyDExp` and `applyDType` as convenience functions.--Version 1.4.0---------------* All `Dec`s can now be desugared, to the new `DDec` type.--* Sweetening `Dec`s that do not exist in GHC 7.6.3- works on a "best effort" basis:-closed type families are sweetened to open ones, and role annotations are dropped.--* `Info`s can now be desugared. Desugaring takes into account GHC bug #8884, which-meant that reifying poly-kinded type families in GHC 7.6.3- was subtly wrong.--* There is a new function `flattenDValD` which takes a binding like-  `let (a,b) = foo` and breaks it apart into separate assignments for `a` and `b`.--* There is a new `Desugar` class with methods `desugar` and `sweeten`. See-the documentation in `Language.Haskell.TH.Desugar`.--* Variable names that are distinct in desugared code are now guaranteed to-have distinct answers to `nameBase`.--* Added a new function `getRecordSelectors` that extracts types and definitions-of record selectors from a datatype definition.--Version 1.3.1---------------* Update cabal file to include testing files in sdist.--Version 1.3.0---------------* Update to work with `type Pred = Type` in GHC 7.9. This changed the-`DPred` type for all GHC versions, though.--Version 1.2.0---------------* Generalized interface to allow any member of the `Qausi` class, instead of-  just `Q`.--Version 1.1.1---------------* Made compatible with HEAD after change in role annotation syntax.--Version 1.1-------------* Added module `Language.Haskell.TH.Desugar.Expand`, which allows for expansion-  of type synonyms in desugared types.-* Added `Show`, `Typeable`, and `Data` instances to desugared types.-* Fixed bug where an as-pattern in a `let` statement was scoped incorrectly.-* Changed signature of `dsPat` to be more specific to as-patterns; this allowed-  for fixing the `let` scoping bug.-* Created new functions `dsPatOverExp` and `dsPatsOverExp` to allow for easy-  desugaring of patterns.-* Changed signature of `dsLetDec` to return a list of `DLetDec`s.-* Added `dsLetDecs` for convenience. Now, instead-  of using `mapM dsLetDec`, you should use `dsLetDecs`.--Version 1.0--------------* Initial release+`th-desugar` release notes
+==========================
+
+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.
+  This means that several core datatypes have changed: partcularly, we now have
+  `DTypeFamilyHead` and fixities are now reified separately from other things.
+
+* `DKind` is merged with `DType`.
+
+* `Generic` instances for everything.
+
+Version 1.5.5
+-------------
+
+* Fix issue #34. This means that desugaring (twice) is idempotent over
+expressions, after the second time. That is, if you desugar an expression,
+sweeten it, desugar again, sweeten again, and then desugar a third time, you
+get the same result as when you desugared the second time. (The extra
+round-trip is necessary there to make the output smaller in certain common
+cases.)
+
+Version 1.5.4.1
+---------------
+* Fix issue #32, concerning reification of classes with default methods.
+
+Version 1.5.4
+-------------
+* Added `expandUnsoundly`
+
+Version 1.5.3
+-------------
+* More `DsMonad` instances, thanks to David Fox.
+
+Version 1.5.2
+-------------
+* Sweeten kinds more, too.
+
+Version 1.5.1
+-------------
+* Thanks to David Fox (@ddssff), sweetening now tries to use more of TH's `Type`
+constructors.
+
+* Also thanks to David Fox, depend usefully on the th-orphans package.
+
+Version 1.5
+-----------
+* There is now a facility to register a list of `Dec` that internal reification
+  should use when necessary. This avoids the user needing to break up their
+  definition across different top-level splices. See `withLocalDeclarations`.
+  This has a side effect of changing the `Quasi` typeclass constraint on many
+  functions to be the new `DsMonad` constraint. Happily, there are `DsMonad`
+  instances for `Q` and `IO`, the two normal inhabitants of `Quasi`.
+
+* "Match flattening" is implemented! The functions `scExp` and `scLetDec` remove
+  any nested pattern matches.
+
+* More is now exported from `Language.Haskell.TH.Desugar` for ease of use.
+
+* `expand` can now expand closed type families! It still requires that the
+  type to expand contain no type variables.
+
+* Support for standalone-deriving and default signatures in GHC 7.10.
+  This means that there are now two new constructors for `DDec`.
+
+* Support for `static` expressions, which are new in GHC 7.10.
+
+Version 1.4.2
+-------------
+* `expand` functions now consider open type families, as long as the type
+   to be expanded has no free variables.
+
+Version 1.4.1
+-------------
+* Added `Language.Haskell.TH.Desugar.Lift`, which provides `Lift` instances
+for all of the th-desugar types, as well as several Template Haskell types.
+
+* Added `applyDExp` and `applyDType` as convenience functions.
+
+Version 1.4.0
+-------------
+* All `Dec`s can now be desugared, to the new `DDec` type.
+
+* Sweetening `Dec`s that do not exist in GHC 7.6.3- works on a "best effort" basis:
+closed type families are sweetened to open ones, and role annotations are dropped.
+
+* `Info`s can now be desugared. Desugaring takes into account GHC bug #8884, which
+meant that reifying poly-kinded type families in GHC 7.6.3- was subtly wrong.
+
+* There is a new function `flattenDValD` which takes a binding like
+  `let (a,b) = foo` and breaks it apart into separate assignments for `a` and `b`.
+
+* There is a new `Desugar` class with methods `desugar` and `sweeten`. See
+the documentation in `Language.Haskell.TH.Desugar`.
+
+* Variable names that are distinct in desugared code are now guaranteed to
+have distinct answers to `nameBase`.
+
+* Added a new function `getRecordSelectors` that extracts types and definitions
+of record selectors from a datatype definition.
+
+Version 1.3.1
+-------------
+* Update cabal file to include testing files in sdist.
+
+Version 1.3.0
+-------------
+* Update to work with `type Pred = Type` in GHC 7.9. This changed the
+`DPred` type for all GHC versions, though.
+
+Version 1.2.0
+-------------
+* Generalized interface to allow any member of the `Qausi` class, instead of
+  just `Q`.
+
+Version 1.1.1
+-------------
+* Made compatible with HEAD after change in role annotation syntax.
+
+Version 1.1
+-----------
+* Added module `Language.Haskell.TH.Desugar.Expand`, which allows for expansion
+  of type synonyms in desugared types.
+* Added `Show`, `Typeable`, and `Data` instances to desugared types.
+* Fixed bug where an as-pattern in a `let` statement was scoped incorrectly.
+* Changed signature of `dsPat` to be more specific to as-patterns; this allowed
+  for fixing the `let` scoping bug.
+* Created new functions `dsPatOverExp` and `dsPatsOverExp` to allow for easy
+  desugaring of patterns.
+* Changed signature of `dsLetDec` to return a list of `DLetDec`s.
+* Added `dsLetDecs` for convenience. Now, instead
+  of using `mapM dsLetDec`, you should use `dsLetDecs`.
+
+Version 1.0
+-----------
+
+* Initial release
LICENSE view
@@ -1,27 +1,27 @@-Copyright (c) 2013, Richard Eisenberg-All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:--1. Redistributions of source code must retain the above copyright notice, this-list of conditions and the following disclaimer.--2. Redistributions in binary form must reproduce the above copyright notice,-this list of conditions and the following disclaimer in the documentation-and/or other materials provided with the distribution.--3. Neither the name of the author nor the names of its contributors may be-used to endorse or promote products derived from this software without-specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"-AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE-IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE-DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE-FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL-DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR-SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER-CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,-OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+Copyright (c) 2013, Richard Eisenberg
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+1. Redistributions of source code must retain the above copyright notice, this
+list of conditions and the following disclaimer.
+
+2. Redistributions in binary form must reproduce the above copyright notice,
+this list of conditions and the following disclaimer in the documentation
+and/or other materials provided with the distribution.
+
+3. Neither the name of the author nor the names of its contributors may be
+used to endorse or promote products derived from this software without
+specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
 OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Language/Haskell/TH/Desugar.hs view
@@ -1,441 +1,441 @@-{- Language/Haskell/TH/Desugar.hs--(c) Richard Eisenberg 2013-rae@cs.brynmawr.edu--}--{-# LANGUAGE CPP, MultiParamTypeClasses, FunctionalDependencies,-             TypeSynonymInstances, FlexibleInstances, LambdaCase,-             ScopedTypeVariables #-}---------------------------------------------------------------------------------- |--- Module      :  Language.Haskell.TH.Desugar--- Copyright   :  (C) 2014 Richard Eisenberg--- License     :  BSD-style (see LICENSE)--- Maintainer  :  Ryan Scott--- Stability   :  experimental--- Portability :  non-portable------ Desugars full Template Haskell syntax into a smaller core syntax for further--- processing.----------------------------------------------------------------------------------module Language.Haskell.TH.Desugar (-  -- * Desugared data types-  DExp(..), DLetDec(..), DPat(..),-  DType(..), DForallTelescope(..), DKind, DCxt, DPred,-  DTyVarBndr(..), DTyVarBndrSpec, DTyVarBndrUnit, Specificity(..),-  DMatch(..), DClause(..), DDec(..),-  DDerivClause(..), DDerivStrategy(..), DPatSynDir(..), DPatSynType,-  Overlap(..), PatSynArgs(..), NewOrData(..),-  DTypeFamilyHead(..), DFamilyResultSig(..), InjectivityAnn(..),-  DCon(..), DConFields(..), DDeclaredInfix, DBangType, DVarBangType,-  Bang(..), SourceUnpackedness(..), SourceStrictness(..),-  DForeign(..),-  DPragma(..), DRuleBndr(..), DTySynEqn(..), DInfo(..), DInstanceDec,-  Role(..), AnnTarget(..),--  -- * The 'Desugar' class-  Desugar(..),--  -- * Main desugaring functions-  dsExp, dsDecs, dsType, dsInfo,-  dsPatOverExp, dsPatsOverExp, dsPatX,-  dsLetDecs, dsTvb, dsTvbSpec, dsTvbUnit, dsCxt,-  dsCon, dsForeign, dsPragma, dsRuleBndr,--  -- ** Secondary desugaring functions-  PatM, dsPred, dsPat, dsDec, dsDataDec, dsDataInstDec,-  DerivingClause, dsDerivClause, dsLetDec,-  dsMatches, dsBody, dsGuards, dsDoStmts, dsComp, dsClauses,-  dsBangType, dsVarBangType,-  dsTypeFamilyHead, dsFamilyResultSig,-#if __GLASGOW_HASKELL__ >= 801-  dsPatSynDir,-#endif-  dsTypeArg,--  -- * Converting desugared AST back to TH AST-  module Language.Haskell.TH.Desugar.Sweeten,--  -- * Expanding type synonyms-  expand, expandType,--  -- * Reification-  reifyWithWarning,--  -- ** 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,-  dPatToDExp, removeWilds,-  getDataD, dataConNameToDataName, dataConNameToCon,-  nameOccursIn, allNamesIn, flattenDValD, getRecordSelectors,-  mkTypeName, mkDataName, newUniqueName,-  mkTupleDExp, mkTupleDPat, maybeDLetE, maybeDCaseE, mkDLamEFromDPats,-  tupleDegree_maybe, tupleNameDegree_maybe,-  unboxedSumDegree_maybe, unboxedSumNameDegree_maybe,-  unboxedTupleDegree_maybe, unboxedTupleNameDegree_maybe,-  isTypeKindName, typeKindName, bindIP,-  mkExtraDKindBinders, dTyVarBndrToDType, changeDTVFlags, toposortTyVarsOf,--  -- ** 'FunArgs' and 'VisFunArg'-  FunArgs(..), ForallTelescope(..), VisFunArg(..),-  filterVisFunArgs, ravelType, unravelType,--  -- ** 'DFunArgs' and 'DVisFunArg'-  DFunArgs(..), DVisFunArg(..),-  filterDVisFunArgs, ravelDType, unravelDType,--  -- ** 'TypeArg'-  TypeArg(..), applyType, filterTANormals, unfoldType,--  -- ** 'DTypeArg'-  DTypeArg(..), applyDType, filterDTANormals, 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.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-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 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--instance Desugar Exp DExp where-  desugar = dsExp-  sweeten = expToTH--instance Desugar Type DType where-  desugar = dsType-  sweeten = typeToTH--instance Desugar Cxt DCxt where-  desugar = dsCxt-  sweeten = cxtToTH--#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 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--- 'DVarPa'. Other declarations are passed through unchanged.--- Note that the declarations that come out of this function are rather--- less efficient than those that come in: they have many more pattern--- matches.-flattenDValD :: Quasi q => DLetDec -> q [DLetDec]-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 (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-    mk_val_d x name = do-      y <- newUniqueName "y"-      let pat'  = wildify name y pat-          match = DMatch pat' (DVarE y)-          cas   = DCaseE (DVarE x) [match]-      return $ DValD (DVarP name) cas--    wildify name y p =-      case p of-        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--flattenDValD other_dec = return [other_dec]---- | 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-    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..]-              ]--    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--    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 [DTyVarBndrUnit]-mkExtraDKindBinders k = do-  k' <- expandType k-  let (fun_args, _) = unravelDType k'-      vis_fun_args  = filterDVisFunArgs fun_args-  mapM mk_tvb vis_fun_args-  where-    mk_tvb :: DVisFunArg -> q DTyVarBndrUnit-    mk_tvb (DVisFADep tvb) = return tvb-    mk_tvb (DVisFAAnon ki) = DKindedTV <$> qNewName "a" <*> return () <*> return ki--{- $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.hs
+
+(c) Richard Eisenberg 2013
+rae@cs.brynmawr.edu
+-}
+
+{-# LANGUAGE CPP, MultiParamTypeClasses, FunctionalDependencies,
+             TypeSynonymInstances, FlexibleInstances, LambdaCase,
+             ScopedTypeVariables #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Language.Haskell.TH.Desugar
+-- Copyright   :  (C) 2014 Richard Eisenberg
+-- License     :  BSD-style (see LICENSE)
+-- Maintainer  :  Ryan Scott
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- Desugars full Template Haskell syntax into a smaller core syntax for further
+-- processing.
+--
+----------------------------------------------------------------------------
+
+module Language.Haskell.TH.Desugar (
+  -- * Desugared data types
+  DExp(..), DLetDec(..), DPat(..),
+  DType(..), DForallTelescope(..), DKind, DCxt, DPred,
+  DTyVarBndr(..), DTyVarBndrSpec, DTyVarBndrUnit, Specificity(..),
+  DMatch(..), DClause(..), DDec(..),
+  DDerivClause(..), DDerivStrategy(..), DPatSynDir(..), DPatSynType,
+  Overlap(..), PatSynArgs(..), DataFlavor(..),
+  DTypeFamilyHead(..), DFamilyResultSig(..), InjectivityAnn(..),
+  DCon(..), DConFields(..), DDeclaredInfix, DBangType, DVarBangType,
+  Bang(..), SourceUnpackedness(..), SourceStrictness(..),
+  DForeign(..),
+  DPragma(..), DRuleBndr(..), DTySynEqn(..), DInfo(..), DInstanceDec,
+  Role(..), AnnTarget(..),
+
+  -- * The 'Desugar' class
+  Desugar(..),
+
+  -- * Main desugaring functions
+  dsExp, dsDecs, dsType, dsInfo,
+  dsPatOverExp, dsPatsOverExp, dsPatX,
+  dsLetDecs, dsTvb, dsTvbSpec, dsTvbUnit, dsCxt,
+  dsCon, dsForeign, dsPragma, dsRuleBndr,
+
+  -- ** Secondary desugaring functions
+  PatM, dsPred, dsPat, dsDec, dsDataDec, dsDataInstDec,
+  DerivingClause, dsDerivClause, dsLetDec,
+  dsMatches, dsBody, dsGuards, dsDoStmts, dsComp, dsClauses,
+  dsBangType, dsVarBangType,
+  dsTypeFamilyHead, dsFamilyResultSig,
+#if __GLASGOW_HASKELL__ >= 801
+  dsPatSynDir,
+#endif
+  dsTypeArg,
+
+  -- * Converting desugared AST back to TH AST
+  module Language.Haskell.TH.Desugar.Sweeten,
+
+  -- * Expanding type synonyms
+  expand, expandType,
+
+  -- * Reification
+  reifyWithWarning,
+
+  -- ** 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,
+  dPatToDExp, removeWilds,
+  getDataD, dataConNameToDataName, dataConNameToCon,
+  nameOccursIn, allNamesIn, flattenDValD, getRecordSelectors,
+  mkTypeName, mkDataName, newUniqueName,
+  mkTupleDExp, mkTupleDPat, maybeDLetE, maybeDCaseE, mkDLamEFromDPats,
+  tupleDegree_maybe, tupleNameDegree_maybe,
+  unboxedSumDegree_maybe, unboxedSumNameDegree_maybe,
+  unboxedTupleDegree_maybe, unboxedTupleNameDegree_maybe,
+  isTypeKindName, typeKindName, bindIP,
+  mkExtraDKindBinders, dTyVarBndrToDType, changeDTVFlags, toposortTyVarsOf,
+
+  -- ** 'FunArgs' and 'VisFunArg'
+  FunArgs(..), ForallTelescope(..), VisFunArg(..),
+  filterVisFunArgs, ravelType, unravelType,
+
+  -- ** 'DFunArgs' and 'DVisFunArg'
+  DFunArgs(..), DVisFunArg(..),
+  filterDVisFunArgs, ravelDType, unravelDType,
+
+  -- ** 'TypeArg'
+  TypeArg(..), applyType, filterTANormals, unfoldType,
+
+  -- ** 'DTypeArg'
+  DTypeArg(..), applyDType, filterDTANormals, 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.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
+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 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
+
+instance Desugar Exp DExp where
+  desugar = dsExp
+  sweeten = expToTH
+
+instance Desugar Type DType where
+  desugar = dsType
+  sweeten = typeToTH
+
+instance Desugar Cxt DCxt where
+  desugar = dsCxt
+  sweeten = cxtToTH
+
+#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 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
+-- 'DVarPa'. Other declarations are passed through unchanged.
+-- Note that the declarations that come out of this function are rather
+-- less efficient than those that come in: they have many more pattern
+-- matches.
+flattenDValD :: Quasi q => DLetDec -> q [DLetDec]
+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 (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
+    mk_val_d x name = do
+      y <- newUniqueName "y"
+      let pat'  = wildify name y pat
+          match = DMatch pat' (DVarE y)
+          cas   = DCaseE (DVarE x) [match]
+      return $ DValD (DVarP name) cas
+
+    wildify name y p =
+      case p of
+        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
+
+flattenDValD other_dec = return [other_dec]
+
+-- | 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
+    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..]
+              ]
+
+    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
+
+    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 [DTyVarBndrUnit]
+mkExtraDKindBinders k = do
+  k' <- expandType k
+  let (fun_args, _) = unravelDType k'
+      vis_fun_args  = filterDVisFunArgs fun_args
+  mapM mk_tvb vis_fun_args
+  where
+    mk_tvb :: DVisFunArg -> q DTyVarBndrUnit
+    mk_tvb (DVisFADep tvb) = return tvb
+    mk_tvb (DVisFAAnon ki) = DKindedTV <$> qNewName "a" <*> return () <*> return ki
+
+{- $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
@@ -1,294 +1,313 @@-{- 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, DeriveFunctor, DeriveGeneric #-}--module Language.Haskell.TH.Desugar.AST where--import Data.Data hiding (Fixity)-import GHC.Generics hiding (Fixity)-import Language.Haskell.TH-#if __GLASGOW_HASKELL__ < 900-import Language.Haskell.TH.Datatype.TyVarBndr (Specificity)-#endif---- | Corresponds to TH's @Exp@ type. Note that @DLamE@ takes names, not patterns.-data DExp = DVarE Name-          | DConE Name-          | DLitE Lit-          | DAppE DExp DExp-          | DAppTypeE DExp DType-          | DLamE [Name] DExp-          | DCaseE DExp [DMatch]-          | DLetE [DLetDec] DExp-          | DSigE DExp DType-          | DStaticE DExp-          deriving (Eq, Show, Data, Generic)----- | Corresponds to TH's @Pat@ type.-data DPat = DLitP Lit-          | DVarP Name-          | DConP Name [DType] [DPat]-          | DTildeP DPat-          | DBangP DPat-          | DSigP DPat DType-          | DWildP-          deriving (Eq, Show, Data, Generic)---- | 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)---- | 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)---- | 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)---- | Corresponds to TH's @TyVarBndrSpec@-type DTyVarBndrSpec = DTyVarBndr Specificity---- | Corresponds to TH's @TyVarBndrUnit@-type DTyVarBndrUnit = DTyVarBndr ()---- | Corresponds to TH's @Match@ type.-data DMatch = DMatch DPat DExp-  deriving (Eq, Show, Data, Generic)---- | Corresponds to TH's @Clause@ type.-data DClause = DClause [DPat] DExp-  deriving (Eq, Show, Data, Generic)---- | Declarations as used in a @let@ statement.-data DLetDec = DFunD Name [DClause]-             | DValD DPat DExp-             | DSigD Name DType-             | DInfixD Fixity Name-             | DPragmaD DPragma-             deriving (Eq, Show, Data, Generic)---- | Is it a @newtype@ or a @data@ type?-data NewOrData = Newtype-               | Data-               deriving (Eq, Show, Data, Generic)---- | Corresponds to TH's @Dec@ type.-data DDec = DLetDec DLetDec-          | DDataD NewOrData DCxt Name [DTyVarBndrUnit] (Maybe DKind) [DCon] [DDerivClause]-          | DTySynD Name [DTyVarBndrUnit] DType-          | DClassD DCxt Name [DTyVarBndrUnit] [FunDep] [DDec]-            -- | 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 [DTyVarBndrUnit] (Maybe DKind)-          | DDataInstD NewOrData 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)---- | 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)---- | 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)-#endif---- | Corresponds to TH's 'TypeFamilyHead' type-data DTypeFamilyHead = DTypeFamilyHead Name [DTyVarBndrUnit] DFamilyResultSig-                                       (Maybe InjectivityAnn)-                     deriving (Eq, Show, Data, Generic)---- | Corresponds to TH's 'FamilyResultSig' type-data DFamilyResultSig = DNoSig-                      | DKindSig DKind-                      | DTyVarSig DTyVarBndrUnit-                      deriving (Eq, Show, Data, Generic)---- | 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)---- | 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)---- | '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)---- | Corresponds to TH's @Pragma@ type.-data DPragma = DInlineP Name Inline RuleMatch Phases-             | DSpecialiseP Name DType (Maybe Inline) Phases-             | DSpecialiseInstP DType-             | DRuleP String (Maybe [DTyVarBndrUnit]) [DRuleBndr] DExp DExp Phases-             | DAnnP AnnTarget DExp-             | DLineP Int String-             | DCompleteP [Name] (Maybe Name)-             | DOpaqueP Name-             deriving (Eq, Show, Data, Generic)---- | Corresponds to TH's @RuleBndr@ type.-data DRuleBndr = DRuleVar Name-               | DTypedRuleVar Name DType-               deriving (Eq, Show, Data, Generic)---- | Corresponds to TH's @TySynEqn@ type (to store type family equations).-data DTySynEqn = DTySynEqn (Maybe [DTyVarBndrUnit]) DType DType-               deriving (Eq, Show, Data, Generic)---- | 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)--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)---- | 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)+{- 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, DeriveFunctor, DeriveGeneric, DeriveLift #-}
+
+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
+
+import Language.Haskell.TH.Desugar.Util (DataFlavor)
+
+-- | Corresponds to TH's @Exp@ type. Note that @DLamE@ takes names, not patterns.
+data DExp = DVarE Name
+          | DConE Name
+          | DLitE Lit
+          | DAppE DExp DExp
+          | DAppTypeE DExp DType
+          | DLamE [Name] DExp
+          | DCaseE DExp [DMatch]
+          | DLetE [DLetDec] DExp
+          | DSigE DExp DType
+          | DStaticE DExp
+          deriving (Eq, Show, Data, Generic, Lift)
+
+
+-- | Corresponds to TH's @Pat@ type.
+data DPat = DLitP Lit
+          | DVarP Name
+          | DConP Name [DType] [DPat]
+          | DTildeP DPat
+          | DBangP DPat
+          | DSigP DPat DType
+          | DWildP
+          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, Lift)
+
+-- | Corresponds to TH's @TyVarBndrSpec@
+type DTyVarBndrSpec = DTyVarBndr Specificity
+
+-- | Corresponds to TH's @TyVarBndrUnit@
+type DTyVarBndrUnit = DTyVarBndr ()
+
+-- | Corresponds to TH's @Match@ type.
+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)
+
+-- | Declarations as used in a @let@ statement.
+data DLetDec = DFunD Name [DClause]
+             | DValD DPat DExp
+             | DSigD Name DType
+             | DInfixD Fixity Name
+             | DPragmaD DPragma
+             deriving (Eq, Show, Data, Generic, Lift)
+
+-- | 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 [DTyVarBndrUnit] (Maybe DKind) [DCon] [DDerivClause]
+          | DTySynD Name [DTyVarBndrUnit] DType
+          | DClassD DCxt Name [DTyVarBndrUnit] [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 [DTyVarBndrUnit] (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 [DTyVarBndrUnit] 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
+             | DSpecialiseP Name DType (Maybe Inline) Phases
+             | DSpecialiseInstP DType
+             | DRuleP String (Maybe [DTyVarBndrUnit]) [DRuleBndr] DExp DExp Phases
+             | DAnnP AnnTarget DExp
+             | DLineP Int String
+             | DCompleteP [Name] (Maybe Name)
+             | DOpaqueP Name
+             deriving (Eq, Show, Data, Generic, Lift)
+
+-- | 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,1980 +1,1986 @@-{- Language/Haskell/TH/Desugar/Core.hs--(c) Richard Eisenberg 2013-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 (match, clause, cxt)-import Language.Haskell.TH.Datatype.TyVarBndr-import Language.Haskell.TH.Syntax hiding (lift)--import Control.Monad hiding (forM_, mapM)-import qualified Control.Monad.Fail as Fail-import Control.Monad.Trans (MonadTrans(..))-import Control.Monad.Writer (MonadWriter(..), WriterT(..))-import Control.Monad.Zip-import Data.Data (Data)-import Data.Either (lefts)-import Data.Foldable as F hiding (concat, notElem)-import qualified Data.Map as M-import Data.Map (Map)-import Data.Maybe (isJust, mapMaybe)-import Data.Monoid (All(..))-import qualified Data.Set as S-import Data.Set (Set)-import Data.Traversable--#if __GLASGOW_HASKELL__ >= 803-import GHC.OverloadedLabels ( fromLabel )-#endif--#if __GLASGOW_HASKELL__ >= 807-import GHC.Classes (IP(..))-#endif--#if __GLASGOW_HASKELL__ >= 902-import Data.List.NonEmpty (NonEmpty(..))-import GHC.Records (HasField(..))-#endif--import GHC.Exts-import GHC.Generics (Generic)--import Language.Haskell.TH.Desugar.AST-import Language.Haskell.TH.Desugar.FV-import qualified Language.Haskell.TH.Desugar.OSet as OS-import Language.Haskell.TH.Desugar.OSet (OSet)-import Language.Haskell.TH.Desugar.Util-import Language.Haskell.TH.Desugar.Reify---- | Desugar an expression-dsExp :: DsMonad q => Exp -> q DExp-dsExp (VarE n) = return $ DVarE n-dsExp (ConE n) = return $ DConE n-dsExp (LitE lit) = return $ DLitE lit-dsExp (AppE e1 e2) = DAppE <$> dsExp e1 <*> dsExp e2-dsExp (InfixE Nothing op Nothing) = dsExp op-dsExp (InfixE (Just lhs) op Nothing) = DAppE <$> (dsExp op) <*> (dsExp lhs)-dsExp (InfixE Nothing op (Just rhs)) = do-  lhsName <- newUniqueName "lhs"-  op' <- dsExp op-  rhs' <- dsExp rhs-  return $ DLamE [lhsName] (foldl DAppE op' [DVarE lhsName, rhs'])-dsExp (InfixE (Just lhs) op (Just rhs)) =-  DAppE <$> (DAppE <$> dsExp op <*> dsExp lhs) <*> dsExp rhs-dsExp (UInfixE _ _ _) =-  fail "Cannot desugar unresolved infix operators."-dsExp (ParensE exp) = dsExp exp-dsExp (LamE pats exp) = do-  exp' <- dsExp exp-  (pats', exp'') <- dsPatsOverExp pats exp'-  mkDLamEFromDPats pats' exp''-dsExp (LamCaseE matches) = do-  x <- newUniqueName "x"-  matches' <- dsMatches x matches-  return $ DLamE [x] (DCaseE (DVarE x) matches')-dsExp (TupE exps) = dsTup tupleDataName exps-dsExp (UnboxedTupE exps) = dsTup unboxedTupleDataName exps-dsExp (CondE e1 e2 e3) =-  dsExp (CaseE e1 [mkBoolMatch 'True e2, mkBoolMatch 'False e3])-  where-    mkBoolMatch :: Name -> Exp -> Match-    mkBoolMatch boolDataCon rhs =-      Match (ConP boolDataCon-#if __GLASGOW_HASKELL__ >= 901-                  []-#endif-                  []) (NormalB rhs) []-dsExp (MultiIfE guarded_exps) =-  let failure = mkErrorMatchExpr MultiWayIfAlt in-  dsGuards guarded_exps failure-dsExp (LetE decs exp) = do-  (decs', ip_binder) <- dsLetDecs decs-  exp' <- dsExp exp-  return $ DLetE decs' $ ip_binder exp'-    -- the following special case avoids creating a new "let" when it's not-    -- necessary. See #34.-dsExp (CaseE (VarE scrutinee) matches) = do-  matches' <- dsMatches scrutinee matches-  return $ DCaseE (DVarE scrutinee) matches'-dsExp (CaseE exp matches) = do-  scrutinee <- newUniqueName "scrutinee"-  exp' <- dsExp exp-  matches' <- dsMatches scrutinee matches-  return $ DLetE [DValD (DVarP scrutinee) exp'] $-           DCaseE (DVarE scrutinee) matches'-#if __GLASGOW_HASKELL__ >= 900-dsExp (DoE mb_mod stmts) = dsDoStmts mb_mod stmts-#else-dsExp (DoE        stmts) = dsDoStmts Nothing stmts-#endif-dsExp (CompE stmts) = dsComp stmts-dsExp (ArithSeqE (FromR exp)) = DAppE (DVarE 'enumFrom) <$> dsExp exp-dsExp (ArithSeqE (FromThenR exp1 exp2)) =-  DAppE <$> (DAppE (DVarE 'enumFromThen) <$> dsExp exp1) <*> dsExp exp2-dsExp (ArithSeqE (FromToR exp1 exp2)) =-  DAppE <$> (DAppE (DVarE 'enumFromTo) <$> dsExp exp1) <*> dsExp exp2-dsExp (ArithSeqE (FromThenToR e1 e2 e3)) =-  DAppE <$> (DAppE <$> (DAppE (DVarE 'enumFromThenTo) <$> dsExp e1) <*>-                               dsExp e2) <*>-            dsExp e3-dsExp (ListE exps) = go exps-  where go [] = return $ DConE '[]-        go (h : t) = DAppE <$> (DAppE (DConE '(:)) <$> dsExp h) <*> go t-dsExp (SigE exp ty) = DSigE <$> dsExp exp <*> dsType ty-dsExp (RecConE con_name field_exps) = do-  con <- dataConNameToCon con_name-  reordered <- reorder con-  return $ foldl DAppE (DConE con_name) reordered-  where-    reorder con = case con of-                    NormalC _name fields -> non_record fields-                    InfixC field1 _name field2 -> non_record [field1, field2]-                    RecC _name fields -> reorder_fields fields-                    ForallC _ _ c -> reorder c-                    GadtC _names fields _ret_ty -> non_record fields-                    RecGadtC _names fields _ret_ty -> reorder_fields fields--    reorder_fields fields = reorderFields con_name fields field_exps-                                          (repeat $ DVarE 'undefined)--    non_record fields | null field_exps-                        -- Special case: record construction is allowed for any-                        -- constructor, regardless of whether the constructor-                        -- actually was declared with records, provided that no-                        -- records are given in the expression itself. (See #59).-                        ---                        -- Con{} desugars down to Con undefined ... undefined.-                      = return $ replicate (length fields) $ DVarE 'undefined--                      | otherwise =-                          impossible $ "Record syntax used with non-record constructor "-                                       ++ (show con_name) ++ "."--dsExp (RecUpdE exp field_exps) = do-  -- here, we need to use one of the field names to find the tycon, somewhat dodgily-  first_name <- case field_exps of-                  ((name, _) : _) -> return name-                  _ -> impossible "Record update with no fields listed."-  info <- reifyWithLocals first_name-  applied_type <- case info of-                    VarI _name ty _m_dec -> extract_first_arg ty-                    _ -> impossible "Record update with an invalid field name."-  type_name <- extract_type_name applied_type-  (_, cons) <- getDataD "This seems to be an error in GHC." type_name-  let filtered_cons = filter_cons_with_names cons (map fst field_exps)-  exp' <- dsExp exp-  matches <- mapM con_to_dmatch filtered_cons-  let all_matches-        | length filtered_cons == length cons = matches-        | otherwise                           = matches ++ [error_match]-  return $ DCaseE exp' all_matches-  where-    extract_first_arg :: DsMonad q => Type -> q Type-    extract_first_arg (AppT (AppT ArrowT arg) _) = return arg-    extract_first_arg (ForallT _ _ t) = extract_first_arg t-    extract_first_arg (SigT t _) = extract_first_arg t-    extract_first_arg _ = impossible "Record selector not a function."--    extract_type_name :: DsMonad q => Type -> q Name-    extract_type_name (AppT t1 _) = extract_type_name t1-    extract_type_name (SigT t _) = extract_type_name t-    extract_type_name (ConT n) = return n-    extract_type_name _ = impossible "Record selector domain not a datatype."--    filter_cons_with_names cons field_names =-      filter has_names cons-      where-        args_contain_names args =-          let con_field_names = map fst_of_3 args in-          all (`elem` con_field_names) field_names--        has_names (RecC _con_name args) =-          args_contain_names args-        has_names (RecGadtC _con_name args _ret_ty) =-          args_contain_names args-        has_names (ForallC _ _ c) = has_names c-        has_names _               = False--    rec_con_to_dmatch con_name args = do-      let con_field_names = map fst_of_3 args-      field_var_names <- mapM (newUniqueName . nameBase) con_field_names-      DMatch (DConP con_name [] (map DVarP field_var_names)) <$>-             (foldl DAppE (DConE con_name) <$>-                    (reorderFields con_name args field_exps (map DVarE field_var_names)))--    con_to_dmatch :: DsMonad q => Con -> q DMatch-    con_to_dmatch (RecC con_name args) = rec_con_to_dmatch con_name args-    -- We're assuming the GADT constructor has only one Name here, but since-    -- this constructor was reified, this assumption should always hold true.-    con_to_dmatch (RecGadtC [con_name] args _ret_ty) = rec_con_to_dmatch con_name args-    con_to_dmatch (ForallC _ _ c) = con_to_dmatch c-    con_to_dmatch _ = impossible "Internal error within th-desugar."--    error_match = DMatch DWildP (mkErrorMatchExpr RecUpd)--    fst_of_3 (x, _, _) = x-dsExp (StaticE exp) = DStaticE <$> dsExp exp-dsExp (UnboundVarE n) = return (DVarE n)-#if __GLASGOW_HASKELL__ >= 801-dsExp (AppTypeE exp ty) = DAppTypeE <$> dsExp exp <*> dsType ty-dsExp (UnboxedSumE exp alt arity) =-  DAppE (DConE $ unboxedSumDataName alt arity) <$> dsExp exp-#endif-#if __GLASGOW_HASKELL__ >= 803-dsExp (LabelE str) = return $ DVarE 'fromLabel `DAppTypeE` DLitT (StrTyLit str)-#endif-#if __GLASGOW_HASKELL__ >= 807-dsExp (ImplicitParamVarE n) = return $ DVarE 'ip `DAppTypeE` DLitT (StrTyLit n)-dsExp (MDoE {}) = fail "th-desugar currently does not support RecursiveDo"-#endif-#if __GLASGOW_HASKELL__ >= 902-dsExp (GetFieldE arg field) = DAppE (mkGetFieldProj field) <$> dsExp arg-dsExp (ProjectionE fields) =-  case fields of-    f :| fs -> return $ foldl' comp (mkGetFieldProj f) fs-  where-    comp :: DExp -> String -> DExp-    comp acc f = DVarE '(.) `DAppE` mkGetFieldProj f `DAppE` acc-#endif-#if __GLASGOW_HASKELL__ >= 903-dsExp (LamCasesE clauses) = do-  clauses' <- dsClauses CaseAlt clauses-  numArgs <--    case clauses' of-      (DClause pats _:_) -> return $ length pats-      [] -> fail "\\cases expression must have at least one alternative"-  args <- replicateM numArgs (newUniqueName "x")-  return $ DLamE args $ DCaseE (mkUnboxedTupleDExp (map DVarE args))-                               (map dClauseToUnboxedTupleMatch clauses')-#endif---- | Convert a 'DClause' to a 'DMatch' by bundling all of the clause's patterns--- into a match on a single unboxed tuple pattern. That is, convert this:------ @--- f x y z = rhs--- @------ To this:------ @--- f (# x, y, z #) = rhs--- @------ This is used to desugar @\\cases@ expressions into lambda expressions.-dClauseToUnboxedTupleMatch :: DClause -> DMatch-dClauseToUnboxedTupleMatch (DClause pats rhs) =-  DMatch (mkUnboxedTupleDPat pats) rhs--#if __GLASGOW_HASKELL__ >= 809-dsTup :: DsMonad q => (Int -> Name) -> [Maybe Exp] -> q DExp-dsTup = ds_tup-#else-dsTup :: DsMonad q => (Int -> Name) -> [Exp]       -> q DExp-dsTup tuple_data_name = ds_tup tuple_data_name . map Just-#endif---- | Desugar a tuple (or tuple section) expression.-ds_tup :: forall q. DsMonad q-       => (Int -> Name) -- ^ Compute the 'Name' of a tuple (boxed or unboxed)-                        --   data constructor from its arity.-       -> [Maybe Exp]   -- ^ The tuple's subexpressions. 'Nothing' entries-                        --   denote empty fields in a tuple section.-       -> q DExp-ds_tup tuple_data_name mb_exps = do-  section_exps <- mapM ds_section_exp mb_exps-  let section_vars = lefts section_exps-      tup_body     = mk_tup_body section_exps-  if null section_vars-     then return tup_body -- If this isn't a tuple section,-                          -- don't create a lambda.-     else mkDLamEFromDPats (map DVarP section_vars) tup_body-  where-    -- If dealing with an empty field in a tuple section (Nothing), create a-    -- unique name and return Left. These names will be used to construct the-    -- lambda expression that it desugars to.-    -- (For example, `(,5)` desugars to `\ts -> (,) ts 5`.)-    ---    -- If dealing with a tuple subexpression (Just), desugar it and return-    -- Right.-    ds_section_exp :: Maybe Exp -> q (Either Name DExp)-    ds_section_exp = maybe (Left <$> qNewName "ts") (fmap Right . dsExp)--    mk_tup_body :: [Either Name DExp] -> DExp-    mk_tup_body section_exps =-      foldl' apply_tup_body (DConE $ tuple_data_name (length section_exps))-             section_exps--    apply_tup_body :: DExp -> Either Name DExp -> DExp-    apply_tup_body f (Left n)  = f `DAppE` DVarE n-    apply_tup_body f (Right e) = f `DAppE` e---- | Convert a list of 'DPat' arguments and a 'DExp' body into a 'DLamE'. This--- is needed since 'DLamE' takes a list of 'Name's for its bound variables--- instead of 'DPat's, so some reorganization is needed.-mkDLamEFromDPats :: Quasi q => [DPat] -> DExp -> q DExp-mkDLamEFromDPats pats exp-  | Just names <- mapM stripDVarP_maybe pats-  = return $ DLamE names exp-  | otherwise-  = do arg_names <- replicateM (length pats) (newUniqueName "arg")-       let scrutinee = mkUnboxedTupleDExp (map DVarE arg_names)-           match     = DMatch (mkUnboxedTupleDPat pats) exp-       return $ DLamE arg_names (DCaseE scrutinee [match])-  where-    stripDVarP_maybe :: DPat -> Maybe Name-    stripDVarP_maybe (DVarP n) = Just n-    stripDVarP_maybe _          = Nothing--#if __GLASGOW_HASKELL__ >= 902-mkGetFieldProj :: String -> DExp-mkGetFieldProj field = DVarE 'getField `DAppTypeE` DLitT (StrTyLit field)-#endif---- | Desugar a list of matches for a @case@ statement-dsMatches :: DsMonad q-          => Name     -- ^ Name of the scrutinee, which must be a bare var-          -> [Match]  -- ^ Matches of the @case@ statement-          -> q [DMatch]-dsMatches scr = go-  where-    go :: DsMonad q => [Match] -> q [DMatch]-    go [] = return []-    go (Match pat body where_decs : rest) = do-      rest' <- go rest-      let failure = maybeDCaseE CaseAlt (DVarE scr) rest'-      exp' <- dsBody body where_decs failure-      (pat', exp'') <- dsPatOverExp pat exp'-      uni_pattern <- isUniversalPattern pat' -- incomplete attempt at #6-      if uni_pattern-      then return [DMatch pat' exp'']-      else return (DMatch pat' exp'' : rest')---- | Desugar a @Body@-dsBody :: DsMonad q-       => Body      -- ^ body to desugar-       -> [Dec]     -- ^ "where" declarations-       -> DExp      -- ^ what to do if the guards don't match-       -> q DExp-dsBody (NormalB exp) decs _ = do-  (decs', ip_binder) <- dsLetDecs decs-  exp' <- dsExp exp-  return $ maybeDLetE decs' $ ip_binder exp'-dsBody (GuardedB guarded_exps) decs failure = do-  (decs', ip_binder) <- dsLetDecs decs-  guarded_exp' <- dsGuards guarded_exps failure-  return $ maybeDLetE decs' $ ip_binder guarded_exp'---- | If decs is non-empty, delcare them in a let:-maybeDLetE :: [DLetDec] -> DExp -> DExp-maybeDLetE [] exp   = exp-maybeDLetE decs exp = DLetE decs exp---- | If matches is non-empty, make a case statement; otherwise make an error statement-maybeDCaseE :: MatchContext -> DExp -> [DMatch] -> DExp-maybeDCaseE mc _     []      = mkErrorMatchExpr mc-maybeDCaseE _  scrut matches = DCaseE scrut matches---- | Desugar guarded expressions-dsGuards :: DsMonad q-         => [(Guard, Exp)]  -- ^ Guarded expressions-         -> DExp            -- ^ What to do if none of the guards match-         -> q DExp-dsGuards [] thing_inside = return thing_inside-dsGuards ((NormalG gd, exp) : rest) thing_inside =-  dsGuards ((PatG [NoBindS gd], exp) : rest) thing_inside-dsGuards ((PatG stmts, exp) : rest) thing_inside = do-  success <- dsExp exp-  failure <- dsGuards rest thing_inside-  dsGuardStmts stmts success failure---- | Desugar the @Stmt@s in a guard-dsGuardStmts :: DsMonad q-             => [Stmt]  -- ^ The @Stmt@s to desugar-             -> DExp    -- ^ What to do if the @Stmt@s yield success-             -> DExp    -- ^ What to do if the @Stmt@s yield failure-             -> q DExp-dsGuardStmts [] success _failure = return success-dsGuardStmts (BindS pat exp : rest) success failure = do-  success' <- dsGuardStmts rest success failure-  (pat', success'') <- dsPatOverExp pat success'-  exp' <- dsExp exp-  return $ DCaseE exp' [DMatch pat' success'', DMatch DWildP failure]-dsGuardStmts (LetS decs : rest) success failure = do-  (decs', ip_binder) <- dsLetDecs decs-  success' <- dsGuardStmts rest success failure-  return $ DLetE decs' $ ip_binder success'-  -- special-case a final pattern containing "otherwise" or "True"-  -- note that GHC does this special-casing, too, in DsGRHSs.isTrueLHsExpr-dsGuardStmts [NoBindS exp] success _failure-  | VarE name <- exp-  , name == 'otherwise-  = return success--  | ConE name <- exp-  , name == 'True-  = return success-dsGuardStmts (NoBindS exp : rest) success failure = do-  exp' <- dsExp exp-  success' <- dsGuardStmts rest success failure-  return $ DCaseE exp' [ DMatch (DConP 'True  [] []) success'-                       , DMatch (DConP 'False [] []) failure ]-dsGuardStmts (ParS _ : _) _ _ = impossible "Parallel comprehension in a pattern guard."-#if __GLASGOW_HASKELL__ >= 807-dsGuardStmts (RecS {} : _) _ _ = fail "th-desugar currently does not support RecursiveDo"-#endif---- | Desugar the @Stmt@s in a @do@ expression-dsDoStmts :: forall q. DsMonad q => Maybe ModName -> [Stmt] -> q DExp-dsDoStmts mb_mod = go-  where-    go :: [Stmt] -> q DExp-    go [] = impossible "do-expression ended with something other than bare statement."-    go [NoBindS exp] = dsExp exp-    go (BindS pat exp : rest) = do-      rest' <- go rest-      dsBindS mb_mod exp pat rest' "do expression"-    go (LetS decs : rest) = do-      (decs', ip_binder) <- dsLetDecs decs-      rest' <- go rest-      return $ DLetE decs' $ ip_binder rest'-    go (NoBindS exp : rest) = do-      exp' <- dsExp exp-      rest' <- go rest-      let sequence_name = mk_qual_do_name mb_mod '(>>)-      return $ DAppE (DAppE (DVarE sequence_name) exp') rest'-    go (ParS _ : _) = impossible "Parallel comprehension in a do-statement."-#if __GLASGOW_HASKELL__ >= 807-    go (RecS {} : _) = fail "th-desugar currently does not support RecursiveDo"-#endif---- | Desugar the @Stmt@s in a list or monad comprehension-dsComp :: DsMonad q => [Stmt] -> q DExp-dsComp [] = impossible "List/monad comprehension ended with something other than a bare statement."-dsComp [NoBindS exp] = DAppE (DVarE 'return) <$> dsExp exp-dsComp (BindS pat exp : rest) = do-  rest' <- dsComp rest-  dsBindS Nothing exp pat rest' "monad comprehension"-dsComp (LetS decs : rest) = do-  (decs', ip_binder) <- dsLetDecs decs-  rest' <- dsComp rest-  return $ DLetE decs' $ ip_binder rest'-dsComp (NoBindS exp : rest) = do-  exp' <- dsExp exp-  rest' <- dsComp rest-  return $ DAppE (DAppE (DVarE '(>>)) (DAppE (DVarE 'guard) exp')) rest'-dsComp (ParS stmtss : rest) = do-  (pat, exp) <- dsParComp stmtss-  rest' <- dsComp rest-  DAppE (DAppE (DVarE '(>>=)) exp) <$> mkDLamEFromDPats [pat] rest'-#if __GLASGOW_HASKELL__ >= 807-dsComp (RecS {} : _) = fail "th-desugar currently does not support RecursiveDo"-#endif---- Desugar a binding statement in a do- or list comprehension.------ In the event that the pattern in the statement is partial, the desugared--- case expression will contain a catch-all case that calls 'fail' from either--- 'MonadFail' or 'Monad', depending on whether the @MonadFailDesugaring@--- language extension is enabled or not. (On GHCs older than 8.0, 'fail' from--- 'Monad' is always used.)-dsBindS :: forall q. DsMonad q-        => Maybe ModName -> Exp -> Pat -> DExp -> String -> q DExp-dsBindS mb_mod bind_arg_exp success_pat success_exp ctxt = do-  bind_arg_exp' <- dsExp bind_arg_exp-  (success_pat', success_exp') <- dsPatOverExp success_pat success_exp-  is_univ_pat <- isUniversalPattern success_pat'-  let bind_into = DAppE (DAppE (DVarE bind_name) bind_arg_exp')-  if is_univ_pat-     then bind_into <$> mkDLamEFromDPats [success_pat'] success_exp'-     else do arg_name  <- newUniqueName "arg"-             fail_name <- mk_fail_name-             return $ bind_into $ DLamE [arg_name] $ DCaseE (DVarE arg_name)-               [ DMatch success_pat' success_exp'-               , DMatch DWildP $-                 DVarE fail_name `DAppE`-                   DLitE (StringL $ "Pattern match failure in " ++ ctxt)-               ]-  where-    bind_name = mk_qual_do_name mb_mod '(>>=)--    mk_fail_name :: q Name-#if __GLASGOW_HASKELL__ >= 807-    -- GHC 8.8 deprecates the MonadFailDesugaring extension since its effects-    -- are always enabled. Furthermore, MonadFailDesugaring is no longer-    -- enabled by default, so simply use MonadFail.fail. (That happens to-    -- be the same as Prelude.fail in 8.8+.)-    mk_fail_name = return fail_MonadFail_name-#else-    mk_fail_name = do-      mfd <- qIsExtEnabled MonadFailDesugaring-      return $ if mfd then fail_MonadFail_name else fail_Prelude_name-#endif--    fail_MonadFail_name = mk_qual_do_name mb_mod 'Fail.fail--#if __GLASGOW_HASKELL__ < 807-    fail_Prelude_name = mk_qual_do_name mb_mod 'Prelude.fail-#endif---- | Desugar the contents of a parallel comprehension.---   Returns a @Pat@ containing a tuple of all bound variables and an expression---   to produce the values for those variables-dsParComp :: DsMonad q => [[Stmt]] -> q (DPat, DExp)-dsParComp [] = impossible "Empty list of parallel comprehension statements."-dsParComp [r] = do-  let rv = foldMap extractBoundNamesStmt r-  dsR <- dsComp (r ++ [mk_tuple_stmt rv])-  return (mk_tuple_dpat rv, dsR)-dsParComp (q : rest) = do-  let qv = foldMap extractBoundNamesStmt q-  (rest_pat, rest_exp) <- dsParComp rest-  dsQ <- dsComp (q ++ [mk_tuple_stmt qv])-  let zipped = DAppE (DAppE (DVarE 'mzip) dsQ) rest_exp-  return (DConP (tupleDataName 2) [] [mk_tuple_dpat qv, rest_pat], zipped)---- helper function for dsParComp-mk_tuple_stmt :: OSet Name -> Stmt-mk_tuple_stmt name_set =-  NoBindS (mkTupleExp (F.foldr ((:) . VarE) [] name_set))---- helper function for dsParComp-mk_tuple_dpat :: OSet Name -> DPat-mk_tuple_dpat name_set =-  mkTupleDPat (F.foldr ((:) . DVarP) [] name_set)---- | Desugar a pattern, along with processing a (desugared) expression that--- is the entire scope of the variables bound in the pattern.-dsPatOverExp :: DsMonad q => Pat -> DExp -> q (DPat, DExp)-dsPatOverExp pat exp = do-  (pat', vars) <- runWriterT $ dsPat pat-  let name_decs = map (uncurry (DValD . DVarP)) vars-  return (pat', maybeDLetE name_decs exp)---- | Desugar multiple patterns. Like 'dsPatOverExp'.-dsPatsOverExp :: DsMonad q => [Pat] -> DExp -> q ([DPat], DExp)-dsPatsOverExp pats exp = do-  (pats', vars) <- runWriterT $ mapM dsPat pats-  let name_decs = map (uncurry (DValD . DVarP)) vars-  return (pats', maybeDLetE name_decs exp)---- | Desugar a pattern, returning a list of (Name, DExp) pairs of extra--- variables that must be bound within the scope of the pattern-dsPatX :: DsMonad q => Pat -> q (DPat, [(Name, DExp)])-dsPatX = runWriterT . dsPat---- | Desugaring a pattern also returns the list of variables bound in as-patterns--- and the values they should be bound to. This variables must be brought into--- scope in the "body" of the pattern.-type PatM q = WriterT [(Name, DExp)] q---- | Desugar a pattern.-dsPat :: DsMonad q => Pat -> PatM q DPat-dsPat (LitP lit) = return $ DLitP lit-dsPat (VarP n) = return $ DVarP n-dsPat (TupP pats) = DConP (tupleDataName (length pats)) [] <$> mapM dsPat pats-dsPat (UnboxedTupP pats) = DConP (unboxedTupleDataName (length pats)) [] <$>-                           mapM dsPat pats-#if __GLASGOW_HASKELL__ >= 901-dsPat (ConP name tys pats) = DConP name <$> mapM dsType tys <*> mapM dsPat pats-#else-dsPat (ConP name     pats) = DConP name [] <$> mapM dsPat pats-#endif-dsPat (InfixP p1 name p2) = DConP name [] <$> mapM dsPat [p1, p2]-dsPat (UInfixP _ _ _) =-  fail "Cannot desugar unresolved infix operators."-dsPat (ParensP pat) = dsPat pat-dsPat (TildeP pat) = DTildeP <$> dsPat pat-dsPat (BangP pat) = DBangP <$> dsPat pat-dsPat (AsP name pat) = do-  pat' <- dsPat pat-  pat'' <- lift $ removeWilds pat'-  tell [(name, dPatToDExp pat'')]-  return pat''-dsPat WildP = return DWildP-dsPat (RecP con_name field_pats) = do-  con <- lift $ dataConNameToCon con_name-  reordered <- reorder con-  return $ DConP con_name [] reordered-  where-    reorder con = case con of-                     NormalC _name fields -> non_record fields-                     InfixC field1 _name field2 -> non_record [field1, field2]-                     RecC _name fields -> reorder_fields_pat fields-                     ForallC _ _ c -> reorder c-                     GadtC _names fields _ret_ty -> non_record fields-                     RecGadtC _names fields _ret_ty -> reorder_fields_pat fields--    reorder_fields_pat fields = reorderFieldsPat con_name fields field_pats--    non_record fields | null field_pats-                        -- Special case: record patterns are allowed for any-                        -- constructor, regardless of whether the constructor-                        -- actually was declared with records, provided that-                        -- no records are given in the pattern itself. (See #59).-                        ---                        -- Con{} desugars down to Con _ ... _.-                      = return $ replicate (length fields) DWildP-                      | otherwise = lift $ impossible-                                         $ "Record syntax used with non-record constructor "-                                           ++ (show con_name) ++ "."--dsPat (ListP pats) = go pats-  where go [] = return $ DConP '[] [] []-        go (h : t) = do-          h' <- dsPat h-          t' <- go t-          return $ DConP '(:) [] [h', t']-dsPat (SigP pat ty) = DSigP <$> dsPat pat <*> dsType ty-#if __GLASGOW_HASKELL__ >= 801-dsPat (UnboxedSumP pat alt arity) =-  DConP (unboxedSumDataName alt arity) [] <$> ((:[]) <$> dsPat pat)-#endif-dsPat (ViewP _ _) =-  fail "View patterns are not supported in th-desugar. Use pattern guards instead."---- | Convert a 'DPat' to a 'DExp'. Fails on 'DWildP'.-dPatToDExp :: DPat -> DExp-dPatToDExp (DLitP lit) = DLitE lit-dPatToDExp (DVarP name) = DVarE name-dPatToDExp (DConP name tys pats) = foldl DAppE (foldl DAppTypeE (DConE name) tys) (map dPatToDExp pats)-dPatToDExp (DTildeP pat) = dPatToDExp pat-dPatToDExp (DBangP pat) = dPatToDExp pat-dPatToDExp (DSigP pat ty) = DSigE (dPatToDExp pat) ty-dPatToDExp DWildP = error "Internal error in th-desugar: wildcard in rhs of as-pattern"---- | Remove all wildcards from a pattern, replacing any wildcard with a fresh---   variable-removeWilds :: DsMonad q => DPat -> q DPat-removeWilds p@(DLitP _) = return p-removeWilds p@(DVarP _) = return p-removeWilds (DConP con_name tys pats) = DConP con_name tys <$> mapM removeWilds pats-removeWilds (DTildeP pat) = DTildeP <$> removeWilds pat-removeWilds (DBangP pat) = DBangP <$> removeWilds pat-removeWilds (DSigP pat ty) = DSigP <$> removeWilds pat <*> pure ty-removeWilds DWildP = DVarP <$> newUniqueName "wild"---- | Desugar @Info@-dsInfo :: DsMonad q => Info -> q DInfo-dsInfo (ClassI dec instances) = do-  [ddec]     <- dsDec dec-  dinstances <- dsDecs instances-  return $ DTyConI ddec (Just dinstances)-dsInfo (ClassOpI name ty parent) =-  DVarI name <$> dsType ty <*> pure (Just parent)-dsInfo (TyConI dec) = do-  [ddec] <- dsDec dec-  return $ DTyConI ddec Nothing-dsInfo (FamilyI dec instances) = do-  [ddec]     <- dsDec dec-  dinstances <- dsDecs instances-  return $ DTyConI ddec (Just dinstances)-dsInfo (PrimTyConI name arity unlifted) =-  return $ DPrimTyConI name arity unlifted-dsInfo (DataConI name ty parent) =-  DVarI name <$> dsType ty <*> pure (Just parent)-dsInfo (VarI name ty Nothing) =-  DVarI name <$> dsType ty <*> pure Nothing-dsInfo (VarI name _ (Just _)) =-  impossible $ "Declaration supplied with variable: " ++ show name-dsInfo (TyVarI name ty) = DTyVarI name <$> dsType ty-#if __GLASGOW_HASKELL__ >= 801-dsInfo (PatSynI name ty) = DPatSynI name <$> dsType ty-#endif---- | Desugar arbitrary @Dec@s-dsDecs :: DsMonad q => [Dec] -> q [DDec]-dsDecs = concatMapM dsDec---- | Desugar a single @Dec@, perhaps producing multiple 'DDec's-dsDec :: DsMonad q => Dec -> q [DDec]-dsDec d@(FunD {}) = dsTopLevelLetDec d-dsDec d@(ValD {}) = dsTopLevelLetDec d-dsDec (DataD cxt n tvbs mk cons derivings) =-  dsDataDec Data cxt n tvbs mk cons derivings-dsDec (NewtypeD cxt n tvbs mk con derivings) =-  dsDataDec Newtype cxt n tvbs mk [con] derivings-dsDec (TySynD n tvbs ty) =-  (:[]) <$> (DTySynD n <$> mapM dsTvbUnit tvbs <*> dsType ty)-dsDec (ClassD cxt n tvbs fds decs) =-  (:[]) <$> (DClassD <$> dsCxt cxt <*> pure n <*> mapM dsTvbUnit tvbs-                     <*> pure fds <*> dsDecs decs)-dsDec (InstanceD over cxt ty decs) =-  (:[]) <$> (DInstanceD over Nothing <$> dsCxt cxt <*> dsType ty <*> dsDecs decs)-dsDec d@(SigD {}) = dsTopLevelLetDec d-dsDec (ForeignD f) = (:[]) <$> (DForeignD <$> dsForeign f)-dsDec d@(InfixD {}) = dsTopLevelLetDec d-dsDec d@(PragmaD {}) = dsTopLevelLetDec d-dsDec (OpenTypeFamilyD tfHead) =-  (:[]) <$> (DOpenTypeFamilyD <$> dsTypeFamilyHead tfHead)-dsDec (DataFamilyD n tvbs m_k) =-  (:[]) <$> (DDataFamilyD n <$> mapM dsTvbUnit tvbs <*> mapM dsType m_k)-#if __GLASGOW_HASKELL__ >= 807-dsDec (DataInstD cxt mtvbs lhs mk cons derivings) =-  case unfoldType lhs of-    (ConT n, tys) -> dsDataInstDec Data cxt n mtvbs tys mk cons derivings-    (_, _)        -> fail $ "Unexpected data instance LHS: " ++ pprint lhs-dsDec (NewtypeInstD cxt mtvbs lhs mk con derivings) =-  case unfoldType lhs of-    (ConT n, tys) -> dsDataInstDec Newtype cxt n mtvbs tys mk [con] derivings-    (_, _)        -> fail $ "Unexpected newtype instance LHS: " ++ pprint lhs-#else-dsDec (DataInstD cxt n tys mk cons derivings) =-  dsDataInstDec Data cxt n Nothing (map TANormal tys) mk cons derivings-dsDec (NewtypeInstD cxt n tys mk con derivings) =-  dsDataInstDec Newtype cxt n Nothing (map TANormal tys) mk [con] derivings-#endif-#if __GLASGOW_HASKELL__ >= 807-dsDec (TySynInstD eqn) = (:[]) <$> (DTySynInstD <$> dsTySynEqn unusedArgument eqn)-#else-dsDec (TySynInstD n eqn) = (:[]) <$> (DTySynInstD <$> dsTySynEqn n eqn)-#endif-dsDec (ClosedTypeFamilyD tfHead eqns) =-  (:[]) <$> (DClosedTypeFamilyD <$> dsTypeFamilyHead tfHead-                                <*> mapM (dsTySynEqn (typeFamilyHeadName tfHead)) eqns)-dsDec (RoleAnnotD n roles) = return [DRoleAnnotD n roles]-#if __GLASGOW_HASKELL__ >= 801-dsDec (PatSynD n args dir pat) = do-  dir' <- dsPatSynDir n dir-  (pat', vars) <- dsPatX pat-  unless (null vars) $-    fail $ "Pattern synonym definition cannot contain as-patterns (@)."-  return [DPatSynD n args dir' pat']-dsDec (PatSynSigD n ty) = (:[]) <$> (DPatSynSigD n <$> dsType ty)-dsDec (StandaloneDerivD mds cxt ty) =-  (:[]) <$> (DStandaloneDerivD <$> mapM dsDerivStrategy mds-                               <*> pure Nothing <*> dsCxt cxt <*> dsType ty)-#else-dsDec (StandaloneDerivD cxt ty) =-  (:[]) <$> (DStandaloneDerivD Nothing Nothing <$> dsCxt cxt <*> dsType ty)-#endif-dsDec (DefaultSigD n ty) = (:[]) <$> (DDefaultSigD n <$> dsType ty)-#if __GLASGOW_HASKELL__ >= 807-dsDec (ImplicitParamBindD {}) = impossible "Non-`let`-bound implicit param binding"-#endif-#if __GLASGOW_HASKELL__ >= 809-dsDec (KiSigD n ki) = (:[]) <$> (DKiSigD n <$> dsType ki)-#endif-#if __GLASGOW_HASKELL__ >= 903-dsDec (DefaultD tys) = (:[]) <$> (DDefaultD <$> mapM dsType tys)-#endif---- | Desugar a 'DataD' or 'NewtypeD'.-dsDataDec :: DsMonad q-          => NewOrData -> Cxt -> Name -> [TyVarBndrUnit]-          -> Maybe Kind -> [Con] -> [DerivingClause] -> q [DDec]-dsDataDec nd cxt n tvbs mk cons derivings = do-  tvbs' <- mapM dsTvbUnit tvbs-  let h98_tvbs = case mk of-                   -- If there's an explicit return kind, we're dealing with a-                   -- GADT, so this argument goes unused in dsCon.-                   Just {} -> unusedArgument-                   Nothing -> tvbs'-      h98_return_type = nonFamilyDataReturnType n tvbs'-  (:[]) <$> (DDataD nd <$> dsCxt cxt <*> pure n-                       <*> pure tvbs' <*> mapM dsType mk-                       <*> concatMapM (dsCon h98_tvbs h98_return_type) cons-                       <*> mapM dsDerivClause derivings)---- | Desugar a 'DataInstD' or a 'NewtypeInstD'.-dsDataInstDec :: DsMonad q-              => NewOrData -> Cxt -> Name -> Maybe [TyVarBndrUnit] -> [TypeArg]-              -> Maybe Kind -> [Con] -> [DerivingClause] -> q [DDec]-dsDataInstDec nd cxt n mtvbs tys mk cons derivings = do-  mtvbs' <- mapM (mapM dsTvbUnit) mtvbs-  tys'   <- mapM dsTypeArg tys-  let lhs' = applyDType (DConT n) tys'-      h98_tvbs =-        case (mk, mtvbs') of-          -- If there's an explicit return kind, we're dealing with a-          -- GADT, so this argument goes unused in dsCon.-          (Just {}, _)          -> unusedArgument-          -- H98, and there is an explicit `forall` in front. Just reuse the-          -- type variable binders from the `forall`.-          (Nothing, Just tvbs') -> tvbs'-          -- H98, and no explicit `forall`. Compute the bound variables-          -- manually.-          (Nothing, Nothing)    -> dataFamInstTvbs tys'-      h98_fam_inst_type = dataFamInstReturnType n tys'-  (:[]) <$> (DDataInstD nd <$> dsCxt cxt <*> pure mtvbs'-                           <*> pure lhs' <*> mapM dsType mk-                           <*> concatMapM (dsCon h98_tvbs h98_fam_inst_type) cons-                           <*> mapM dsDerivClause derivings)---- | Desugar a @FamilyResultSig@-dsFamilyResultSig :: DsMonad q => FamilyResultSig -> q DFamilyResultSig-dsFamilyResultSig NoSig          = return DNoSig-dsFamilyResultSig (KindSig k)    = DKindSig <$> dsType k-dsFamilyResultSig (TyVarSig tvb) = DTyVarSig <$> dsTvbUnit tvb---- | Desugar a @TypeFamilyHead@-dsTypeFamilyHead :: DsMonad q => TypeFamilyHead -> q DTypeFamilyHead-dsTypeFamilyHead (TypeFamilyHead n tvbs result inj)-  = DTypeFamilyHead n <$> mapM dsTvbUnit tvbs-                      <*> dsFamilyResultSig result-                      <*> pure inj--typeFamilyHeadName :: TypeFamilyHead -> Name-typeFamilyHeadName (TypeFamilyHead n _ _ _) = n---- | Desugar @Dec@s that can appear in a @let@ expression. See the--- documentation for 'dsLetDec' for an explanation of what the return type--- represents.-dsLetDecs :: DsMonad q => [Dec] -> q ([DLetDec], DExp -> DExp)-dsLetDecs decs = do-  (let_decss, ip_binders) <- mapAndUnzipM dsLetDec decs-  let let_decs :: [DLetDec]-      let_decs = concat let_decss--      ip_binder :: DExp -> DExp-      ip_binder = foldr (.) id ip_binders-  return (let_decs, ip_binder)---- | Desugar a single 'Dec' that can appear in a @let@ expression.--- This produces the following output:------ * One or more 'DLetDec's (a single 'Dec' can produce multiple 'DLetDec's---   in the event of a value declaration that binds multiple things by way---   of pattern matching.------ * A function of type @'DExp' -> 'DExp'@, which should be applied to the---   expression immediately following the 'DLetDec's. This function prepends---   binding forms for any implicit params that were bound in the argument---   'Dec'. (If no implicit params are bound, this is simply the 'id'---   function.)------ For instance, if the argument to 'dsLetDec' is the @?x = 42@ part of this--- expression:------ @--- let { ?x = 42 } in ?x--- @------ Then the output is:------ * @let new_x_val = 42@------ * @\\z -> 'bindIP' \@\"x\" new_x_val z@------ This way, the expression--- @let { new_x_val = 42 } in 'bindIP' \@"x" new_x_val ('ip' \@\"x\")@ can be--- formed. The implicit param binders always come after all the other--- 'DLetDec's to support parallel assignment of implicit params.-dsLetDec :: DsMonad q => Dec -> q ([DLetDec], DExp -> DExp)-dsLetDec (FunD name clauses) = do-  clauses' <- dsClauses (FunRhs name) clauses-  return ([DFunD name clauses'], id)-dsLetDec (ValD pat body where_decs) = do-  (pat', vars) <- dsPatX pat-  body' <- dsBody body where_decs error_exp-  let extras = uncurry (zipWith (DValD . DVarP)) $ unzip vars-  return (DValD pat' body' : extras, id)-  where-    error_exp = mkErrorMatchExpr (LetDecRhs pat)-dsLetDec (SigD name ty) = do-  ty' <- dsType ty-  return ([DSigD name ty'], id)-dsLetDec (InfixD fixity name) = return ([DInfixD fixity name], id)-dsLetDec (PragmaD prag) = do-  prag' <- dsPragma prag-  return ([DPragmaD prag'], id)-#if __GLASGOW_HASKELL__ >= 807-dsLetDec (ImplicitParamBindD n e) = do-  new_n_name <- qNewName $ "new_" ++ n ++ "_val"-  e' <- dsExp e-  let let_dec :: DLetDec-      let_dec = DValD (DVarP new_n_name) e'--      ip_binder :: DExp -> DExp-      ip_binder = (DVarE 'bindIP        `DAppTypeE`-                     DLitT (StrTyLit n) `DAppE`-                     DVarE new_n_name   `DAppE`)-  return ([let_dec], ip_binder)-#endif-dsLetDec _dec = impossible "Illegal declaration in let expression."---- | Desugar a single 'Dec' corresponding to something that could appear after--- the @let@ in a @let@ expression, but occurring at the top level. Because the--- 'Dec' occurs at the top level, there is nothing that would correspond to the--- @in ...@ part of the @let@ expression. As a consequence, this function does--- not return a @'DExp' -> 'DExp'@ function corresonding to implicit param--- binders (these cannot occur at the top level).-dsTopLevelLetDec :: DsMonad q => Dec -> q [DDec]-dsTopLevelLetDec = fmap (map DLetDec . fst) . dsLetDec-  -- Note the use of fst above: we're silently throwing away any implicit param-  -- binders that dsLetDec returns, since there is invariant that there will be-  -- no implicit params in the first place.---- | Desugar a single @Con@.------ Because we always desugar @Con@s to GADT syntax (see the documentation for--- 'DCon'), it is not always possible to desugar with just a 'Con' alone.--- For instance, we must desugar:------ @--- data Foo a = forall b. MkFoo b--- @------ To this:------ @--- data Foo a :: Type where---   MkFoo :: forall a b. b -> Foo a--- @------ If our only argument was @forall b. MkFoo b@, it would be somewhat awkward--- to figure out (1) what the set of universally quantified type variables--- (@[a]@) was, and (2) what the return type (@Foo a@) was. For this reason,--- we require passing these as arguments. (If we desugar an actual GADT--- constructor, these arguments are ignored.)-dsCon :: DsMonad q-      => [DTyVarBndrUnit] -- ^ The universally quantified type variables-                          --   (used if desugaring a non-GADT constructor).-      -> DType            -- ^ The original data declaration's type-                          --   (used if desugaring a non-GADT constructor).-      -> Con -> q [DCon]-dsCon univ_dtvbs data_type con = do-  dcons' <- dsCon' con-  return $ flip map dcons' $ \(n, dtvbs, dcxt, fields, m_gadt_type) ->-    case m_gadt_type of-      Nothing ->-        let ex_dtvbs   = dtvbs-            expl_dtvbs = changeDTVFlags SpecifiedSpec univ_dtvbs ++-                         ex_dtvbs-            impl_dtvbs = changeDTVFlags SpecifiedSpec $-                         toposortTyVarsOf $ mapMaybe extractTvbKind expl_dtvbs in-        DCon (impl_dtvbs ++ expl_dtvbs) dcxt n fields data_type-      Just gadt_type ->-        let univ_ex_dtvbs = dtvbs in-        DCon univ_ex_dtvbs dcxt n fields gadt_type---- Desugar a Con in isolation. The meaning of the returned DTyVarBndrs changes--- depending on what the returned Maybe DType value is:------ * If returning Just gadt_ty, then we've encountered a GadtC or RecGadtC,---   so the returned DTyVarBndrs are both the universally and existentially---   quantified tyvars.--- * If returning Nothing, we're dealing with a non-GADT constructor, so---   the returned DTyVarBndrs are the existentials only.-dsCon' :: DsMonad q-       => Con -> q [(Name, [DTyVarBndrSpec], DCxt, DConFields, Maybe DType)]-dsCon' (NormalC n stys) = do-  dtys <- mapM dsBangType stys-  return [(n, [], [], DNormalC False dtys, Nothing)]-dsCon' (RecC n vstys) = do-  vdtys <- mapM dsVarBangType vstys-  return [(n, [], [], DRecC vdtys, Nothing)]-dsCon' (InfixC sty1 n sty2) = do-  dty1 <- dsBangType sty1-  dty2 <- dsBangType sty2-  return [(n, [], [], DNormalC True [dty1, dty2], Nothing)]-dsCon' (ForallC tvbs cxt con) = do-  dtvbs <- mapM dsTvbSpec tvbs-  dcxt <- dsCxt cxt-  dcons' <- dsCon' con-  return $ flip map dcons' $ \(n, dtvbs', dcxt', fields, m_gadt_type) ->-    (n, dtvbs ++ dtvbs', dcxt ++ dcxt', fields, m_gadt_type)-dsCon' (GadtC nms btys rty) = do-  dbtys <- mapM dsBangType btys-  drty  <- dsType rty-  sequence $ flip map nms $ \nm -> do-    mbFi <- reifyFixityWithLocals nm-    -- A GADT data constructor is declared infix when these three-    -- properties hold:-    let decInfix = isInfixDataCon (nameBase nm) -- 1. Its name uses operator syntax-                                                --    (e.g., (:*:))-                && length dbtys == 2            -- 2. It has exactly two fields-                && isJust mbFi                  -- 3. It has a programmer-specified-                                                --    fixity declaration-    return (nm, [], [], DNormalC decInfix dbtys, Just drty)-dsCon' (RecGadtC nms vbtys rty) = do-  dvbtys <- mapM dsVarBangType vbtys-  drty   <- dsType rty-  return $ flip map nms $ \nm ->-    (nm, [], [], DRecC dvbtys, Just drty)---- | Desugar a @BangType@.-dsBangType :: DsMonad q => BangType -> q DBangType-dsBangType (b, ty) = (b, ) <$> dsType ty---- | Desugar a @VarBangType@.-dsVarBangType :: DsMonad q => VarBangType -> q DVarBangType-dsVarBangType (n, b, ty) = (n, b, ) <$> dsType ty---- | Desugar a @Foreign@.-dsForeign :: DsMonad q => Foreign -> q DForeign-dsForeign (ImportF cc safety str n ty) = DImportF cc safety str n <$> dsType ty-dsForeign (ExportF cc str n ty)        = DExportF cc str n <$> dsType ty---- | Desugar a @Pragma@.-dsPragma :: DsMonad q => Pragma -> q DPragma-dsPragma (InlineP n inl rm phases)       = return $ DInlineP n inl rm phases-dsPragma (SpecialiseP n ty m_inl phases) = DSpecialiseP n <$> dsType ty-                                                          <*> pure m_inl-                                                          <*> pure phases-dsPragma (SpecialiseInstP ty)            = DSpecialiseInstP <$> dsType ty-#if __GLASGOW_HASKELL__ >= 807-dsPragma (RuleP str mtvbs rbs lhs rhs phases)-                                         = DRuleP str <$> mapM (mapM dsTvbUnit) mtvbs-                                                      <*> mapM dsRuleBndr rbs-                                                      <*> dsExp lhs-                                                      <*> dsExp rhs-                                                      <*> pure phases-#else-dsPragma (RuleP str rbs lhs rhs phases)  = DRuleP str Nothing-                                                      <$> mapM dsRuleBndr rbs-                                                      <*> dsExp lhs-                                                      <*> dsExp rhs-                                                      <*> pure phases-#endif-dsPragma (AnnP target exp)               = DAnnP target <$> dsExp exp-dsPragma (LineP n str)                   = return $ DLineP n str-#if __GLASGOW_HASKELL__ >= 801-dsPragma (CompleteP cls mty)             = return $ DCompleteP cls mty-#endif-#if __GLASGOW_HASKELL__ >= 903-dsPragma (OpaqueP n)                     = return $ DOpaqueP n-#endif---- | Desugar a @RuleBndr@.-dsRuleBndr :: DsMonad q => RuleBndr -> q DRuleBndr-dsRuleBndr (RuleVar n)         = return $ DRuleVar n-dsRuleBndr (TypedRuleVar n ty) = DTypedRuleVar n <$> dsType ty--#if __GLASGOW_HASKELL__ >= 807--- | Desugar a @TySynEqn@. (Available only with GHC 7.8+)------ This requires a 'Name' as an argument since 'TySynEqn's did not have--- this information prior to GHC 8.8.-dsTySynEqn :: DsMonad q => Name -> TySynEqn -> q DTySynEqn-dsTySynEqn _ (TySynEqn mtvbs lhs rhs) =-  DTySynEqn <$> mapM (mapM dsTvbUnit) mtvbs <*> dsType lhs <*> dsType rhs-#else--- | Desugar a @TySynEqn@. (Available only with GHC 7.8+)-dsTySynEqn :: DsMonad q => Name -> TySynEqn -> q DTySynEqn-dsTySynEqn n (TySynEqn lhss rhs) = do-  lhss' <- mapM dsType lhss-  let lhs' = applyDType (DConT n) $ map DTANormal lhss'-  DTySynEqn Nothing lhs' <$> dsType rhs-#endif---- | Desugar clauses to a function definition-dsClauses :: DsMonad q-          => MatchContext -- ^ The context in which the clauses arise-          -> [Clause]     -- ^ Clauses to desugar-          -> q [DClause]-dsClauses _ [] = return []-dsClauses mc (Clause pats (NormalB exp) where_decs : rest) = do-  -- this case is necessary to maintain the roundtrip property.-  rest' <- dsClauses mc rest-  exp' <- dsExp exp-  (where_decs', ip_binder) <- dsLetDecs where_decs-  let exp_with_wheres = maybeDLetE where_decs' (ip_binder exp')-  (pats', exp'') <- dsPatsOverExp pats exp_with_wheres-  return $ DClause pats' exp'' : rest'-dsClauses mc clauses@(Clause outer_pats _ _ : _) = do-  arg_names <- replicateM (length outer_pats) (newUniqueName "arg")-  let scrutinee = mkUnboxedTupleDExp (map DVarE arg_names)-  clause <- DClause (map DVarP arg_names) <$>-              (DCaseE scrutinee <$> foldrM (clause_to_dmatch scrutinee) [] clauses)-  return [clause]-  where-    clause_to_dmatch :: DsMonad q => DExp -> Clause -> [DMatch] -> q [DMatch]-    clause_to_dmatch scrutinee (Clause pats body where_decs) failure_matches = do-      let failure_exp = maybeDCaseE mc scrutinee failure_matches-      exp <- dsBody body where_decs failure_exp-      (pats', exp') <- dsPatsOverExp pats exp-      uni_pats <- fmap getAll $ concatMapM (fmap All . isUniversalPattern) pats'-      let match = DMatch (mkUnboxedTupleDPat pats') exp'-      if uni_pats-      then return [match]-      else return (match : failure_matches)---- | The context of a pattern match. This is used to produce--- @Non-exhaustive patterns in...@ messages that are tailored to specific--- situations. Compare this to GHC's @HsMatchContext@ data type--- (https://gitlab.haskell.org/ghc/ghc/-/blob/81cf52bb301592ff3d043d03eb9a0d547891a3e1/compiler/Language/Haskell/Syntax/Expr.hs#L1662-1695),--- from which the @MatchContext@ data type takes inspiration.-data MatchContext-  = FunRhs Name-    -- ^ A pattern matching on an argument of a function binding-  | LetDecRhs Pat-    -- ^ A pattern in a @let@ declaration-  | RecUpd-    -- ^ A record update-  | MultiWayIfAlt-    -- ^ Guards in a multi-way if alternative-  | CaseAlt-    -- ^ Patterns and guards in a case alternative---- | Construct an expression that throws an error when encountering a pattern--- at runtime that is not covered by pattern matching.-mkErrorMatchExpr :: MatchContext -> DExp-mkErrorMatchExpr mc =-  DAppE (DVarE 'error) (DLitE (StringL ("Non-exhaustive patterns in " ++ pp_context)))-  where-    pp_context =-      case mc of-        FunRhs n      -> show n-        LetDecRhs pat -> pprint pat-        RecUpd        -> "record update"-        MultiWayIfAlt -> "multi-way if"-        CaseAlt       -> "case"---- | Desugar a type-dsType :: DsMonad q => Type -> q DType-#if __GLASGOW_HASKELL__ >= 900--- See Note [Gracefully handling linear types]-dsType (MulArrowT `AppT` _) = return DArrowT-dsType MulArrowT = fail "Cannot desugar exotic uses of linear types."-#endif-dsType (ForallT tvbs preds ty) =-  mkDForallConstrainedT <$> (DForallInvis <$> mapM dsTvbSpec tvbs)-                        <*> dsCxt preds <*> dsType ty-dsType (AppT t1 t2) = DAppT <$> dsType t1 <*> dsType t2-dsType (SigT ty ki) = DSigT <$> dsType ty <*> dsType ki-dsType (VarT name) = return $ DVarT name-dsType (ConT name) = return $ DConT name--- The PromotedT case is identical to the ConT case above.--- See Note [Desugaring promoted types].-dsType (PromotedT name) = return $ DConT name-dsType (TupleT n) = return $ DConT (tupleTypeName n)-dsType (UnboxedTupleT n) = return $ DConT (unboxedTupleTypeName n)-dsType ArrowT = return DArrowT-dsType ListT = return $ DConT ''[]-dsType (PromotedTupleT n) = return $ DConT (tupleDataName n)-dsType PromotedNilT = return $ DConT '[]-dsType PromotedConsT = return $ DConT '(:)-dsType StarT = return $ DConT typeKindName-dsType ConstraintT = return $ DConT ''Constraint-dsType (LitT lit) = return $ DLitT lit-dsType EqualityT = return $ DConT ''(~)-dsType (InfixT t1 n t2) = dsInfixT t1 n t2-dsType (UInfixT{}) = dsUInfixT-dsType (ParensT t) = dsType t-dsType WildCardT = return DWildCardT-#if __GLASGOW_HASKELL__ >= 801-dsType (UnboxedSumT arity) = return $ DConT (unboxedSumTypeName arity)-#endif-#if __GLASGOW_HASKELL__ >= 807-dsType (AppKindT t k) = DAppKindT <$> dsType t <*> dsType k-dsType (ImplicitParamT n t) = do-  t' <- dsType t-  return $ DConT ''IP `DAppT` DLitT (StrTyLit n) `DAppT` t'-#endif-#if __GLASGOW_HASKELL__ >= 809-dsType (ForallVisT tvbs ty) =-  DForallT <$> (DForallVis <$> mapM dsTvbUnit tvbs) <*> dsType ty-#endif-#if __GLASGOW_HASKELL__ >= 903--- The PromotedInfixT case is identical to the InfixT case above.--- See Note [Desugaring promoted types].-dsType (PromotedInfixT t1 n t2) = dsInfixT t1 n t2-dsType PromotedUInfixT{} = dsUInfixT-#endif--#if __GLASGOW_HASKELL__ >= 900--- | Desugar a 'TyVarBndr'.-dsTvb :: DsMonad q => TyVarBndr_ flag -> q (DTyVarBndr flag)-dsTvb (PlainTV n flag)    = return $ DPlainTV n flag-dsTvb (KindedTV n flag k) = DKindedTV n flag <$> dsType k-#else--- | Desugar a 'TyVarBndr' with a particular @flag@.-dsTvb :: DsMonad q => flag -> TyVarBndr -> q (DTyVarBndr flag)-dsTvb flag (PlainTV n)    = return $ DPlainTV n flag-dsTvb flag (KindedTV n k) = DKindedTV n flag <$> dsType k-#endif--{--Note [Gracefully handling linear types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Per the README, th-desugar does not currently support linear types.-Unfortunately, we cannot simply reject all occurrences of-multiplicity-polymorphic function arrows (i.e., MulArrowT), as it is possible-for "non-linear" code to contain them when reified. For example, the type of a-Haskell98 data constructor such as `Just` will be reified as--  a #-> Maybe a--In terms of the TH AST, that is:--  MulArrowT `AppT` PromotedConT 'One `AppT` VarT a `AppT` (ConT ''Maybe `AppT` VarT a)--Therefore, in order to desugar these sorts of types, we have to do *something*-with MulArrowT. The approach that th-desugar takes is to pretend that all-multiplicity-polymorphic function arrows are actually ordinary function arrows-(->) when desugaring types. In other words, whenever th-desugar sees-(MulArrowT `AppT` m), for any particular value of `m`, it will turn it into-DArrowT.--This approach is enough to gracefully handle most uses of MulArrowT, as TH-reification always generates MulArrowT applied to some particular multiplicity-(as of GHC 9.0, at least). It's conceivable that some wily user could manually-construct a TH AST containing MulArrowT in a different position, but since this-situation is rare, we simply throw an error in such cases.--We adopt a similar stance in L.H.TH.Desugar.Reify when locally reifying the-types of data constructors: since th-desugar doesn't currently support linear-types, we pretend as if MulArrowT does not exist. As a result, the type of-`Just` would be locally reified as `a -> Maybe a`, not `a #-> Maybe a`.--Note [Desugaring promoted types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-ConT and PromotedT both contain Names as a payload, the only difference being-that PromotedT is intended to refer exclusively to promoted data constructor-Names, while ConT can refer to both type and data constructor Names alike.--When desugaring a PromotedT, we make the assumption that the TH quoting-mechanism produced the correct Name and wrap the name in a DConT. In other-words, we desugar ConT and PromotedT identically. This assumption about-PromotedT may not always be correct, however. Consider this example:--  data a :+: b = Inl a | Inr b-  data Exp a = ... | Exp :+: Exp--How should `PromotedT (mkName ":+:")` be desugared? Morally, it ought to be-desugared to a DConT that contains (:+:) the data constructor, not (:+:) the-type constructor. Deciding between the two is not always straightforward,-however. We could use the `lookupDataName` function to try and distinguish-between the two Names, but this may not necessarily work. This is because the-Name passed to `lookupDataName` could have its original module attached, which-may not be in scope.--Long story short: we make things simple (albeit slightly wrong) by desugaring-ConT and PromotedT identically. We'll wait for someone to complain about the-wrongness of this approach before researching a more accurate solution.--Note that the same considerations also apply to InfixT and PromotedInfixT,-which are also desugared identically.--}---- | Desugar an infix 'Type'.-dsInfixT :: DsMonad q => Type -> Name -> Type -> q DType-dsInfixT t1 n t2 = DAppT <$> (DAppT (DConT n) <$> dsType t1) <*> dsType t2---- | We cannot desugar unresolved infix operators, so fail if we encounter one.-dsUInfixT :: Fail.MonadFail m => m a-dsUInfixT = fail "Cannot desugar unresolved infix operators."---- | Desugar a 'TyVarBndrSpec'.-dsTvbSpec :: DsMonad q => TyVarBndrSpec -> q DTyVarBndrSpec-#if __GLASGOW_HASKELL__ >= 900-dsTvbSpec = dsTvb-#else-dsTvbSpec = dsTvb SpecifiedSpec-#endif---- | Desugar a 'TyVarBndrUnit'.-dsTvbUnit :: DsMonad q => TyVarBndrUnit -> q DTyVarBndrUnit-#if __GLASGOW_HASKELL__ >= 900-dsTvbUnit = dsTvb-#else-dsTvbUnit = dsTvb ()-#endif---- | Desugar a @Cxt@-dsCxt :: DsMonad q => Cxt -> q DCxt-dsCxt = concatMapM dsPred--#if __GLASGOW_HASKELL__ >= 801--- | A backwards-compatible type synonym for the thing representing a single--- derived class in a @deriving@ clause. (This is a @DerivClause@, @Pred@, or--- @Name@ depending on the GHC version.)-type DerivingClause = DerivClause---- | Desugar a @DerivingClause@.-dsDerivClause :: DsMonad q => DerivingClause -> q DDerivClause-dsDerivClause (DerivClause mds cxt) =-  DDerivClause <$> mapM dsDerivStrategy mds <*> dsCxt cxt-#else-type DerivingClause = Pred--dsDerivClause :: DsMonad q => DerivingClause -> q DDerivClause-dsDerivClause p = DDerivClause Nothing <$> dsPred p-#endif--#if __GLASGOW_HASKELL__ >= 801--- | Desugar a @DerivStrategy@.-dsDerivStrategy :: DsMonad q => DerivStrategy -> q DDerivStrategy-dsDerivStrategy StockStrategy    = pure DStockStrategy-dsDerivStrategy AnyclassStrategy = pure DAnyclassStrategy-dsDerivStrategy NewtypeStrategy  = pure DNewtypeStrategy-#if __GLASGOW_HASKELL__ >= 805-dsDerivStrategy (ViaStrategy ty) = DViaStrategy <$> dsType ty-#endif-#endif--#if __GLASGOW_HASKELL__ >= 801--- | Desugar a @PatSynDir@. (Available only with GHC 8.2+)-dsPatSynDir :: DsMonad q => Name -> PatSynDir -> q DPatSynDir-dsPatSynDir _ Unidir              = pure DUnidir-dsPatSynDir _ ImplBidir           = pure DImplBidir-dsPatSynDir n (ExplBidir clauses) = DExplBidir <$> dsClauses (FunRhs n) clauses-#endif---- | Desugar a @Pred@, flattening any internal tuples-dsPred :: DsMonad q => Pred -> q DCxt-dsPred t-  | Just ts <- splitTuple_maybe t-  = concatMapM dsPred ts-dsPred (ForallT tvbs cxt p) = dsForallPred tvbs cxt p-dsPred (AppT t1 t2) = do-  [p1] <- dsPred t1   -- tuples can't be applied!-  (:[]) <$> DAppT p1 <$> dsType t2-dsPred (SigT ty ki) = do-  preds <- dsPred ty-  case preds of-    [p]   -> (:[]) <$> DSigT p <$> dsType ki-    other -> return other   -- just drop the kind signature on a tuple.-dsPred (VarT n) = return [DVarT n]-dsPred (ConT n) = return [DConT n]-dsPred t@(PromotedT _) =-  impossible $ "Promoted type seen as head of constraint: " ++ show t-dsPred (TupleT 0) = return [DConT (tupleTypeName 0)]-dsPred (TupleT _) =-  impossible "Internal error in th-desugar in detecting tuple constraints."-dsPred t@(UnboxedTupleT _) =-  impossible $ "Unboxed tuple seen as head of constraint: " ++ show t-dsPred ArrowT = impossible "Arrow seen as head of constraint."-dsPred ListT  = impossible "List seen as head of constraint."-dsPred (PromotedTupleT _) =-  impossible "Promoted tuple seen as head of constraint."-dsPred PromotedNilT  = impossible "Promoted nil seen as head of constraint."-dsPred PromotedConsT = impossible "Promoted cons seen as head of constraint."-dsPred StarT         = impossible "* seen as head of constraint."-dsPred ConstraintT =-  impossible "The kind `Constraint' seen as head of constraint."-dsPred t@(LitT _) =-  impossible $ "Type literal seen as head of constraint: " ++ show t-dsPred EqualityT = return [DConT ''(~)]-dsPred (InfixT t1 n t2) = (:[]) <$> dsInfixT t1 n t2-dsPred (UInfixT{}) = dsUInfixT-dsPred (ParensT t) = dsPred t-dsPred WildCardT = return [DWildCardT]-#if __GLASGOW_HASKELL__ >= 801-dsPred t@(UnboxedSumT {}) =-  impossible $ "Unboxed sum seen as head of constraint: " ++ show t-#endif-#if __GLASGOW_HASKELL__ >= 807-dsPred (AppKindT t k) = do-  [p] <- dsPred t-  (:[]) <$> (DAppKindT p <$> dsType k)-dsPred (ImplicitParamT n t) = do-  t' <- dsType t-  return [DConT ''IP `DAppT` DLitT (StrTyLit n) `DAppT` t']-#endif-#if __GLASGOW_HASKELL__ >= 809-dsPred t@(ForallVisT {}) =-  impossible $ "Visible dependent quantifier seen as head of constraint: " ++ show t-#endif-#if __GLASGOW_HASKELL__ >= 900-dsPred MulArrowT = impossible "Linear arrow seen as head of constraint."-#endif-#if __GLASGOW_HASKELL__ >= 903-dsPred t@PromotedInfixT{} =-  impossible $ "Promoted infix type seen as head of constraint: " ++ show t-dsPred PromotedUInfixT{} = dsUInfixT-#endif---- | Desugar a quantified constraint.-dsForallPred :: DsMonad q => [TyVarBndrSpec] -> Cxt -> Pred -> q DCxt-dsForallPred tvbs cxt p = do-  ps' <- dsPred p-  case ps' of-    [p'] -> (:[]) <$> (mkDForallConstrainedT <$>-                         (DForallInvis <$> mapM dsTvbSpec tvbs) <*> dsCxt cxt <*> pure p')-    _    -> fail "Cannot desugar constraint tuples in the body of a quantified constraint"-              -- See GHC #15334.---- | Like 'reify', but safer and desugared. Uses local declarations where--- available.-dsReify :: DsMonad q => Name -> q (Maybe DInfo)-dsReify = traverse dsInfo <=< reifyWithLocals_maybe---- | Like 'reifyType', but safer and desugared. Uses local declarations where--- available.-dsReifyType :: DsMonad q => Name -> q (Maybe DType)-dsReifyType = traverse dsType <=< reifyTypeWithLocals_maybe---- Given a list of `forall`ed type variable binders and a context, construct--- a DType using DForallT and DConstrainedT as appropriate. The phrase--- "as appropriate" is used because DConstrainedT will not be used if the--- context is empty, per Note [Desugaring and sweetening ForallT].-mkDForallConstrainedT :: DForallTelescope -> DCxt -> DType -> DType-mkDForallConstrainedT tele ctxt ty =-  DForallT tele $ if null ctxt then ty else DConstrainedT ctxt ty---- create a list of expressions in the same order as the fields in the first argument--- but with the values as given in the second argument--- if a field is missing from the second argument, use the corresponding expression--- from the third argument-reorderFields :: DsMonad q => Name -> [VarStrictType] -> [FieldExp] -> [DExp] -> q [DExp]-reorderFields = reorderFields' dsExp--reorderFieldsPat :: DsMonad q => Name -> [VarStrictType] -> [FieldPat] -> PatM q [DPat]-reorderFieldsPat con_name field_decs field_pats =-  reorderFields' dsPat con_name field_decs field_pats (repeat DWildP)--reorderFields' :: (Applicative m, Fail.MonadFail m)-               => (a -> m da)-               -> Name -- ^ The name of the constructor (used for error reporting)-               -> [VarStrictType] -> [(Name, a)]-               -> [da] -> m [da]-reorderFields' ds_thing con_name field_names_types field_things deflts =-  check_valid_fields >> reorder field_names deflts-  where-    field_names = map (\(a, _, _) -> a) field_names_types--    check_valid_fields =-      forM_ field_things $ \(thing_name, _) ->-        unless (thing_name `elem` field_names) $-          fail $ "Constructor ‘" ++ nameBase con_name   ++ "‘ does not have field ‘"-                                 ++ nameBase thing_name ++ "‘"--    reorder [] _ = return []-    reorder (field_name : rest) (deflt : rest_deflt) = do-      rest' <- reorder rest rest_deflt-      case find (\(thing_name, _) -> thing_name == field_name) field_things of-        Just (_, thing) -> (: rest') <$> ds_thing thing-        Nothing -> return $ deflt : rest'-    reorder (_ : _) [] = error "Internal error in th-desugar."---- mkTupleDExp, mkUnboxedTupleDExp, and friends construct tuples, avoiding the--- use of 1-tuples. These are used to create auxiliary tuple values when--- desugaring pattern-matching constructs to simpler forms.--- See Note [Auxiliary tuples in pattern matching].---- | Make a tuple 'DExp' from a list of 'DExp's. Avoids using a 1-tuple.-mkTupleDExp :: [DExp] -> DExp-mkTupleDExp [exp] = exp-mkTupleDExp exps = foldl DAppE (DConE $ tupleDataName (length exps)) exps---- | Make an unboxed tuple 'DExp' from a list of 'DExp's. Avoids using a 1-tuple.-mkUnboxedTupleDExp :: [DExp] -> DExp-mkUnboxedTupleDExp [exp] = exp-mkUnboxedTupleDExp exps = foldl DAppE (DConE $ unboxedTupleDataName (length exps)) exps---- | Make a tuple 'Exp' from a list of 'Exp's. Avoids using a 1-tuple.-mkTupleExp :: [Exp] -> Exp-mkTupleExp [exp] = exp-mkTupleExp exps = foldl AppE (ConE $ tupleDataName (length exps)) exps---- | Make an unboxed tuple 'Exp' from a list of 'Exp's. Avoids using a 1-tuple.-mkUnboxedTupleExp :: [Exp] -> Exp-mkUnboxedTupleExp [exp] = exp-mkUnboxedTupleExp exps = foldl AppE (ConE $ unboxedTupleDataName (length exps)) exps---- | Make a tuple 'DPat' from a list of 'DPat's. Avoids using a 1-tuple.-mkTupleDPat :: [DPat] -> DPat-mkTupleDPat [pat] = pat-mkTupleDPat pats = DConP (tupleDataName (length pats)) [] pats---- | Make an unboxed tuple 'DPat' from a list of 'DPat's. Avoids using a 1-tuple.-mkUnboxedTupleDPat :: [DPat] -> DPat-mkUnboxedTupleDPat [pat] = pat-mkUnboxedTupleDPat pats = DConP (unboxedTupleDataName (length pats)) [] pats---- | Is this pattern guaranteed to match?-isUniversalPattern :: DsMonad q => DPat -> q Bool-isUniversalPattern (DLitP {}) = return False-isUniversalPattern (DVarP {}) = return True-isUniversalPattern (DConP con_name _ pats) = do-  data_name <- dataConNameToDataName con_name-  (_tvbs, cons) <- getDataD "Internal error." data_name-  if length cons == 1-  then fmap and $ mapM isUniversalPattern pats-  else return False-isUniversalPattern (DTildeP {})  = return True-isUniversalPattern (DBangP pat)  = isUniversalPattern pat-isUniversalPattern (DSigP pat _) = isUniversalPattern pat-isUniversalPattern DWildP        = return True---- | Apply one 'DExp' to a list of arguments-applyDExp :: DExp -> [DExp] -> DExp-applyDExp = foldl DAppE---- | Apply one 'DType' to a list of arguments-applyDType :: DType -> [DTypeArg] -> DType-applyDType = foldl apply-  where-    apply :: DType -> DTypeArg -> DType-    apply f (DTANormal x) = f `DAppT` x-    apply f (DTyArg x)    = f `DAppKindT` x---- | An argument to a type, either a normal type ('DTANormal') or a visible--- kind application ('DTyArg').------ 'DTypeArg' does not appear directly in the @th-desugar@ AST, but it is--- useful when decomposing an application of a 'DType' to its arguments.-data DTypeArg-  = DTANormal DType-  | DTyArg DKind-  deriving (Eq, Show, Data, Generic)---- | Desugar a 'TypeArg'.-dsTypeArg :: DsMonad q => TypeArg -> q DTypeArg-dsTypeArg (TANormal t) = DTANormal <$> dsType t-dsTypeArg (TyArg k)    = DTyArg    <$> dsType k---- | Filter the normal type arguments from a list of 'DTypeArg's.-filterDTANormals :: [DTypeArg] -> [DType]-filterDTANormals = mapMaybe getDTANormal-  where-    getDTANormal :: DTypeArg -> Maybe DType-    getDTANormal (DTANormal t) = Just t-    getDTANormal (DTyArg {})   = Nothing---- | Convert a 'DTyVarBndr' into a 'DType'-dTyVarBndrToDType :: DTyVarBndr flag -> DType-dTyVarBndrToDType (DPlainTV a _)    = DVarT a-dTyVarBndrToDType (DKindedTV a _ k) = DVarT a `DSigT` k---- | Extract the underlying 'DType' or 'DKind' from a 'DTypeArg'. This forgets--- information about whether a type is a normal argument or not, so use with--- caution.-probablyWrongUnDTypeArg :: DTypeArg -> DType-probablyWrongUnDTypeArg (DTANormal t) = t-probablyWrongUnDTypeArg (DTyArg k)    = k---- Take a data type name (which does not belong to a data family) and--- apply it to its type variable binders to form a DType.-nonFamilyDataReturnType :: Name -> [DTyVarBndrUnit] -> DType-nonFamilyDataReturnType con_name =-  applyDType (DConT con_name) . map (DTANormal . dTyVarBndrToDType)---- Take a data family name and apply it to its argument types to form a--- data family instance DType.-dataFamInstReturnType :: Name -> [DTypeArg] -> DType-dataFamInstReturnType fam_name = applyDType (DConT fam_name)---- Data family instance declarations did not come equipped with a list of bound--- type variables until GHC 8.8 (and even then, it's optional whether the user--- provides them or not). This means that there are situations where we must--- reverse engineer this information ourselves from the list of type--- arguments. We accomplish this by taking the free variables of the types--- and performing a reverse topological sort on them to ensure that the--- returned list is well scoped.-dataFamInstTvbs :: [DTypeArg] -> [DTyVarBndrUnit]-dataFamInstTvbs = toposortTyVarsOf . map probablyWrongUnDTypeArg---- | Take a list of 'DType's, find their free variables, and sort them in--- reverse topological order to ensure that they are well scoped. In other--- words, the free variables are ordered such that:------ 1. Whenever an explicit kind signature of the form @(A :: K)@ is---    encountered, the free variables of @K@ will always appear to the left of---    the free variables of @A@ in the returned result.------ 2. The constraint in (1) notwithstanding, free variables will appear in---    left-to-right order of their original appearance.------ On older GHCs, this takes measures to avoid returning explicitly bound--- kind variables, which was not possible before @TypeInType@.-toposortTyVarsOf :: [DType] -> [DTyVarBndrUnit]-toposortTyVarsOf tys =-  let freeVars :: [Name]-      freeVars = F.toList $ foldMap fvDType tys--      varKindSigs :: Map Name DKind-      varKindSigs = foldMap go_ty tys-        where-          go_ty :: DType -> Map Name DKind-          go_ty (DForallT tele t) = go_tele tele (go_ty t)-          go_ty (DConstrainedT ctxt t) = foldMap go_ty ctxt `mappend` go_ty t-          go_ty (DAppT t1 t2) = go_ty t1 `mappend` go_ty t2-          go_ty (DAppKindT t k) = go_ty t `mappend` go_ty k-          go_ty (DSigT t k) =-            let kSigs = go_ty k-            in case t of-                 DVarT n -> M.insert n k kSigs-                 _       -> go_ty t `mappend` kSigs-          go_ty (DVarT {}) = mempty-          go_ty (DConT {}) = mempty-          go_ty DArrowT    = mempty-          go_ty (DLitT {}) = mempty-          go_ty DWildCardT = mempty--          go_tele :: DForallTelescope -> Map Name DKind -> Map Name DKind-          go_tele (DForallVis   tvbs) = go_tvbs tvbs-          go_tele (DForallInvis tvbs) = go_tvbs tvbs--          go_tvbs :: [DTyVarBndr flag] -> Map Name DKind -> Map Name DKind-          go_tvbs tvbs m = foldr go_tvb m tvbs--          go_tvb :: DTyVarBndr flag -> Map Name DKind -> Map Name DKind-          go_tvb (DPlainTV n _)    m = M.delete n m-          go_tvb (DKindedTV n _ k) m = M.delete n m `mappend` go_ty k--      -- | Do a topological sort on a list of tyvars,-      --   so that binders occur before occurrences-      -- E.g. given  [ a::k, k::*, b::k ]-      -- it'll return a well-scoped list [ k::*, a::k, b::k ]-      ---      -- This is a deterministic sorting operation-      -- (that is, doesn't depend on Uniques).-      ---      -- It is also meant to be stable: that is, variables should not-      -- be reordered unnecessarily.-      scopedSort :: [Name] -> [Name]-      scopedSort = go [] []--      go :: [Name]     -- already sorted, in reverse order-         -> [Set Name] -- each set contains all the variables which must be placed-                       -- before the tv corresponding to the set; they are accumulations-                       -- of the fvs in the sorted tvs' kinds--                       -- This list is in 1-to-1 correspondence with the sorted tyvars-                       -- INVARIANT:-                       --   all (\tl -> all (`isSubsetOf` head tl) (tail tl)) (tails fv_list)-                       -- That is, each set in the list is a superset of all later sets.-         -> [Name]     -- yet to be sorted-         -> [Name]-      go acc _fv_list [] = reverse acc-      go acc  fv_list (tv:tvs)-        = go acc' fv_list' tvs-        where-          (acc', fv_list') = insert tv acc fv_list--      insert :: Name       -- var to insert-             -> [Name]     -- sorted list, in reverse order-             -> [Set Name] -- list of fvs, as above-             -> ([Name], [Set Name])   -- augmented lists-      insert tv []     []         = ([tv], [kindFVSet tv])-      insert tv (a:as) (fvs:fvss)-        | tv `S.member` fvs-        , (as', fvss') <- insert tv as fvss-        = (a:as', fvs `S.union` fv_tv : fvss')--        | otherwise-        = (tv:a:as, fvs `S.union` fv_tv : fvs : fvss)-        where-          fv_tv = kindFVSet tv--         -- lists not in correspondence-      insert _ _ _ = error "scopedSort"--      kindFVSet n =-        maybe S.empty (OS.toSet . fvDType)-                      (M.lookup n varKindSigs)-      ascribeWithKind n =-        maybe (DPlainTV n ()) (DKindedTV n ()) (M.lookup n varKindSigs)--  in map ascribeWithKind $-     scopedSort freeVars--dtvbName :: DTyVarBndr flag -> Name-dtvbName (DPlainTV n _)    = n-dtvbName (DKindedTV n _ _) = n---- @mk_qual_do_name mb_mod orig_name@ will simply return @orig_name@ if--- @mb_mod@ is Nothing. If @mb_mod@ is @Just mod_@, then a new 'Name' will be--- returned that uses @mod_@ as the new module prefix. This is useful for--- emulating the behavior of the @QualifiedDo@ extension, which adds module--- prefixes to functions such as ('>>=') and ('>>').-mk_qual_do_name :: Maybe ModName -> Name -> Name-mk_qual_do_name mb_mod orig_name = case mb_mod of-  Nothing   -> orig_name-  Just mod_ -> Name (OccName (nameBase orig_name)) (NameQ mod_)---- | Reconstruct an arrow 'DType' from its argument and result types.-ravelDType :: DFunArgs -> DType -> DType-ravelDType DFANil                 res = res-ravelDType (DFAForalls tele args) res = DForallT tele (ravelDType args res)-ravelDType (DFACxt cxt args)      res = DConstrainedT cxt (ravelDType args res)-ravelDType (DFAAnon t args)       res = DAppT (DAppT DArrowT t) (ravelDType args res)---- | Decompose a function 'DType' into its arguments (the 'DFunArgs') and its--- result type (the 'DType).-unravelDType :: DType -> (DFunArgs, DType)-unravelDType (DForallT tele ty) =-  let (args, res) = unravelDType ty in-  (DFAForalls tele args, res)-unravelDType (DConstrainedT cxt ty) =-  let (args, res) = unravelDType ty in-  (DFACxt cxt args, res)-unravelDType (DAppT (DAppT DArrowT t1) t2) =-  let (args, res) = unravelDType t2 in-  (DFAAnon t1 args, res)-unravelDType t = (DFANil, t)---- | The list of arguments in a function 'DType'.-data DFunArgs-  = DFANil-    -- ^ No more arguments.-  | DFAForalls DForallTelescope DFunArgs-    -- ^ A series of @forall@ed type variables followed by a dot (if-    --   'ForallInvis') or an arrow (if 'ForallVis'). For example,-    --   the type variables @a1 ... an@ in @forall a1 ... an. r@.-  | DFACxt DCxt DFunArgs-    -- ^ A series of constraint arguments followed by @=>@. For example,-    --   the @(c1, ..., cn)@ in @(c1, ..., cn) => r@.-  | DFAAnon DType DFunArgs-    -- ^ An anonymous argument followed by an arrow. For example, the @a@-    --   in @a -> r@.-  deriving (Eq, Show, Data, Generic)---- | A /visible/ function argument type (i.e., one that must be supplied--- explicitly in the source code). This is in contrast to /invisible/--- arguments (e.g., the @c@ in @c => r@), which are instantiated without--- the need for explicit user input.-data DVisFunArg-  = DVisFADep DTyVarBndrUnit-    -- ^ A visible @forall@ (e.g., @forall a -> a@).-  | DVisFAAnon DType-    -- ^ An anonymous argument followed by an arrow (e.g., @a -> r@).-  deriving (Eq, Show, Data, Generic)---- | Filter the visible function arguments from a list of 'DFunArgs'.-filterDVisFunArgs :: DFunArgs -> [DVisFunArg]-filterDVisFunArgs DFANil = []-filterDVisFunArgs (DFAForalls tele args) =-  case tele of-    DForallVis tvbs -> map DVisFADep tvbs ++ args'-    DForallInvis _  -> args'-  where-    args' = filterDVisFunArgs args-filterDVisFunArgs (DFACxt _ args) =-  filterDVisFunArgs args-filterDVisFunArgs (DFAAnon t args) =-  DVisFAAnon t:filterDVisFunArgs args---- | Decompose an applied type into its individual components. For example, this:------ @--- Proxy \@Type Char--- @------ would be unfolded to this:------ @--- ('DConT' ''Proxy, ['DTyArg' ('DConT' ''Type), 'DTANormal' ('DConT' ''Char)])--- @-unfoldDType :: DType -> (DType, [DTypeArg])-unfoldDType = go []-  where-    go :: [DTypeArg] -> DType -> (DType, [DTypeArg])-    go acc (DForallT _ ty)   = go acc ty-    go acc (DAppT ty1 ty2)   = go (DTANormal ty2:acc) ty1-    go acc (DAppKindT ty ki) = go (DTyArg ki:acc) ty-    go acc (DSigT ty _)      = go acc ty-    go acc ty                = (ty, acc)---- | Extract the kind from a 'DTyVarBndr', if one is present.-extractTvbKind :: DTyVarBndr flag -> Maybe DKind-extractTvbKind (DPlainTV _ _)    = Nothing-extractTvbKind (DKindedTV _ _ k) = Just k---- | Set the flag in a list of 'DTyVarBndr's. This is often useful in contexts--- where one needs to re-use a list of 'DTyVarBndr's from one flag setting to--- another flag setting. For example, in order to re-use the 'DTyVarBndr's bound--- by a 'DDataD' in a 'DForallT', one can do the following:------ @--- case x of---   'DDataD' _ _ _ tvbs _ _ _ ->---     'DForallT' ('DForallInvis' ('changeDTVFlags' 'SpecifiedSpec' tvbs)) ...--- @-changeDTVFlags :: newFlag -> [DTyVarBndr oldFlag] -> [DTyVarBndr newFlag]-changeDTVFlags new_flag = map (new_flag <$)---- | Some functions in this module only use certain arguments on particular--- versions of GHC. Other versions of GHC (that don't make use of those--- arguments) might need to conjure up those arguments out of thin air at the--- functions' call sites, so this function serves as a placeholder to use in--- those situations. (In other words, this is a slightly more informative--- version of 'undefined'.)-unusedArgument :: a-unusedArgument = error "Unused"--{--Note [Desugaring and sweetening ForallT]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The ForallT constructor from template-haskell is tremendously awkward. Because-ForallT contains both a list of type variable binders and constraint arguments,-ForallT expressions can be ambiguous when one of these lists is empty. For-example, consider this expression with no constraints:--  ForallT [PlainTV a] [] (VarT a)--What should this desugar to in th-desugar, which must maintain a clear-separation between type variable binders and constraints? There are two-possibilities:--1. DForallT DForallInvis [DPlainTV a] (DVarT a)-   (i.e., forall a. a)-2. DForallT DForallInvis [DPlainTV a] (DConstrainedT [] (DVarT a))-   (i.e., forall a. () => a)--Template Haskell generally drops these empty lists when splicing Template-Haskell expressions, so we would like to do the same in th-desugar to mimic-TH's behavior as closely as possible. However, there are some situations where-dropping empty lists of `forall`ed type variable binders can change the-semantics of a program. For instance, contrast `foo :: forall. a -> a` (which-is an error) with `foo :: a -> a` (which is fine). Therefore, we try to-preserve empty `forall`s to the best of our ability.--Here is an informal specification of how th-desugar should handle different sorts-of ambiguity. First, a specification for desugaring.-Let `tvbs` and `ctxt` be non-empty:--* `ForallT tvbs [] ty` should desugar to `DForallT DForallInvis tvbs ty`.-* `ForallT [] ctxt ty` should desguar to `DForallT DForallInvis [] (DConstrainedT ctxt ty)`.-* `ForallT [] [] ty`   should desugar to `DForallT DForallInvis [] ty`.-* For all other cases, just straightforwardly desugar-  `ForallT tvbs ctxt ty` to `DForallT DForallInvis tvbs (DConstraintedT ctxt ty)`.--For sweetening:--* `DForallT DForallInvis tvbs (DConstrainedT ctxt ty)` should sweeten to `ForallT tvbs ctxt ty`.-* `DForallT DForallInvis []   (DConstrainedT ctxt ty)` should sweeten to `ForallT [] ctxt ty`.-* `DForallT DForallInvis tvbs (DConstrainedT [] ty)`   should sweeten to `ForallT tvbs [] ty`.-* `DForallT DForallInvis []   (DConstrainedT [] ty)`   should sweeten to `ForallT [] [] ty`.-* For all other cases, just straightforwardly sweeten-  `DForallT DForallInvis tvbs ty` to `ForallT tvbs [] ty` and-  `DConstrainedT ctxt ty` to `ForallT [] ctxt ty`.--Note [Auxiliary tuples in pattern matching]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-th-desugar simplifies the overall treatment of pattern matching in two-notable ways:--1. Lambda expressions only bind variables and do not directly perform pattern-   matching. For example, this:--     \True False -> ()--   Roughly desugars to:--     \x y -> case (x, y) of-               (True, False) -> ()-               _             -> error "Non-exhaustive patterns"-2. th-desugar does not have guards, as guards are desugared into pattern-   matches. For example, this:--     f x y | True <- x-           , False <- y-           = ()--  Roughly desugars to:--    f x y = case (x, y) of-              (True, False) -> ()-              _             -> error "Non-exhaustive patterns"--In both of these examples, there are multiple expressions being matched on-simultaneously. When desugaring these examples to `case` expressions, we need a-construct that allows us to group these patterns together. Auxiliary tuples are-one way to accomplish this.--While this use of tuples works well when the arguments have lifted types, such-as Bool, it doesn't work when the arguments have unlifted types, such as Int#.-Imagine desugaring this lambda expression, for instance:--  \27# 42# -> ()--The approach above would desugar this to:--  \x y -> case (x, y) of-            (27#, 42#) -> ()-            _          -> error "Non-exhaustive patterns"--This will not typecheck, however, as we are using _lifted_ tuples, which-require their arguments to have lifted types. If we want to support unlifted-types, we need a different approach.--One idea that seems tempting at first is to create an auxiliary `let`-expression, e.g.,--  \x y ->-    let aux 27# 42# = ()-     in aux x y--This avoids having to use lifted tuples, but it creates a new problem: type-inference. In the general case, auxiliary `let` expressions aren't enough to-handle GADT pattern matches, such as in this example:--  data T a where-    MkT :: Int -> T Int--  g :: T a -> T a -> a-  g = \(MkT x1) (MkT x2) -> x1 + x2--If you desugar `g` to use an auxiliary `let` expression:--  g :: T a -> T a -> a-  g = \t1 t2 ->-        let aux (MkT x1) (MkT x2) = x1 + x2-        in aux t1 t2--Then it will not typecheck. To make this work, you'd need to give `aux` a type-signature. Doing this in general is tantamount to performing type inference,-however, which is very challenging in a Template Haskell setting.--Another approach, which is what th-desugar currently uses, is to use auxiliary-_unboxed_ tuples. This is identical to the previous tuple approach, but with-slightly different syntax:--  \x y -> case (# x, y #) of-            (# 27#, 42# #) -> ()-            _              -> error "Non-exhaustive patterns"--Unboxed tuples can handle lifted and unlifted arguments alike, so it is capable-of handling all the examples above.--You might worry that this approach would require clients of th-desugar to-enable the UnboxedTuples extension in non-obvious places, but fortunately, this-is not the case. For one thing, all unboxed tuples produced by th-desugar would-be TH-generated, so we would bypass the need to enable UnboxedTuples to lex-unboxed tuple syntax. GHC's typechecker also imposes a requirement that-UnboxedTuples be enabled if a variable has an unboxed tuple type, but this-never happens in th-desugar by construction. It's possible that a future-version of GHC might be stricter about this, but it seems unlikely.--There are a couple of exceptions to the general rule that auxiliary binders-should be unboxed:--1. ParallelListComp is desugared using the `mzip` function, which returns a-   lifted pair. As a result, the variables bound in a parallel list-   comprehension must be lifted. This is a restriction which is inherited from-   GHC itself—https://gitlab.haskell.org/ghc/ghc/-/merge_requests/7270.--2. Match flattening desugars lazy patterns that bind multiple variables to code-   that extracts fields from tuples. For instance, this:--     data Pair a b = MkPair a b--     f :: Pair a b -> Pair b a-     f ~(MkPair x y) = MkPair y x--   Desugars to this (roughly) when match-flattened:--     f :: Pair a b -> Pair b a-     f p =-       let tuple = case p of-                     MkPair x y -> (x, y)--           x = case tuple of-                 (x, _) -> x--           y = case tuple of-                 (_, y) -> x--        in MkPair y x--   One could imagine using an unboxed tuple here instead, but since the-   intermediate `tuple` value would have an unboxed tuple this, this would-   require users of match flattening to enable UnboxedTuples. Fortunately,-   using unboxed tuples here isn't necessary, as GHC doesn't support binding-   variables with unlifted types in lazy patterns anyway.--}+{- Language/Haskell/TH/Desugar/Core.hs
+
+(c) Richard Eisenberg 2013
+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 qualified Data.Map as M
+import Data.Map (Map)
+import Data.Maybe (isJust, mapMaybe)
+import Data.Monoid (All(..))
+import qualified Data.Set as S
+import Data.Set (Set)
+import Data.Traversable
+
+#if __GLASGOW_HASKELL__ >= 803
+import GHC.OverloadedLabels ( fromLabel )
+#endif
+
+#if __GLASGOW_HASKELL__ >= 807
+import GHC.Classes (IP(..))
+#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
+
+-- | Desugar an expression
+dsExp :: DsMonad q => Exp -> q DExp
+dsExp (VarE n) = return $ DVarE n
+dsExp (ConE n) = return $ DConE n
+dsExp (LitE lit) = return $ DLitE lit
+dsExp (AppE e1 e2) = DAppE <$> dsExp e1 <*> dsExp e2
+dsExp (InfixE Nothing op Nothing) = dsExp op
+dsExp (InfixE (Just lhs) op Nothing) = DAppE <$> (dsExp op) <*> (dsExp lhs)
+dsExp (InfixE Nothing op (Just rhs)) = do
+  lhsName <- newUniqueName "lhs"
+  op' <- dsExp op
+  rhs' <- dsExp rhs
+  return $ DLamE [lhsName] (foldl DAppE op' [DVarE lhsName, rhs'])
+dsExp (InfixE (Just lhs) op (Just rhs)) =
+  DAppE <$> (DAppE <$> dsExp op <*> dsExp lhs) <*> dsExp rhs
+dsExp (UInfixE _ _ _) =
+  fail "Cannot desugar unresolved infix operators."
+dsExp (ParensE exp) = dsExp exp
+dsExp (LamE pats exp) = do
+  exp' <- dsExp exp
+  (pats', exp'') <- dsPatsOverExp pats exp'
+  mkDLamEFromDPats pats' exp''
+dsExp (LamCaseE matches) = do
+  x <- newUniqueName "x"
+  matches' <- dsMatches x matches
+  return $ DLamE [x] (DCaseE (DVarE x) matches')
+dsExp (TupE exps) = dsTup tupleDataName exps
+dsExp (UnboxedTupE exps) = dsTup unboxedTupleDataName exps
+dsExp (CondE e1 e2 e3) =
+  dsExp (CaseE e1 [mkBoolMatch 'True e2, mkBoolMatch 'False e3])
+  where
+    mkBoolMatch :: Name -> Exp -> Match
+    mkBoolMatch boolDataCon rhs =
+      Match (ConP boolDataCon
+#if __GLASGOW_HASKELL__ >= 901
+                  []
+#endif
+                  []) (NormalB rhs) []
+dsExp (MultiIfE guarded_exps) =
+  let failure = mkErrorMatchExpr MultiWayIfAlt in
+  dsGuards guarded_exps failure
+dsExp (LetE decs exp) = do
+  (decs', ip_binder) <- dsLetDecs decs
+  exp' <- dsExp exp
+  return $ DLetE decs' $ ip_binder exp'
+    -- the following special case avoids creating a new "let" when it's not
+    -- necessary. See #34.
+dsExp (CaseE (VarE scrutinee) matches) = do
+  matches' <- dsMatches scrutinee matches
+  return $ DCaseE (DVarE scrutinee) matches'
+dsExp (CaseE exp matches) = do
+  scrutinee <- newUniqueName "scrutinee"
+  exp' <- dsExp exp
+  matches' <- dsMatches scrutinee matches
+  return $ DLetE [DValD (DVarP scrutinee) exp'] $
+           DCaseE (DVarE scrutinee) matches'
+#if __GLASGOW_HASKELL__ >= 900
+dsExp (DoE mb_mod stmts) = dsDoStmts mb_mod stmts
+#else
+dsExp (DoE        stmts) = dsDoStmts Nothing stmts
+#endif
+dsExp (CompE stmts) = dsComp stmts
+dsExp (ArithSeqE (FromR exp)) = DAppE (DVarE 'enumFrom) <$> dsExp exp
+dsExp (ArithSeqE (FromThenR exp1 exp2)) =
+  DAppE <$> (DAppE (DVarE 'enumFromThen) <$> dsExp exp1) <*> dsExp exp2
+dsExp (ArithSeqE (FromToR exp1 exp2)) =
+  DAppE <$> (DAppE (DVarE 'enumFromTo) <$> dsExp exp1) <*> dsExp exp2
+dsExp (ArithSeqE (FromThenToR e1 e2 e3)) =
+  DAppE <$> (DAppE <$> (DAppE (DVarE 'enumFromThenTo) <$> dsExp e1) <*>
+                               dsExp e2) <*>
+            dsExp e3
+dsExp (ListE exps) = go exps
+  where go [] = return $ DConE '[]
+        go (h : t) = DAppE <$> (DAppE (DConE '(:)) <$> dsExp h) <*> go t
+dsExp (SigE exp ty) = DSigE <$> dsExp exp <*> dsType ty
+dsExp (RecConE con_name field_exps) = do
+  con <- dataConNameToCon con_name
+  reordered <- reorder con
+  return $ foldl DAppE (DConE con_name) reordered
+  where
+    reorder con = case con of
+                    NormalC _name fields -> non_record fields
+                    InfixC field1 _name field2 -> non_record [field1, field2]
+                    RecC _name fields -> reorder_fields fields
+                    ForallC _ _ c -> reorder c
+                    GadtC _names fields _ret_ty -> non_record fields
+                    RecGadtC _names fields _ret_ty -> reorder_fields fields
+
+    reorder_fields fields = reorderFields con_name fields field_exps
+                                          (repeat $ DVarE 'undefined)
+
+    non_record fields | null field_exps
+                        -- Special case: record construction is allowed for any
+                        -- constructor, regardless of whether the constructor
+                        -- actually was declared with records, provided that no
+                        -- records are given in the expression itself. (See #59).
+                        --
+                        -- Con{} desugars down to Con undefined ... undefined.
+                      = return $ replicate (length fields) $ DVarE 'undefined
+
+                      | otherwise =
+                          impossible $ "Record syntax used with non-record constructor "
+                                       ++ (show con_name) ++ "."
+
+dsExp (RecUpdE exp field_exps) = do
+  -- here, we need to use one of the field names to find the tycon, somewhat dodgily
+  first_name <- case field_exps of
+                  ((name, _) : _) -> return name
+                  _ -> impossible "Record update with no fields listed."
+  info <- reifyWithLocals first_name
+  applied_type <- case info of
+                    VarI _name ty _m_dec -> extract_first_arg ty
+                    _ -> impossible "Record update with an invalid field name."
+  type_name <- extract_type_name applied_type
+  (_, _, cons) <- getDataD "This seems to be an error in GHC." type_name
+  let filtered_cons = filter_cons_with_names cons (map fst field_exps)
+  exp' <- dsExp exp
+  matches <- mapM con_to_dmatch filtered_cons
+  let all_matches
+        | length filtered_cons == length cons = matches
+        | otherwise                           = matches ++ [error_match]
+  return $ DCaseE exp' all_matches
+  where
+    extract_first_arg :: DsMonad q => Type -> q Type
+    extract_first_arg (AppT (AppT ArrowT arg) _) = return arg
+    extract_first_arg (ForallT _ _ t) = extract_first_arg t
+    extract_first_arg (SigT t _) = extract_first_arg t
+    extract_first_arg _ = impossible "Record selector not a function."
+
+    extract_type_name :: DsMonad q => Type -> q Name
+    extract_type_name (AppT t1 _) = extract_type_name t1
+    extract_type_name (SigT t _) = extract_type_name t
+    extract_type_name (ConT n) = return n
+    extract_type_name _ = impossible "Record selector domain not a datatype."
+
+    filter_cons_with_names cons field_names =
+      filter has_names cons
+      where
+        args_contain_names args =
+          let con_field_names = map fst_of_3 args in
+          all (`elem` con_field_names) field_names
+
+        has_names (RecC _con_name args) =
+          args_contain_names args
+        has_names (RecGadtC _con_name args _ret_ty) =
+          args_contain_names args
+        has_names (ForallC _ _ c) = has_names c
+        has_names _               = False
+
+    rec_con_to_dmatch con_name args = do
+      let con_field_names = map fst_of_3 args
+      field_var_names <- mapM (newUniqueName . nameBase) con_field_names
+      DMatch (DConP con_name [] (map DVarP field_var_names)) <$>
+             (foldl DAppE (DConE con_name) <$>
+                    (reorderFields con_name args field_exps (map DVarE field_var_names)))
+
+    con_to_dmatch :: DsMonad q => Con -> q DMatch
+    con_to_dmatch (RecC con_name args) = rec_con_to_dmatch con_name args
+    -- We're assuming the GADT constructor has only one Name here, but since
+    -- this constructor was reified, this assumption should always hold true.
+    con_to_dmatch (RecGadtC [con_name] args _ret_ty) = rec_con_to_dmatch con_name args
+    con_to_dmatch (ForallC _ _ c) = con_to_dmatch c
+    con_to_dmatch _ = impossible "Internal error within th-desugar."
+
+    error_match = DMatch DWildP (mkErrorMatchExpr RecUpd)
+
+    fst_of_3 (x, _, _) = x
+dsExp (StaticE exp) = DStaticE <$> dsExp exp
+dsExp (UnboundVarE n) = return (DVarE n)
+#if __GLASGOW_HASKELL__ >= 801
+dsExp (AppTypeE exp ty) = DAppTypeE <$> dsExp exp <*> dsType ty
+dsExp (UnboxedSumE exp alt arity) =
+  DAppE (DConE $ unboxedSumDataName alt arity) <$> dsExp exp
+#endif
+#if __GLASGOW_HASKELL__ >= 803
+dsExp (LabelE str) = return $ DVarE 'fromLabel `DAppTypeE` DLitT (StrTyLit str)
+#endif
+#if __GLASGOW_HASKELL__ >= 807
+dsExp (ImplicitParamVarE n) = return $ DVarE 'ip `DAppTypeE` DLitT (StrTyLit n)
+dsExp (MDoE {}) = fail "th-desugar currently does not support RecursiveDo"
+#endif
+#if __GLASGOW_HASKELL__ >= 902
+dsExp (GetFieldE arg field) = DAppE (mkGetFieldProj field) <$> dsExp arg
+dsExp (ProjectionE fields) =
+  case fields of
+    f :| fs -> return $ foldl' comp (mkGetFieldProj f) fs
+  where
+    comp :: DExp -> String -> DExp
+    comp acc f = DVarE '(.) `DAppE` mkGetFieldProj f `DAppE` acc
+#endif
+#if __GLASGOW_HASKELL__ >= 903
+dsExp (LamCasesE clauses) = do
+  clauses' <- dsClauses CaseAlt clauses
+  numArgs <-
+    case clauses' of
+      (DClause pats _:_) -> return $ length pats
+      [] -> fail "\\cases expression must have at least one alternative"
+  args <- replicateM numArgs (newUniqueName "x")
+  return $ DLamE args $ DCaseE (mkUnboxedTupleDExp (map DVarE args))
+                               (map dClauseToUnboxedTupleMatch clauses')
+#endif
+
+-- | Convert a 'DClause' to a 'DMatch' by bundling all of the clause's patterns
+-- into a match on a single unboxed tuple pattern. That is, convert this:
+--
+-- @
+-- f x y z = rhs
+-- @
+--
+-- To this:
+--
+-- @
+-- f (# x, y, z #) = rhs
+-- @
+--
+-- This is used to desugar @\\cases@ expressions into lambda expressions.
+dClauseToUnboxedTupleMatch :: DClause -> DMatch
+dClauseToUnboxedTupleMatch (DClause pats rhs) =
+  DMatch (mkUnboxedTupleDPat pats) rhs
+
+#if __GLASGOW_HASKELL__ >= 809
+dsTup :: DsMonad q => (Int -> Name) -> [Maybe Exp] -> q DExp
+dsTup = ds_tup
+#else
+dsTup :: DsMonad q => (Int -> Name) -> [Exp]       -> q DExp
+dsTup tuple_data_name = ds_tup tuple_data_name . map Just
+#endif
+
+-- | Desugar a tuple (or tuple section) expression.
+ds_tup :: forall q. DsMonad q
+       => (Int -> Name) -- ^ Compute the 'Name' of a tuple (boxed or unboxed)
+                        --   data constructor from its arity.
+       -> [Maybe Exp]   -- ^ The tuple's subexpressions. 'Nothing' entries
+                        --   denote empty fields in a tuple section.
+       -> q DExp
+ds_tup tuple_data_name mb_exps = do
+  section_exps <- mapM ds_section_exp mb_exps
+  let section_vars = lefts section_exps
+      tup_body     = mk_tup_body section_exps
+  if null section_vars
+     then return tup_body -- If this isn't a tuple section,
+                          -- don't create a lambda.
+     else mkDLamEFromDPats (map DVarP section_vars) tup_body
+  where
+    -- If dealing with an empty field in a tuple section (Nothing), create a
+    -- unique name and return Left. These names will be used to construct the
+    -- lambda expression that it desugars to.
+    -- (For example, `(,5)` desugars to `\ts -> (,) ts 5`.)
+    --
+    -- If dealing with a tuple subexpression (Just), desugar it and return
+    -- Right.
+    ds_section_exp :: Maybe Exp -> q (Either Name DExp)
+    ds_section_exp = maybe (Left <$> qNewName "ts") (fmap Right . dsExp)
+
+    mk_tup_body :: [Either Name DExp] -> DExp
+    mk_tup_body section_exps =
+      foldl' apply_tup_body (DConE $ tuple_data_name (length section_exps))
+             section_exps
+
+    apply_tup_body :: DExp -> Either Name DExp -> DExp
+    apply_tup_body f (Left n)  = f `DAppE` DVarE n
+    apply_tup_body f (Right e) = f `DAppE` e
+
+-- | Convert a list of 'DPat' arguments and a 'DExp' body into a 'DLamE'. This
+-- is needed since 'DLamE' takes a list of 'Name's for its bound variables
+-- instead of 'DPat's, so some reorganization is needed.
+mkDLamEFromDPats :: Quasi q => [DPat] -> DExp -> q DExp
+mkDLamEFromDPats pats exp
+  | Just names <- mapM stripDVarP_maybe pats
+  = return $ DLamE names exp
+  | otherwise
+  = do arg_names <- replicateM (length pats) (newUniqueName "arg")
+       let scrutinee = mkUnboxedTupleDExp (map DVarE arg_names)
+           match     = DMatch (mkUnboxedTupleDPat pats) exp
+       return $ DLamE arg_names (DCaseE scrutinee [match])
+  where
+    stripDVarP_maybe :: DPat -> Maybe Name
+    stripDVarP_maybe (DVarP n) = Just n
+    stripDVarP_maybe _          = Nothing
+
+#if __GLASGOW_HASKELL__ >= 902
+mkGetFieldProj :: String -> DExp
+mkGetFieldProj field = DVarE 'getField `DAppTypeE` DLitT (StrTyLit field)
+#endif
+
+-- | Desugar a list of matches for a @case@ statement
+dsMatches :: DsMonad q
+          => Name     -- ^ Name of the scrutinee, which must be a bare var
+          -> [Match]  -- ^ Matches of the @case@ statement
+          -> q [DMatch]
+dsMatches scr = go
+  where
+    go :: DsMonad q => [Match] -> q [DMatch]
+    go [] = return []
+    go (Match pat body where_decs : rest) = do
+      rest' <- go rest
+      let failure = maybeDCaseE CaseAlt (DVarE scr) rest'
+      exp' <- dsBody body where_decs failure
+      (pat', exp'') <- dsPatOverExp pat exp'
+      uni_pattern <- isUniversalPattern pat' -- incomplete attempt at #6
+      if uni_pattern
+      then return [DMatch pat' exp'']
+      else return (DMatch pat' exp'' : rest')
+
+-- | Desugar a @Body@
+dsBody :: DsMonad q
+       => Body      -- ^ body to desugar
+       -> [Dec]     -- ^ "where" declarations
+       -> DExp      -- ^ what to do if the guards don't match
+       -> q DExp
+dsBody (NormalB exp) decs _ = do
+  (decs', ip_binder) <- dsLetDecs decs
+  exp' <- dsExp exp
+  return $ maybeDLetE decs' $ ip_binder exp'
+dsBody (GuardedB guarded_exps) decs failure = do
+  (decs', ip_binder) <- dsLetDecs decs
+  guarded_exp' <- dsGuards guarded_exps failure
+  return $ maybeDLetE decs' $ ip_binder guarded_exp'
+
+-- | If decs is non-empty, delcare them in a let:
+maybeDLetE :: [DLetDec] -> DExp -> DExp
+maybeDLetE [] exp   = exp
+maybeDLetE decs exp = DLetE decs exp
+
+-- | If matches is non-empty, make a case statement; otherwise make an error statement
+maybeDCaseE :: MatchContext -> DExp -> [DMatch] -> DExp
+maybeDCaseE mc _     []      = mkErrorMatchExpr mc
+maybeDCaseE _  scrut matches = DCaseE scrut matches
+
+-- | Desugar guarded expressions
+dsGuards :: DsMonad q
+         => [(Guard, Exp)]  -- ^ Guarded expressions
+         -> DExp            -- ^ What to do if none of the guards match
+         -> q DExp
+dsGuards [] thing_inside = return thing_inside
+dsGuards ((NormalG gd, exp) : rest) thing_inside =
+  dsGuards ((PatG [NoBindS gd], exp) : rest) thing_inside
+dsGuards ((PatG stmts, exp) : rest) thing_inside = do
+  success <- dsExp exp
+  failure <- dsGuards rest thing_inside
+  dsGuardStmts stmts success failure
+
+-- | Desugar the @Stmt@s in a guard
+dsGuardStmts :: DsMonad q
+             => [Stmt]  -- ^ The @Stmt@s to desugar
+             -> DExp    -- ^ What to do if the @Stmt@s yield success
+             -> DExp    -- ^ What to do if the @Stmt@s yield failure
+             -> q DExp
+dsGuardStmts [] success _failure = return success
+dsGuardStmts (BindS pat exp : rest) success failure = do
+  success' <- dsGuardStmts rest success failure
+  (pat', success'') <- dsPatOverExp pat success'
+  exp' <- dsExp exp
+  return $ DCaseE exp' [DMatch pat' success'', DMatch DWildP failure]
+dsGuardStmts (LetS decs : rest) success failure = do
+  (decs', ip_binder) <- dsLetDecs decs
+  success' <- dsGuardStmts rest success failure
+  return $ DLetE decs' $ ip_binder success'
+  -- special-case a final pattern containing "otherwise" or "True"
+  -- note that GHC does this special-casing, too, in DsGRHSs.isTrueLHsExpr
+dsGuardStmts [NoBindS exp] success _failure
+  | VarE name <- exp
+  , name == 'otherwise
+  = return success
+
+  | ConE name <- exp
+  , name == 'True
+  = return success
+dsGuardStmts (NoBindS exp : rest) success failure = do
+  exp' <- dsExp exp
+  success' <- dsGuardStmts rest success failure
+  return $ DCaseE exp' [ DMatch (DConP 'True  [] []) success'
+                       , DMatch (DConP 'False [] []) failure ]
+dsGuardStmts (ParS _ : _) _ _ = impossible "Parallel comprehension in a pattern guard."
+#if __GLASGOW_HASKELL__ >= 807
+dsGuardStmts (RecS {} : _) _ _ = fail "th-desugar currently does not support RecursiveDo"
+#endif
+
+-- | Desugar the @Stmt@s in a @do@ expression
+dsDoStmts :: forall q. DsMonad q => Maybe ModName -> [Stmt] -> q DExp
+dsDoStmts mb_mod = go
+  where
+    go :: [Stmt] -> q DExp
+    go [] = impossible "do-expression ended with something other than bare statement."
+    go [NoBindS exp] = dsExp exp
+    go (BindS pat exp : rest) = do
+      rest' <- go rest
+      dsBindS mb_mod exp pat rest' "do expression"
+    go (LetS decs : rest) = do
+      (decs', ip_binder) <- dsLetDecs decs
+      rest' <- go rest
+      return $ DLetE decs' $ ip_binder rest'
+    go (NoBindS exp : rest) = do
+      exp' <- dsExp exp
+      rest' <- go rest
+      let sequence_name = mk_qual_do_name mb_mod '(>>)
+      return $ DAppE (DAppE (DVarE sequence_name) exp') rest'
+    go (ParS _ : _) = impossible "Parallel comprehension in a do-statement."
+#if __GLASGOW_HASKELL__ >= 807
+    go (RecS {} : _) = fail "th-desugar currently does not support RecursiveDo"
+#endif
+
+-- | Desugar the @Stmt@s in a list or monad comprehension
+dsComp :: DsMonad q => [Stmt] -> q DExp
+dsComp [] = impossible "List/monad comprehension ended with something other than a bare statement."
+dsComp [NoBindS exp] = DAppE (DVarE 'return) <$> dsExp exp
+dsComp (BindS pat exp : rest) = do
+  rest' <- dsComp rest
+  dsBindS Nothing exp pat rest' "monad comprehension"
+dsComp (LetS decs : rest) = do
+  (decs', ip_binder) <- dsLetDecs decs
+  rest' <- dsComp rest
+  return $ DLetE decs' $ ip_binder rest'
+dsComp (NoBindS exp : rest) = do
+  exp' <- dsExp exp
+  rest' <- dsComp rest
+  return $ DAppE (DAppE (DVarE '(>>)) (DAppE (DVarE 'guard) exp')) rest'
+dsComp (ParS stmtss : rest) = do
+  (pat, exp) <- dsParComp stmtss
+  rest' <- dsComp rest
+  DAppE (DAppE (DVarE '(>>=)) exp) <$> mkDLamEFromDPats [pat] rest'
+#if __GLASGOW_HASKELL__ >= 807
+dsComp (RecS {} : _) = fail "th-desugar currently does not support RecursiveDo"
+#endif
+
+-- Desugar a binding statement in a do- or list comprehension.
+--
+-- In the event that the pattern in the statement is partial, the desugared
+-- case expression will contain a catch-all case that calls 'fail' from either
+-- 'MonadFail' or 'Monad', depending on whether the @MonadFailDesugaring@
+-- language extension is enabled or not. (On GHCs older than 8.0, 'fail' from
+-- 'Monad' is always used.)
+dsBindS :: forall q. DsMonad q
+        => Maybe ModName -> Exp -> Pat -> DExp -> String -> q DExp
+dsBindS mb_mod bind_arg_exp success_pat success_exp ctxt = do
+  bind_arg_exp' <- dsExp bind_arg_exp
+  (success_pat', success_exp') <- dsPatOverExp success_pat success_exp
+  is_univ_pat <- isUniversalPattern success_pat'
+  let bind_into = DAppE (DAppE (DVarE bind_name) bind_arg_exp')
+  if is_univ_pat
+     then bind_into <$> mkDLamEFromDPats [success_pat'] success_exp'
+     else do arg_name  <- newUniqueName "arg"
+             fail_name <- mk_fail_name
+             return $ bind_into $ DLamE [arg_name] $ DCaseE (DVarE arg_name)
+               [ DMatch success_pat' success_exp'
+               , DMatch DWildP $
+                 DVarE fail_name `DAppE`
+                   DLitE (StringL $ "Pattern match failure in " ++ ctxt)
+               ]
+  where
+    bind_name = mk_qual_do_name mb_mod '(>>=)
+
+    mk_fail_name :: q Name
+#if __GLASGOW_HASKELL__ >= 807
+    -- GHC 8.8 deprecates the MonadFailDesugaring extension since its effects
+    -- are always enabled. Furthermore, MonadFailDesugaring is no longer
+    -- enabled by default, so simply use MonadFail.fail. (That happens to
+    -- be the same as Prelude.fail in 8.8+.)
+    mk_fail_name = return fail_MonadFail_name
+#else
+    mk_fail_name = do
+      mfd <- qIsExtEnabled 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.
+--   Returns a @Pat@ containing a tuple of all bound variables and an expression
+--   to produce the values for those variables
+dsParComp :: DsMonad q => [[Stmt]] -> q (DPat, DExp)
+dsParComp [] = impossible "Empty list of parallel comprehension statements."
+dsParComp [r] = do
+  let rv = foldMap extractBoundNamesStmt r
+  dsR <- dsComp (r ++ [mk_tuple_stmt rv])
+  return (mk_tuple_dpat rv, dsR)
+dsParComp (q : rest) = do
+  let qv = foldMap extractBoundNamesStmt q
+  (rest_pat, rest_exp) <- dsParComp rest
+  dsQ <- dsComp (q ++ [mk_tuple_stmt qv])
+  let zipped = DAppE (DAppE (DVarE 'mzip) dsQ) rest_exp
+  return (DConP (tupleDataName 2) [] [mk_tuple_dpat qv, rest_pat], zipped)
+
+-- helper function for dsParComp
+mk_tuple_stmt :: OSet Name -> Stmt
+mk_tuple_stmt name_set =
+  NoBindS (mkTupleExp (F.foldr ((:) . VarE) [] name_set))
+
+-- helper function for dsParComp
+mk_tuple_dpat :: OSet Name -> DPat
+mk_tuple_dpat name_set =
+  mkTupleDPat (F.foldr ((:) . DVarP) [] name_set)
+
+-- | Desugar a pattern, along with processing a (desugared) expression that
+-- is the entire scope of the variables bound in the pattern.
+dsPatOverExp :: DsMonad q => Pat -> DExp -> q (DPat, DExp)
+dsPatOverExp pat exp = do
+  (pat', vars) <- runWriterT $ dsPat pat
+  let name_decs = map (uncurry (DValD . DVarP)) vars
+  return (pat', maybeDLetE name_decs exp)
+
+-- | Desugar multiple patterns. Like 'dsPatOverExp'.
+dsPatsOverExp :: DsMonad q => [Pat] -> DExp -> q ([DPat], DExp)
+dsPatsOverExp pats exp = do
+  (pats', vars) <- runWriterT $ mapM dsPat pats
+  let name_decs = map (uncurry (DValD . DVarP)) vars
+  return (pats', maybeDLetE name_decs exp)
+
+-- | Desugar a pattern, returning a list of (Name, DExp) pairs of extra
+-- variables that must be bound within the scope of the pattern
+dsPatX :: DsMonad q => Pat -> q (DPat, [(Name, DExp)])
+dsPatX = runWriterT . dsPat
+
+-- | Desugaring a pattern also returns the list of variables bound in as-patterns
+-- and the values they should be bound to. This variables must be brought into
+-- scope in the "body" of the pattern.
+type PatM q = WriterT [(Name, DExp)] q
+
+-- | Desugar a pattern.
+dsPat :: DsMonad q => Pat -> PatM q DPat
+dsPat (LitP lit) = return $ DLitP lit
+dsPat (VarP n) = return $ DVarP n
+dsPat (TupP pats) = DConP (tupleDataName (length pats)) [] <$> mapM dsPat pats
+dsPat (UnboxedTupP pats) = DConP (unboxedTupleDataName (length pats)) [] <$>
+                           mapM dsPat pats
+#if __GLASGOW_HASKELL__ >= 901
+dsPat (ConP name tys pats) = DConP name <$> mapM dsType tys <*> mapM dsPat pats
+#else
+dsPat (ConP name     pats) = DConP name [] <$> mapM dsPat pats
+#endif
+dsPat (InfixP p1 name p2) = DConP name [] <$> mapM dsPat [p1, p2]
+dsPat (UInfixP _ _ _) =
+  fail "Cannot desugar unresolved infix operators."
+dsPat (ParensP pat) = dsPat pat
+dsPat (TildeP pat) = DTildeP <$> dsPat pat
+dsPat (BangP pat) = DBangP <$> dsPat pat
+dsPat (AsP name pat) = do
+  pat' <- dsPat pat
+  pat'' <- lift $ removeWilds pat'
+  tell [(name, dPatToDExp pat'')]
+  return pat''
+dsPat WildP = return DWildP
+dsPat (RecP con_name field_pats) = do
+  con <- lift $ dataConNameToCon con_name
+  reordered <- reorder con
+  return $ DConP con_name [] reordered
+  where
+    reorder con = case con of
+                     NormalC _name fields -> non_record fields
+                     InfixC field1 _name field2 -> non_record [field1, field2]
+                     RecC _name fields -> reorder_fields_pat fields
+                     ForallC _ _ c -> reorder c
+                     GadtC _names fields _ret_ty -> non_record fields
+                     RecGadtC _names fields _ret_ty -> reorder_fields_pat fields
+
+    reorder_fields_pat fields = reorderFieldsPat con_name fields field_pats
+
+    non_record fields | null field_pats
+                        -- Special case: record patterns are allowed for any
+                        -- constructor, regardless of whether the constructor
+                        -- actually was declared with records, provided that
+                        -- no records are given in the pattern itself. (See #59).
+                        --
+                        -- Con{} desugars down to Con _ ... _.
+                      = return $ replicate (length fields) DWildP
+                      | otherwise = lift $ impossible
+                                         $ "Record syntax used with non-record constructor "
+                                           ++ (show con_name) ++ "."
+
+dsPat (ListP pats) = go pats
+  where go [] = return $ DConP '[] [] []
+        go (h : t) = do
+          h' <- dsPat h
+          t' <- go t
+          return $ DConP '(:) [] [h', t']
+dsPat (SigP pat ty) = DSigP <$> dsPat pat <*> dsType ty
+#if __GLASGOW_HASKELL__ >= 801
+dsPat (UnboxedSumP pat alt arity) =
+  DConP (unboxedSumDataName alt arity) [] <$> ((:[]) <$> dsPat pat)
+#endif
+dsPat (ViewP _ _) =
+  fail "View patterns are not supported in th-desugar. Use pattern guards instead."
+
+-- | Convert a 'DPat' to a 'DExp'. Fails on 'DWildP'.
+dPatToDExp :: DPat -> DExp
+dPatToDExp (DLitP lit) = DLitE lit
+dPatToDExp (DVarP name) = DVarE name
+dPatToDExp (DConP name tys pats) = foldl DAppE (foldl DAppTypeE (DConE name) tys) (map dPatToDExp pats)
+dPatToDExp (DTildeP pat) = dPatToDExp pat
+dPatToDExp (DBangP pat) = dPatToDExp pat
+dPatToDExp (DSigP pat ty) = DSigE (dPatToDExp pat) ty
+dPatToDExp DWildP = error "Internal error in th-desugar: wildcard in rhs of as-pattern"
+
+-- | Remove all wildcards from a pattern, replacing any wildcard with a fresh
+--   variable
+removeWilds :: DsMonad q => DPat -> q DPat
+removeWilds p@(DLitP _) = return p
+removeWilds p@(DVarP _) = return p
+removeWilds (DConP con_name tys pats) = DConP con_name tys <$> mapM removeWilds pats
+removeWilds (DTildeP pat) = DTildeP <$> removeWilds pat
+removeWilds (DBangP pat) = DBangP <$> removeWilds pat
+removeWilds (DSigP pat ty) = DSigP <$> removeWilds pat <*> pure ty
+removeWilds DWildP = DVarP <$> newUniqueName "wild"
+
+-- | Desugar @Info@
+dsInfo :: DsMonad q => Info -> q DInfo
+dsInfo (ClassI dec instances) = do
+  [ddec]     <- dsDec dec
+  dinstances <- dsDecs instances
+  return $ DTyConI ddec (Just dinstances)
+dsInfo (ClassOpI name ty parent) =
+  DVarI name <$> dsType ty <*> pure (Just parent)
+dsInfo (TyConI dec) = do
+  [ddec] <- dsDec dec
+  return $ DTyConI ddec Nothing
+dsInfo (FamilyI dec instances) = do
+  [ddec]     <- dsDec dec
+  dinstances <- dsDecs instances
+  return $ DTyConI ddec (Just dinstances)
+dsInfo (PrimTyConI name arity unlifted) =
+  return $ DPrimTyConI name arity unlifted
+dsInfo (DataConI name ty parent) =
+  DVarI name <$> dsType ty <*> pure (Just parent)
+dsInfo (VarI name ty Nothing) =
+  DVarI name <$> dsType ty <*> pure Nothing
+dsInfo (VarI name _ (Just _)) =
+  impossible $ "Declaration supplied with variable: " ++ show name
+dsInfo (TyVarI name ty) = DTyVarI name <$> dsType ty
+#if __GLASGOW_HASKELL__ >= 801
+dsInfo (PatSynI name ty) = DPatSynI name <$> dsType ty
+#endif
+
+-- | Desugar arbitrary @Dec@s
+dsDecs :: DsMonad q => [Dec] -> q [DDec]
+dsDecs = concatMapM dsDec
+
+-- | Desugar a single @Dec@, perhaps producing multiple 'DDec's
+dsDec :: DsMonad q => Dec -> q [DDec]
+dsDec d@(FunD {}) = dsTopLevelLetDec d
+dsDec d@(ValD {}) = dsTopLevelLetDec d
+dsDec (DataD cxt n tvbs mk cons derivings) =
+  dsDataDec Data cxt n tvbs mk cons derivings
+dsDec (NewtypeD cxt n tvbs mk con derivings) =
+  dsDataDec Newtype cxt n tvbs mk [con] derivings
+dsDec (TySynD n tvbs ty) =
+  (:[]) <$> (DTySynD n <$> mapM dsTvbUnit tvbs <*> dsType ty)
+dsDec (ClassD cxt n tvbs fds decs) =
+  (:[]) <$> (DClassD <$> dsCxt cxt <*> pure n <*> mapM dsTvbUnit tvbs
+                     <*> pure fds <*> dsDecs decs)
+dsDec (InstanceD over cxt ty decs) =
+  (:[]) <$> (DInstanceD over Nothing <$> dsCxt cxt <*> dsType ty <*> dsDecs decs)
+dsDec d@(SigD {}) = dsTopLevelLetDec d
+dsDec (ForeignD f) = (:[]) <$> (DForeignD <$> dsForeign f)
+dsDec d@(InfixD {}) = dsTopLevelLetDec d
+dsDec d@(PragmaD {}) = dsTopLevelLetDec d
+dsDec (OpenTypeFamilyD tfHead) =
+  (:[]) <$> (DOpenTypeFamilyD <$> dsTypeFamilyHead tfHead)
+dsDec (DataFamilyD n tvbs m_k) =
+  (:[]) <$> (DDataFamilyD n <$> mapM dsTvbUnit tvbs <*> mapM dsType m_k)
+#if __GLASGOW_HASKELL__ >= 807
+dsDec (DataInstD cxt mtvbs lhs mk cons derivings) =
+  case unfoldType lhs of
+    (ConT n, tys) -> dsDataInstDec Data cxt n mtvbs tys mk cons derivings
+    (_, _)        -> fail $ "Unexpected data instance LHS: " ++ pprint lhs
+dsDec (NewtypeInstD cxt mtvbs lhs mk con derivings) =
+  case unfoldType lhs of
+    (ConT n, tys) -> dsDataInstDec Newtype cxt n mtvbs tys mk [con] derivings
+    (_, _)        -> fail $ "Unexpected newtype instance LHS: " ++ pprint lhs
+#else
+dsDec (DataInstD cxt n tys mk cons derivings) =
+  dsDataInstDec Data cxt n Nothing (map TANormal tys) mk cons derivings
+dsDec (NewtypeInstD cxt n tys mk con derivings) =
+  dsDataInstDec Newtype cxt n Nothing (map TANormal tys) mk [con] derivings
+#endif
+#if __GLASGOW_HASKELL__ >= 807
+dsDec (TySynInstD eqn) = (:[]) <$> (DTySynInstD <$> dsTySynEqn unusedArgument eqn)
+#else
+dsDec (TySynInstD n eqn) = (:[]) <$> (DTySynInstD <$> dsTySynEqn n eqn)
+#endif
+dsDec (ClosedTypeFamilyD tfHead eqns) =
+  (:[]) <$> (DClosedTypeFamilyD <$> dsTypeFamilyHead tfHead
+                                <*> mapM (dsTySynEqn (typeFamilyHeadName tfHead)) eqns)
+dsDec (RoleAnnotD n roles) = return [DRoleAnnotD n roles]
+#if __GLASGOW_HASKELL__ >= 801
+dsDec (PatSynD n args dir pat) = do
+  dir' <- dsPatSynDir n dir
+  (pat', vars) <- dsPatX pat
+  unless (null vars) $
+    fail $ "Pattern synonym definition cannot contain as-patterns (@)."
+  return [DPatSynD n args dir' pat']
+dsDec (PatSynSigD n ty) = (:[]) <$> (DPatSynSigD n <$> dsType ty)
+dsDec (StandaloneDerivD mds cxt ty) =
+  (:[]) <$> (DStandaloneDerivD <$> mapM dsDerivStrategy mds
+                               <*> pure Nothing <*> dsCxt cxt <*> dsType ty)
+#else
+dsDec (StandaloneDerivD cxt ty) =
+  (:[]) <$> (DStandaloneDerivD Nothing Nothing <$> dsCxt cxt <*> dsType ty)
+#endif
+dsDec (DefaultSigD n ty) = (:[]) <$> (DDefaultSigD n <$> dsType ty)
+#if __GLASGOW_HASKELL__ >= 807
+dsDec (ImplicitParamBindD {}) = impossible "Non-`let`-bound implicit param binding"
+#endif
+#if __GLASGOW_HASKELL__ >= 809
+dsDec (KiSigD n ki) = (:[]) <$> (DKiSigD n <$> dsType ki)
+#endif
+#if __GLASGOW_HASKELL__ >= 903
+dsDec (DefaultD tys) = (:[]) <$> (DDefaultD <$> mapM dsType tys)
+#endif
+#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 -> [TyVarBndrUnit]
+          -> Maybe Kind -> [Con] -> [DerivingClause] -> q [DDec]
+dsDataDec nd cxt n tvbs mk cons derivings = do
+  tvbs' <- mapM dsTvbUnit tvbs
+  let h98_tvbs = case mk of
+                   -- If there's an explicit return kind, we're dealing with a
+                   -- GADT, so this argument goes unused in dsCon.
+                   Just {} -> unusedArgument
+                   Nothing -> tvbs'
+      h98_return_type = nonFamilyDataReturnType n tvbs'
+  (:[]) <$> (DDataD nd <$> dsCxt cxt <*> pure n
+                       <*> pure tvbs' <*> mapM dsType mk
+                       <*> concatMapM (dsCon h98_tvbs h98_return_type) cons
+                       <*> mapM dsDerivClause derivings)
+
+-- | Desugar a 'DataInstD' or a 'NewtypeInstD'.
+dsDataInstDec :: DsMonad q
+              => 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 =
+        case (mk, mtvbs') of
+          -- If there's an explicit return kind, we're dealing with a
+          -- GADT, so this argument goes unused in dsCon.
+          (Just {}, _)          -> unusedArgument
+          -- H98, and there is an explicit `forall` in front. Just reuse the
+          -- type variable binders from the `forall`.
+          (Nothing, Just tvbs') -> tvbs'
+          -- H98, and no explicit `forall`. Compute the bound variables
+          -- manually.
+          (Nothing, Nothing)    -> dataFamInstTvbs tys'
+      h98_fam_inst_type = dataFamInstReturnType n tys'
+  (:[]) <$> (DDataInstD nd <$> dsCxt cxt <*> pure mtvbs'
+                           <*> pure lhs' <*> mapM dsType mk
+                           <*> concatMapM (dsCon h98_tvbs h98_fam_inst_type) cons
+                           <*> mapM dsDerivClause derivings)
+
+-- | Desugar a @FamilyResultSig@
+dsFamilyResultSig :: DsMonad q => FamilyResultSig -> q DFamilyResultSig
+dsFamilyResultSig NoSig          = return DNoSig
+dsFamilyResultSig (KindSig k)    = DKindSig <$> dsType k
+dsFamilyResultSig (TyVarSig tvb) = DTyVarSig <$> dsTvbUnit tvb
+
+-- | Desugar a @TypeFamilyHead@
+dsTypeFamilyHead :: DsMonad q => TypeFamilyHead -> q DTypeFamilyHead
+dsTypeFamilyHead (TypeFamilyHead n tvbs result inj)
+  = DTypeFamilyHead n <$> mapM dsTvbUnit tvbs
+                      <*> dsFamilyResultSig result
+                      <*> pure inj
+
+typeFamilyHeadName :: TypeFamilyHead -> Name
+typeFamilyHeadName (TypeFamilyHead n _ _ _) = n
+
+-- | Desugar @Dec@s that can appear in a @let@ expression. See the
+-- documentation for 'dsLetDec' for an explanation of what the return type
+-- represents.
+dsLetDecs :: DsMonad q => [Dec] -> q ([DLetDec], DExp -> DExp)
+dsLetDecs decs = do
+  (let_decss, ip_binders) <- mapAndUnzipM dsLetDec decs
+  let let_decs :: [DLetDec]
+      let_decs = concat let_decss
+
+      ip_binder :: DExp -> DExp
+      ip_binder = foldr (.) id ip_binders
+  return (let_decs, ip_binder)
+
+-- | Desugar a single 'Dec' that can appear in a @let@ expression.
+-- This produces the following output:
+--
+-- * One or more 'DLetDec's (a single 'Dec' can produce multiple 'DLetDec's
+--   in the event of a value declaration that binds multiple things by way
+--   of pattern matching.
+--
+-- * A function of type @'DExp' -> 'DExp'@, which should be applied to the
+--   expression immediately following the 'DLetDec's. This function prepends
+--   binding forms for any implicit params that were bound in the argument
+--   'Dec'. (If no implicit params are bound, this is simply the 'id'
+--   function.)
+--
+-- For instance, if the argument to 'dsLetDec' is the @?x = 42@ part of this
+-- expression:
+--
+-- @
+-- let { ?x = 42 } in ?x
+-- @
+--
+-- Then the output is:
+--
+-- * @let new_x_val = 42@
+--
+-- * @\\z -> 'bindIP' \@\"x\" new_x_val z@
+--
+-- This way, the expression
+-- @let { new_x_val = 42 } in 'bindIP' \@"x" new_x_val ('ip' \@\"x\")@ can be
+-- formed. The implicit param binders always come after all the other
+-- 'DLetDec's to support parallel assignment of implicit params.
+dsLetDec :: DsMonad q => Dec -> q ([DLetDec], DExp -> DExp)
+dsLetDec (FunD name clauses) = do
+  clauses' <- dsClauses (FunRhs name) clauses
+  return ([DFunD name clauses'], id)
+dsLetDec (ValD pat body where_decs) = do
+  (pat', vars) <- dsPatX pat
+  body' <- dsBody body where_decs error_exp
+  let extras = uncurry (zipWith (DValD . DVarP)) $ unzip vars
+  return (DValD pat' body' : extras, id)
+  where
+    error_exp = mkErrorMatchExpr (LetDecRhs pat)
+dsLetDec (SigD name ty) = do
+  ty' <- dsType ty
+  return ([DSigD name ty'], id)
+dsLetDec (InfixD fixity name) = return ([DInfixD fixity name], id)
+dsLetDec (PragmaD prag) = do
+  prag' <- dsPragma prag
+  return ([DPragmaD prag'], id)
+#if __GLASGOW_HASKELL__ >= 807
+dsLetDec (ImplicitParamBindD n e) = do
+  new_n_name <- qNewName $ "new_" ++ n ++ "_val"
+  e' <- dsExp e
+  let let_dec :: DLetDec
+      let_dec = DValD (DVarP new_n_name) e'
+
+      ip_binder :: DExp -> DExp
+      ip_binder = (DVarE 'bindIP        `DAppTypeE`
+                     DLitT (StrTyLit n) `DAppE`
+                     DVarE new_n_name   `DAppE`)
+  return ([let_dec], ip_binder)
+#endif
+dsLetDec _dec = impossible "Illegal declaration in let expression."
+
+-- | Desugar a single 'Dec' corresponding to something that could appear after
+-- the @let@ in a @let@ expression, but occurring at the top level. Because the
+-- 'Dec' occurs at the top level, there is nothing that would correspond to the
+-- @in ...@ part of the @let@ expression. As a consequence, this function does
+-- not return a @'DExp' -> 'DExp'@ function corresonding to implicit param
+-- binders (these cannot occur at the top level).
+dsTopLevelLetDec :: DsMonad q => Dec -> q [DDec]
+dsTopLevelLetDec = fmap (map DLetDec . fst) . dsLetDec
+  -- Note the use of fst above: we're silently throwing away any implicit param
+  -- binders that dsLetDec returns, since there is invariant that there will be
+  -- no implicit params in the first place.
+
+-- | Desugar a single @Con@.
+--
+-- Because we always desugar @Con@s to GADT syntax (see the documentation for
+-- 'DCon'), it is not always possible to desugar with just a 'Con' alone.
+-- For instance, we must desugar:
+--
+-- @
+-- data Foo a = forall b. MkFoo b
+-- @
+--
+-- To this:
+--
+-- @
+-- data Foo a :: Type where
+--   MkFoo :: forall a b. b -> Foo a
+-- @
+--
+-- If our only argument was @forall b. MkFoo b@, it would be somewhat awkward
+-- to figure out (1) what the set of universally quantified type variables
+-- (@[a]@) was, and (2) what the return type (@Foo a@) was. For this reason,
+-- we require passing these as arguments. (If we desugar an actual GADT
+-- constructor, these arguments are ignored.)
+dsCon :: DsMonad q
+      => [DTyVarBndrUnit] -- ^ The universally quantified type variables
+                          --   (used if desugaring a non-GADT constructor).
+      -> DType            -- ^ The original data declaration's type
+                          --   (used if desugaring a non-GADT constructor).
+      -> Con -> q [DCon]
+dsCon univ_dtvbs data_type con = do
+  dcons' <- dsCon' con
+  return $ flip map dcons' $ \(n, dtvbs, dcxt, fields, m_gadt_type) ->
+    case m_gadt_type of
+      Nothing ->
+        let ex_dtvbs   = dtvbs
+            expl_dtvbs = changeDTVFlags SpecifiedSpec univ_dtvbs ++
+                         ex_dtvbs
+            impl_dtvbs = changeDTVFlags SpecifiedSpec $
+                         toposortTyVarsOf $ mapMaybe extractTvbKind expl_dtvbs in
+        DCon (impl_dtvbs ++ expl_dtvbs) dcxt n fields data_type
+      Just gadt_type ->
+        let univ_ex_dtvbs = dtvbs in
+        DCon univ_ex_dtvbs dcxt n fields gadt_type
+
+-- Desugar a Con in isolation. The meaning of the returned DTyVarBndrs changes
+-- depending on what the returned Maybe DType value is:
+--
+-- * If returning Just gadt_ty, then we've encountered a GadtC or RecGadtC,
+--   so the returned DTyVarBndrs are both the universally and existentially
+--   quantified tyvars.
+-- * If returning Nothing, we're dealing with a non-GADT constructor, so
+--   the returned DTyVarBndrs are the existentials only.
+dsCon' :: DsMonad q
+       => Con -> q [(Name, [DTyVarBndrSpec], DCxt, DConFields, Maybe DType)]
+dsCon' (NormalC n stys) = do
+  dtys <- mapM dsBangType stys
+  return [(n, [], [], DNormalC False dtys, Nothing)]
+dsCon' (RecC n vstys) = do
+  vdtys <- mapM dsVarBangType vstys
+  return [(n, [], [], DRecC vdtys, Nothing)]
+dsCon' (InfixC sty1 n sty2) = do
+  dty1 <- dsBangType sty1
+  dty2 <- dsBangType sty2
+  return [(n, [], [], DNormalC True [dty1, dty2], Nothing)]
+dsCon' (ForallC tvbs cxt con) = do
+  dtvbs <- mapM dsTvbSpec tvbs
+  dcxt <- dsCxt cxt
+  dcons' <- dsCon' con
+  return $ flip map dcons' $ \(n, dtvbs', dcxt', fields, m_gadt_type) ->
+    (n, dtvbs ++ dtvbs', dcxt ++ dcxt', fields, m_gadt_type)
+dsCon' (GadtC nms btys rty) = do
+  dbtys <- mapM dsBangType btys
+  drty  <- dsType rty
+  sequence $ flip map nms $ \nm -> do
+    mbFi <- reifyFixityWithLocals nm
+    -- A GADT data constructor is declared infix when these three
+    -- properties hold:
+    let decInfix = isInfixDataCon (nameBase nm) -- 1. Its name uses operator syntax
+                                                --    (e.g., (:*:))
+                && length dbtys == 2            -- 2. It has exactly two fields
+                && isJust mbFi                  -- 3. It has a programmer-specified
+                                                --    fixity declaration
+    return (nm, [], [], DNormalC decInfix dbtys, Just drty)
+dsCon' (RecGadtC nms vbtys rty) = do
+  dvbtys <- mapM dsVarBangType vbtys
+  drty   <- dsType rty
+  return $ flip map nms $ \nm ->
+    (nm, [], [], DRecC dvbtys, Just drty)
+
+-- | Desugar a @BangType@.
+dsBangType :: DsMonad q => BangType -> q DBangType
+dsBangType (b, ty) = (b, ) <$> dsType ty
+
+-- | Desugar a @VarBangType@.
+dsVarBangType :: DsMonad q => VarBangType -> q DVarBangType
+dsVarBangType (n, b, ty) = (n, b, ) <$> dsType ty
+
+-- | Desugar a @Foreign@.
+dsForeign :: DsMonad q => Foreign -> q DForeign
+dsForeign (ImportF cc safety str n ty) = DImportF cc safety str n <$> dsType ty
+dsForeign (ExportF cc str n ty)        = DExportF cc str n <$> dsType ty
+
+-- | Desugar a @Pragma@.
+dsPragma :: DsMonad q => Pragma -> q DPragma
+dsPragma (InlineP n inl rm phases)       = return $ DInlineP n inl rm phases
+dsPragma (SpecialiseP n ty m_inl phases) = DSpecialiseP n <$> dsType ty
+                                                          <*> pure m_inl
+                                                          <*> pure phases
+dsPragma (SpecialiseInstP ty)            = DSpecialiseInstP <$> dsType ty
+#if __GLASGOW_HASKELL__ >= 807
+dsPragma (RuleP str mtvbs rbs lhs rhs phases)
+                                         = DRuleP str <$> mapM (mapM dsTvbUnit) mtvbs
+                                                      <*> mapM dsRuleBndr rbs
+                                                      <*> dsExp lhs
+                                                      <*> dsExp rhs
+                                                      <*> pure phases
+#else
+dsPragma (RuleP str rbs lhs rhs phases)  = DRuleP str Nothing
+                                                      <$> mapM dsRuleBndr rbs
+                                                      <*> dsExp lhs
+                                                      <*> dsExp rhs
+                                                      <*> pure phases
+#endif
+dsPragma (AnnP target exp)               = DAnnP target <$> dsExp exp
+dsPragma (LineP n str)                   = return $ DLineP n str
+#if __GLASGOW_HASKELL__ >= 801
+dsPragma (CompleteP cls mty)             = return $ DCompleteP cls mty
+#endif
+#if __GLASGOW_HASKELL__ >= 903
+dsPragma (OpaqueP n)                     = return $ DOpaqueP n
+#endif
+
+-- | Desugar a @RuleBndr@.
+dsRuleBndr :: DsMonad q => RuleBndr -> q DRuleBndr
+dsRuleBndr (RuleVar n)         = return $ DRuleVar n
+dsRuleBndr (TypedRuleVar n ty) = DTypedRuleVar n <$> dsType ty
+
+#if __GLASGOW_HASKELL__ >= 807
+-- | Desugar a @TySynEqn@. (Available only with GHC 7.8+)
+--
+-- This requires a 'Name' as an argument since 'TySynEqn's did not have
+-- this information prior to GHC 8.8.
+dsTySynEqn :: DsMonad q => Name -> TySynEqn -> q DTySynEqn
+dsTySynEqn _ (TySynEqn mtvbs lhs rhs) =
+  DTySynEqn <$> mapM (mapM dsTvbUnit) mtvbs <*> dsType lhs <*> dsType rhs
+#else
+-- | Desugar a @TySynEqn@. (Available only with GHC 7.8+)
+dsTySynEqn :: DsMonad q => Name -> TySynEqn -> q DTySynEqn
+dsTySynEqn n (TySynEqn lhss rhs) = do
+  lhss' <- mapM dsType lhss
+  let lhs' = applyDType (DConT n) $ map DTANormal lhss'
+  DTySynEqn Nothing lhs' <$> dsType rhs
+#endif
+
+-- | Desugar clauses to a function definition
+dsClauses :: DsMonad q
+          => MatchContext -- ^ The context in which the clauses arise
+          -> [Clause]     -- ^ Clauses to desugar
+          -> q [DClause]
+dsClauses _ [] = return []
+dsClauses mc (Clause pats (NormalB exp) where_decs : rest) = do
+  -- this case is necessary to maintain the roundtrip property.
+  rest' <- dsClauses mc rest
+  exp' <- dsExp exp
+  (where_decs', ip_binder) <- dsLetDecs where_decs
+  let exp_with_wheres = maybeDLetE where_decs' (ip_binder exp')
+  (pats', exp'') <- dsPatsOverExp pats exp_with_wheres
+  return $ DClause pats' exp'' : rest'
+dsClauses mc clauses@(Clause outer_pats _ _ : _) = do
+  arg_names <- replicateM (length outer_pats) (newUniqueName "arg")
+  let scrutinee = mkUnboxedTupleDExp (map DVarE arg_names)
+  clause <- DClause (map DVarP arg_names) <$>
+              (DCaseE scrutinee <$> foldrM (clause_to_dmatch scrutinee) [] clauses)
+  return [clause]
+  where
+    clause_to_dmatch :: DsMonad q => DExp -> Clause -> [DMatch] -> q [DMatch]
+    clause_to_dmatch scrutinee (Clause pats body where_decs) failure_matches = do
+      let failure_exp = maybeDCaseE mc scrutinee failure_matches
+      exp <- dsBody body where_decs failure_exp
+      (pats', exp') <- dsPatsOverExp pats exp
+      uni_pats <- fmap getAll $ concatMapM (fmap All . isUniversalPattern) pats'
+      let match = DMatch (mkUnboxedTupleDPat pats') exp'
+      if uni_pats
+      then return [match]
+      else return (match : failure_matches)
+
+-- | The context of a pattern match. This is used to produce
+-- @Non-exhaustive patterns in...@ messages that are tailored to specific
+-- situations. Compare this to GHC's @HsMatchContext@ data type
+-- (https://gitlab.haskell.org/ghc/ghc/-/blob/81cf52bb301592ff3d043d03eb9a0d547891a3e1/compiler/Language/Haskell/Syntax/Expr.hs#L1662-1695),
+-- from which the @MatchContext@ data type takes inspiration.
+data MatchContext
+  = FunRhs Name
+    -- ^ A pattern matching on an argument of a function binding
+  | LetDecRhs Pat
+    -- ^ A pattern in a @let@ declaration
+  | RecUpd
+    -- ^ A record update
+  | MultiWayIfAlt
+    -- ^ Guards in a multi-way if alternative
+  | CaseAlt
+    -- ^ Patterns and guards in a case alternative
+
+-- | Construct an expression that throws an error when encountering a pattern
+-- at runtime that is not covered by pattern matching.
+mkErrorMatchExpr :: MatchContext -> DExp
+mkErrorMatchExpr mc =
+  DAppE (DVarE 'error) (DLitE (StringL ("Non-exhaustive patterns in " ++ pp_context)))
+  where
+    pp_context =
+      case mc of
+        FunRhs n      -> show n
+        LetDecRhs pat -> pprint pat
+        RecUpd        -> "record update"
+        MultiWayIfAlt -> "multi-way if"
+        CaseAlt       -> "case"
+
+-- | Desugar a type
+dsType :: DsMonad q => Type -> q DType
+#if __GLASGOW_HASKELL__ >= 900
+-- See Note [Gracefully handling linear types]
+dsType (MulArrowT `AppT` _) = return DArrowT
+dsType MulArrowT = fail "Cannot desugar exotic uses of linear types."
+#endif
+dsType (ForallT tvbs preds ty) =
+  mkDForallConstrainedT <$> (DForallInvis <$> mapM dsTvbSpec tvbs)
+                        <*> dsCxt preds <*> dsType ty
+dsType (AppT t1 t2) = DAppT <$> dsType t1 <*> dsType t2
+dsType (SigT ty ki) = DSigT <$> dsType ty <*> dsType ki
+dsType (VarT name) = return $ DVarT name
+dsType (ConT name) = return $ DConT name
+-- The PromotedT case is identical to the ConT case above.
+-- See Note [Desugaring promoted types].
+dsType (PromotedT name) = return $ DConT name
+dsType (TupleT n) = return $ DConT (tupleTypeName n)
+dsType (UnboxedTupleT n) = return $ DConT (unboxedTupleTypeName n)
+dsType ArrowT = return DArrowT
+dsType ListT = return $ DConT ''[]
+dsType (PromotedTupleT n) = return $ DConT (tupleDataName n)
+dsType PromotedNilT = return $ DConT '[]
+dsType PromotedConsT = return $ DConT '(:)
+dsType StarT = return $ DConT typeKindName
+dsType ConstraintT = return $ DConT ''Constraint
+dsType (LitT lit) = return $ DLitT lit
+dsType EqualityT = return $ DConT ''(~)
+dsType (InfixT t1 n t2) = dsInfixT t1 n t2
+dsType (UInfixT{}) = dsUInfixT
+dsType (ParensT t) = dsType t
+dsType WildCardT = return DWildCardT
+#if __GLASGOW_HASKELL__ >= 801
+dsType (UnboxedSumT arity) = return $ DConT (unboxedSumTypeName arity)
+#endif
+#if __GLASGOW_HASKELL__ >= 807
+dsType (AppKindT t k) = DAppKindT <$> dsType t <*> dsType k
+dsType (ImplicitParamT n t) = do
+  t' <- dsType t
+  return $ DConT ''IP `DAppT` DLitT (StrTyLit n) `DAppT` t'
+#endif
+#if __GLASGOW_HASKELL__ >= 809
+dsType (ForallVisT tvbs ty) =
+  DForallT <$> (DForallVis <$> mapM dsTvbUnit tvbs) <*> dsType ty
+#endif
+#if __GLASGOW_HASKELL__ >= 903
+-- The PromotedInfixT case is identical to the InfixT case above.
+-- See Note [Desugaring promoted types].
+dsType (PromotedInfixT t1 n t2) = dsInfixT t1 n t2
+dsType PromotedUInfixT{} = dsUInfixT
+#endif
+
+#if __GLASGOW_HASKELL__ >= 900
+-- | Desugar a 'TyVarBndr'.
+dsTvb :: DsMonad q => TyVarBndr_ flag -> q (DTyVarBndr flag)
+dsTvb (PlainTV n flag)    = return $ DPlainTV n flag
+dsTvb (KindedTV n flag k) = DKindedTV n flag <$> dsType k
+#else
+-- | Desugar a 'TyVarBndr' with a particular @flag@.
+dsTvb :: DsMonad q => flag -> TyVarBndr -> q (DTyVarBndr flag)
+dsTvb flag (PlainTV n)    = return $ DPlainTV n flag
+dsTvb flag (KindedTV n k) = DKindedTV n flag <$> dsType k
+#endif
+
+{-
+Note [Gracefully handling linear types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Per the README, th-desugar does not currently support linear types.
+Unfortunately, we cannot simply reject all occurrences of
+multiplicity-polymorphic function arrows (i.e., MulArrowT), as it is possible
+for "non-linear" code to contain them when reified. For example, the type of a
+Haskell98 data constructor such as `Just` will be reified as
+
+  a #-> Maybe a
+
+In terms of the TH AST, that is:
+
+  MulArrowT `AppT` PromotedConT 'One `AppT` VarT a `AppT` (ConT ''Maybe `AppT` VarT a)
+
+Therefore, in order to desugar these sorts of types, we have to do *something*
+with MulArrowT. The approach that th-desugar takes is to pretend that all
+multiplicity-polymorphic function arrows are actually ordinary function arrows
+(->) when desugaring types. In other words, whenever th-desugar sees
+(MulArrowT `AppT` m), for any particular value of `m`, it will turn it into
+DArrowT.
+
+This approach is enough to gracefully handle most uses of MulArrowT, as TH
+reification always generates MulArrowT applied to some particular multiplicity
+(as of GHC 9.0, at least). It's conceivable that some wily user could manually
+construct a TH AST containing MulArrowT in a different position, but since this
+situation is rare, we simply throw an error in such cases.
+
+We adopt a similar stance in L.H.TH.Desugar.Reify when locally reifying the
+types of data constructors: since th-desugar doesn't currently support linear
+types, we pretend as if MulArrowT does not exist. As a result, the type of
+`Just` would be locally reified as `a -> Maybe a`, not `a #-> Maybe a`.
+
+Note [Desugaring promoted types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ConT and PromotedT both contain Names as a payload, the only difference being
+that PromotedT is intended to refer exclusively to promoted data constructor
+Names, while ConT can refer to both type and data constructor Names alike.
+
+When desugaring a PromotedT, we make the assumption that the TH quoting
+mechanism produced the correct Name and wrap the name in a DConT. In other
+words, we desugar ConT and PromotedT identically. This assumption about
+PromotedT may not always be correct, however. Consider this example:
+
+  data a :+: b = Inl a | Inr b
+  data Exp a = ... | Exp :+: Exp
+
+How should `PromotedT (mkName ":+:")` be desugared? Morally, it ought to be
+desugared to a DConT that contains (:+:) the data constructor, not (:+:) the
+type constructor. Deciding between the two is not always straightforward,
+however. We could use the `lookupDataName` function to try and distinguish
+between the two Names, but this may not necessarily work. This is because the
+Name passed to `lookupDataName` could have its original module attached, which
+may not be in scope.
+
+Long story short: we make things simple (albeit slightly wrong) by desugaring
+ConT and PromotedT identically. We'll wait for someone to complain about the
+wrongness of this approach before researching a more accurate solution.
+
+Note that the same considerations also apply to InfixT and PromotedInfixT,
+which are also desugared identically.
+-}
+
+-- | Desugar an infix 'Type'.
+dsInfixT :: DsMonad q => Type -> Name -> Type -> q DType
+dsInfixT t1 n t2 = DAppT <$> (DAppT (DConT n) <$> dsType t1) <*> dsType t2
+
+-- | We cannot desugar unresolved infix operators, so fail if we encounter one.
+dsUInfixT :: Fail.MonadFail m => m a
+dsUInfixT = fail "Cannot desugar unresolved infix operators."
+
+-- | Desugar a 'TyVarBndrSpec'.
+dsTvbSpec :: DsMonad q => TyVarBndrSpec -> q DTyVarBndrSpec
+#if __GLASGOW_HASKELL__ >= 900
+dsTvbSpec = dsTvb
+#else
+dsTvbSpec = dsTvb SpecifiedSpec
+#endif
+
+-- | Desugar a 'TyVarBndrUnit'.
+dsTvbUnit :: DsMonad q => TyVarBndrUnit -> q DTyVarBndrUnit
+#if __GLASGOW_HASKELL__ >= 900
+dsTvbUnit = dsTvb
+#else
+dsTvbUnit = dsTvb ()
+#endif
+
+-- | Desugar a @Cxt@
+dsCxt :: DsMonad q => Cxt -> q DCxt
+dsCxt = concatMapM dsPred
+
+#if __GLASGOW_HASKELL__ >= 801
+-- | A backwards-compatible type synonym for the thing representing a single
+-- derived class in a @deriving@ clause. (This is a @DerivClause@, @Pred@, or
+-- @Name@ depending on the GHC version.)
+type DerivingClause = DerivClause
+
+-- | Desugar a @DerivingClause@.
+dsDerivClause :: DsMonad q => DerivingClause -> q DDerivClause
+dsDerivClause (DerivClause mds cxt) =
+  DDerivClause <$> mapM dsDerivStrategy mds <*> dsCxt cxt
+#else
+type DerivingClause = Pred
+
+dsDerivClause :: DsMonad q => DerivingClause -> q DDerivClause
+dsDerivClause p = DDerivClause Nothing <$> dsPred p
+#endif
+
+#if __GLASGOW_HASKELL__ >= 801
+-- | Desugar a @DerivStrategy@.
+dsDerivStrategy :: DsMonad q => DerivStrategy -> q DDerivStrategy
+dsDerivStrategy StockStrategy    = pure DStockStrategy
+dsDerivStrategy AnyclassStrategy = pure DAnyclassStrategy
+dsDerivStrategy NewtypeStrategy  = pure DNewtypeStrategy
+#if __GLASGOW_HASKELL__ >= 805
+dsDerivStrategy (ViaStrategy ty) = DViaStrategy <$> dsType ty
+#endif
+#endif
+
+#if __GLASGOW_HASKELL__ >= 801
+-- | Desugar a @PatSynDir@. (Available only with GHC 8.2+)
+dsPatSynDir :: DsMonad q => Name -> PatSynDir -> q DPatSynDir
+dsPatSynDir _ Unidir              = pure DUnidir
+dsPatSynDir _ ImplBidir           = pure DImplBidir
+dsPatSynDir n (ExplBidir clauses) = DExplBidir <$> dsClauses (FunRhs n) clauses
+#endif
+
+-- | Desugar a @Pred@, flattening any internal tuples
+dsPred :: DsMonad q => Pred -> q DCxt
+dsPred t
+  | Just ts <- splitTuple_maybe t
+  = concatMapM dsPred ts
+dsPred (ForallT tvbs cxt p) = dsForallPred tvbs cxt p
+dsPred (AppT t1 t2) = do
+  [p1] <- dsPred t1   -- tuples can't be applied!
+  (:[]) <$> DAppT p1 <$> dsType t2
+dsPred (SigT ty ki) = do
+  preds <- dsPred ty
+  case preds of
+    [p]   -> (:[]) <$> DSigT p <$> dsType ki
+    other -> return other   -- just drop the kind signature on a tuple.
+dsPred (VarT n) = return [DVarT n]
+dsPred (ConT n) = return [DConT n]
+dsPred t@(PromotedT _) =
+  impossible $ "Promoted type seen as head of constraint: " ++ show t
+dsPred (TupleT 0) = return [DConT (tupleTypeName 0)]
+dsPred (TupleT _) =
+  impossible "Internal error in th-desugar in detecting tuple constraints."
+dsPred t@(UnboxedTupleT _) =
+  impossible $ "Unboxed tuple seen as head of constraint: " ++ show t
+dsPred ArrowT = impossible "Arrow seen as head of constraint."
+dsPred ListT  = impossible "List seen as head of constraint."
+dsPred (PromotedTupleT _) =
+  impossible "Promoted tuple seen as head of constraint."
+dsPred PromotedNilT  = impossible "Promoted nil seen as head of constraint."
+dsPred PromotedConsT = impossible "Promoted cons seen as head of constraint."
+dsPred StarT         = impossible "* seen as head of constraint."
+dsPred ConstraintT =
+  impossible "The kind `Constraint' seen as head of constraint."
+dsPred t@(LitT _) =
+  impossible $ "Type literal seen as head of constraint: " ++ show t
+dsPred EqualityT = return [DConT ''(~)]
+dsPred (InfixT t1 n t2) = (:[]) <$> dsInfixT t1 n t2
+dsPred (UInfixT{}) = dsUInfixT
+dsPred (ParensT t) = dsPred t
+dsPred WildCardT = return [DWildCardT]
+#if __GLASGOW_HASKELL__ >= 801
+dsPred t@(UnboxedSumT {}) =
+  impossible $ "Unboxed sum seen as head of constraint: " ++ show t
+#endif
+#if __GLASGOW_HASKELL__ >= 807
+dsPred (AppKindT t k) = do
+  [p] <- dsPred t
+  (:[]) <$> (DAppKindT p <$> dsType k)
+dsPred (ImplicitParamT n t) = do
+  t' <- dsType t
+  return [DConT ''IP `DAppT` DLitT (StrTyLit n) `DAppT` t']
+#endif
+#if __GLASGOW_HASKELL__ >= 809
+dsPred t@(ForallVisT {}) =
+  impossible $ "Visible dependent quantifier seen as head of constraint: " ++ show t
+#endif
+#if __GLASGOW_HASKELL__ >= 900
+dsPred MulArrowT = impossible "Linear arrow seen as head of constraint."
+#endif
+#if __GLASGOW_HASKELL__ >= 903
+dsPred t@PromotedInfixT{} =
+  impossible $ "Promoted infix type seen as head of constraint: " ++ show t
+dsPred PromotedUInfixT{} = dsUInfixT
+#endif
+
+-- | Desugar a quantified constraint.
+dsForallPred :: DsMonad q => [TyVarBndrSpec] -> Cxt -> Pred -> q DCxt
+dsForallPred tvbs cxt p = do
+  ps' <- dsPred p
+  case ps' of
+    [p'] -> (:[]) <$> (mkDForallConstrainedT <$>
+                         (DForallInvis <$> mapM dsTvbSpec tvbs) <*> dsCxt cxt <*> pure p')
+    _    -> fail "Cannot desugar constraint tuples in the body of a quantified constraint"
+              -- See GHC #15334.
+
+-- | Like 'reify', but safer and desugared. Uses local declarations where
+-- available.
+dsReify :: DsMonad q => Name -> q (Maybe DInfo)
+dsReify = traverse dsInfo <=< reifyWithLocals_maybe
+
+-- | Like 'reifyType', but safer and desugared. Uses local declarations where
+-- available.
+dsReifyType :: DsMonad q => Name -> q (Maybe DType)
+dsReifyType = traverse dsType <=< reifyTypeWithLocals_maybe
+
+-- Given a list of `forall`ed type variable binders and a context, construct
+-- a DType using DForallT and DConstrainedT as appropriate. The phrase
+-- "as appropriate" is used because DConstrainedT will not be used if the
+-- context is empty, per Note [Desugaring and sweetening ForallT].
+mkDForallConstrainedT :: DForallTelescope -> DCxt -> DType -> DType
+mkDForallConstrainedT tele ctxt ty =
+  DForallT tele $ if null ctxt then ty else DConstrainedT ctxt ty
+
+-- create a list of expressions in the same order as the fields in the first argument
+-- but with the values as given in the second argument
+-- if a field is missing from the second argument, use the corresponding expression
+-- from the third argument
+reorderFields :: DsMonad q => Name -> [VarStrictType] -> [FieldExp] -> [DExp] -> q [DExp]
+reorderFields = reorderFields' dsExp
+
+reorderFieldsPat :: DsMonad q => Name -> [VarStrictType] -> [FieldPat] -> PatM q [DPat]
+reorderFieldsPat con_name field_decs field_pats =
+  reorderFields' dsPat con_name field_decs field_pats (repeat DWildP)
+
+reorderFields' :: (Applicative m, Fail.MonadFail m)
+               => (a -> m da)
+               -> Name -- ^ The name of the constructor (used for error reporting)
+               -> [VarStrictType] -> [(Name, a)]
+               -> [da] -> m [da]
+reorderFields' ds_thing con_name field_names_types field_things deflts =
+  check_valid_fields >> reorder field_names deflts
+  where
+    field_names = map (\(a, _, _) -> a) field_names_types
+
+    check_valid_fields =
+      forM_ field_things $ \(thing_name, _) ->
+        unless (thing_name `elem` field_names) $
+          fail $ "Constructor ‘" ++ nameBase con_name   ++ "‘ does not have field ‘"
+                                 ++ nameBase thing_name ++ "‘"
+
+    reorder [] _ = return []
+    reorder (field_name : rest) (deflt : rest_deflt) = do
+      rest' <- reorder rest rest_deflt
+      case find (\(thing_name, _) -> thing_name == field_name) field_things of
+        Just (_, thing) -> (: rest') <$> ds_thing thing
+        Nothing -> return $ deflt : rest'
+    reorder (_ : _) [] = error "Internal error in th-desugar."
+
+-- mkTupleDExp, mkUnboxedTupleDExp, and friends construct tuples, avoiding the
+-- use of 1-tuples. These are used to create auxiliary tuple values when
+-- desugaring pattern-matching constructs to simpler forms.
+-- See Note [Auxiliary tuples in pattern matching].
+
+-- | Make a tuple 'DExp' from a list of 'DExp's. Avoids using a 1-tuple.
+mkTupleDExp :: [DExp] -> DExp
+mkTupleDExp [exp] = exp
+mkTupleDExp exps = foldl DAppE (DConE $ tupleDataName (length exps)) exps
+
+-- | Make an unboxed tuple 'DExp' from a list of 'DExp's. Avoids using a 1-tuple.
+mkUnboxedTupleDExp :: [DExp] -> DExp
+mkUnboxedTupleDExp [exp] = exp
+mkUnboxedTupleDExp exps = foldl DAppE (DConE $ unboxedTupleDataName (length exps)) exps
+
+-- | Make a tuple 'Exp' from a list of 'Exp's. Avoids using a 1-tuple.
+mkTupleExp :: [Exp] -> Exp
+mkTupleExp [exp] = exp
+mkTupleExp exps = foldl AppE (ConE $ tupleDataName (length exps)) exps
+
+-- | Make an unboxed tuple 'Exp' from a list of 'Exp's. Avoids using a 1-tuple.
+mkUnboxedTupleExp :: [Exp] -> Exp
+mkUnboxedTupleExp [exp] = exp
+mkUnboxedTupleExp exps = foldl AppE (ConE $ unboxedTupleDataName (length exps)) exps
+
+-- | Make a tuple 'DPat' from a list of 'DPat's. Avoids using a 1-tuple.
+mkTupleDPat :: [DPat] -> DPat
+mkTupleDPat [pat] = pat
+mkTupleDPat pats = DConP (tupleDataName (length pats)) [] pats
+
+-- | Make an unboxed tuple 'DPat' from a list of 'DPat's. Avoids using a 1-tuple.
+mkUnboxedTupleDPat :: [DPat] -> DPat
+mkUnboxedTupleDPat [pat] = pat
+mkUnboxedTupleDPat pats = DConP (unboxedTupleDataName (length pats)) [] pats
+
+-- | Is this pattern guaranteed to match?
+isUniversalPattern :: DsMonad q => DPat -> q Bool
+isUniversalPattern (DLitP {}) = return False
+isUniversalPattern (DVarP {}) = return True
+isUniversalPattern (DConP con_name _ pats) = do
+  data_name <- dataConNameToDataName con_name
+  (_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
+
+-- | Apply one 'DExp' to a list of arguments
+applyDExp :: DExp -> [DExp] -> DExp
+applyDExp = foldl DAppE
+
+-- | Apply one 'DType' to a list of arguments
+applyDType :: DType -> [DTypeArg] -> DType
+applyDType = foldl apply
+  where
+    apply :: DType -> DTypeArg -> DType
+    apply f (DTANormal x) = f `DAppT` x
+    apply f (DTyArg x)    = f `DAppKindT` x
+
+-- | An argument to a type, either a normal type ('DTANormal') or a visible
+-- kind application ('DTyArg').
+--
+-- 'DTypeArg' does not appear directly in the @th-desugar@ AST, but it is
+-- useful when decomposing an application of a 'DType' to its arguments.
+data DTypeArg
+  = DTANormal DType
+  | DTyArg DKind
+  deriving (Eq, Show, Data, Generic)
+
+-- | Desugar a 'TypeArg'.
+dsTypeArg :: DsMonad q => TypeArg -> q DTypeArg
+dsTypeArg (TANormal t) = DTANormal <$> dsType t
+dsTypeArg (TyArg k)    = DTyArg    <$> dsType k
+
+-- | Filter the normal type arguments from a list of 'DTypeArg's.
+filterDTANormals :: [DTypeArg] -> [DType]
+filterDTANormals = mapMaybe getDTANormal
+  where
+    getDTANormal :: DTypeArg -> Maybe DType
+    getDTANormal (DTANormal t) = Just t
+    getDTANormal (DTyArg {})   = Nothing
+
+-- | Convert a 'DTyVarBndr' into a 'DType'
+dTyVarBndrToDType :: DTyVarBndr flag -> DType
+dTyVarBndrToDType (DPlainTV a _)    = DVarT a
+dTyVarBndrToDType (DKindedTV a _ k) = DVarT a `DSigT` k
+
+-- | Extract the underlying 'DType' or 'DKind' from a 'DTypeArg'. This forgets
+-- information about whether a type is a normal argument or not, so use with
+-- caution.
+probablyWrongUnDTypeArg :: DTypeArg -> DType
+probablyWrongUnDTypeArg (DTANormal t) = t
+probablyWrongUnDTypeArg (DTyArg k)    = k
+
+-- Take a data type name (which does not belong to a data family) and
+-- apply it to its type variable binders to form a DType.
+nonFamilyDataReturnType :: Name -> [DTyVarBndrUnit] -> DType
+nonFamilyDataReturnType con_name =
+  applyDType (DConT con_name) . map (DTANormal . dTyVarBndrToDType)
+
+-- Take a data family name and apply it to its argument types to form a
+-- data family instance DType.
+dataFamInstReturnType :: Name -> [DTypeArg] -> DType
+dataFamInstReturnType fam_name = applyDType (DConT fam_name)
+
+-- Data family instance declarations did not come equipped with a list of bound
+-- type variables until GHC 8.8 (and even then, it's optional whether the user
+-- provides them or not). This means that there are situations where we must
+-- reverse engineer this information ourselves from the list of type
+-- arguments. We accomplish this by taking the free variables of the types
+-- and performing a reverse topological sort on them to ensure that the
+-- returned list is well scoped.
+dataFamInstTvbs :: [DTypeArg] -> [DTyVarBndrUnit]
+dataFamInstTvbs = toposortTyVarsOf . map probablyWrongUnDTypeArg
+
+-- | Take a list of 'DType's, find their free variables, and sort them in
+-- reverse topological order to ensure that they are well scoped. In other
+-- words, the free variables are ordered such that:
+--
+-- 1. Whenever an explicit kind signature of the form @(A :: K)@ is
+--    encountered, the free variables of @K@ will always appear to the left of
+--    the free variables of @A@ in the returned result.
+--
+-- 2. The constraint in (1) notwithstanding, free variables will appear in
+--    left-to-right order of their original appearance.
+--
+-- On older GHCs, this takes measures to avoid returning explicitly bound
+-- kind variables, which was not possible before @TypeInType@.
+toposortTyVarsOf :: [DType] -> [DTyVarBndrUnit]
+toposortTyVarsOf tys =
+  let freeVars :: [Name]
+      freeVars = F.toList $ foldMap fvDType tys
+
+      varKindSigs :: Map Name DKind
+      varKindSigs = foldMap go_ty tys
+        where
+          go_ty :: DType -> Map Name DKind
+          go_ty (DForallT tele t) = go_tele tele (go_ty t)
+          go_ty (DConstrainedT ctxt t) = foldMap go_ty ctxt `mappend` go_ty t
+          go_ty (DAppT t1 t2) = go_ty t1 `mappend` go_ty t2
+          go_ty (DAppKindT t k) = go_ty t `mappend` go_ty k
+          go_ty (DSigT t k) =
+            let kSigs = go_ty k
+            in case t of
+                 DVarT n -> M.insert n k kSigs
+                 _       -> go_ty t `mappend` kSigs
+          go_ty (DVarT {}) = mempty
+          go_ty (DConT {}) = mempty
+          go_ty DArrowT    = mempty
+          go_ty (DLitT {}) = mempty
+          go_ty DWildCardT = mempty
+
+          go_tele :: DForallTelescope -> Map Name DKind -> Map Name DKind
+          go_tele (DForallVis   tvbs) = go_tvbs tvbs
+          go_tele (DForallInvis tvbs) = go_tvbs tvbs
+
+          go_tvbs :: [DTyVarBndr flag] -> Map Name DKind -> Map Name DKind
+          go_tvbs tvbs m = foldr go_tvb m tvbs
+
+          go_tvb :: DTyVarBndr flag -> Map Name DKind -> Map Name DKind
+          go_tvb (DPlainTV n _)    m = M.delete n m
+          go_tvb (DKindedTV n _ k) m = M.delete n m `mappend` go_ty k
+
+      -- | Do a topological sort on a list of tyvars,
+      --   so that binders occur before occurrences
+      -- E.g. given  [ a::k, k::*, b::k ]
+      -- it'll return a well-scoped list [ k::*, a::k, b::k ]
+      --
+      -- This is a deterministic sorting operation
+      -- (that is, doesn't depend on Uniques).
+      --
+      -- It is also meant to be stable: that is, variables should not
+      -- be reordered unnecessarily.
+      scopedSort :: [Name] -> [Name]
+      scopedSort = go [] []
+
+      go :: [Name]     -- already sorted, in reverse order
+         -> [Set Name] -- each set contains all the variables which must be placed
+                       -- before the tv corresponding to the set; they are accumulations
+                       -- of the fvs in the sorted tvs' kinds
+
+                       -- This list is in 1-to-1 correspondence with the sorted tyvars
+                       -- INVARIANT:
+                       --   all (\tl -> all (`isSubsetOf` head tl) (tail tl)) (tails fv_list)
+                       -- That is, each set in the list is a superset of all later sets.
+         -> [Name]     -- yet to be sorted
+         -> [Name]
+      go acc _fv_list [] = reverse acc
+      go acc  fv_list (tv:tvs)
+        = go acc' fv_list' tvs
+        where
+          (acc', fv_list') = insert tv acc fv_list
+
+      insert :: Name       -- var to insert
+             -> [Name]     -- sorted list, in reverse order
+             -> [Set Name] -- list of fvs, as above
+             -> ([Name], [Set Name])   -- augmented lists
+      insert tv []     []         = ([tv], [kindFVSet tv])
+      insert tv (a:as) (fvs:fvss)
+        | tv `S.member` fvs
+        , (as', fvss') <- insert tv as fvss
+        = (a:as', fvs `S.union` fv_tv : fvss')
+
+        | otherwise
+        = (tv:a:as, fvs `S.union` fv_tv : fvs : fvss)
+        where
+          fv_tv = kindFVSet tv
+
+         -- lists not in correspondence
+      insert _ _ _ = error "scopedSort"
+
+      kindFVSet n =
+        maybe S.empty (OS.toSet . fvDType)
+                      (M.lookup n varKindSigs)
+      ascribeWithKind n =
+        maybe (DPlainTV n ()) (DKindedTV n ()) (M.lookup n varKindSigs)
+
+  in map ascribeWithKind $
+     scopedSort freeVars
+
+dtvbName :: DTyVarBndr flag -> Name
+dtvbName (DPlainTV n _)    = n
+dtvbName (DKindedTV n _ _) = n
+
+-- @mk_qual_do_name mb_mod orig_name@ will simply return @orig_name@ if
+-- @mb_mod@ is Nothing. If @mb_mod@ is @Just mod_@, then a new 'Name' will be
+-- returned that uses @mod_@ as the new module prefix. This is useful for
+-- emulating the behavior of the @QualifiedDo@ extension, which adds module
+-- prefixes to functions such as ('>>=') and ('>>').
+mk_qual_do_name :: Maybe ModName -> Name -> Name
+mk_qual_do_name mb_mod orig_name = case mb_mod of
+  Nothing   -> orig_name
+  Just mod_ -> Name (OccName (nameBase orig_name)) (NameQ mod_)
+
+-- | Reconstruct an arrow 'DType' from its argument and result types.
+ravelDType :: DFunArgs -> DType -> DType
+ravelDType DFANil                 res = res
+ravelDType (DFAForalls tele args) res = DForallT tele (ravelDType args res)
+ravelDType (DFACxt cxt args)      res = DConstrainedT cxt (ravelDType args res)
+ravelDType (DFAAnon t args)       res = DAppT (DAppT DArrowT t) (ravelDType args res)
+
+-- | Decompose a function 'DType' into its arguments (the 'DFunArgs') and its
+-- result type (the 'DType).
+unravelDType :: DType -> (DFunArgs, DType)
+unravelDType (DForallT tele ty) =
+  let (args, res) = unravelDType ty in
+  (DFAForalls tele args, res)
+unravelDType (DConstrainedT cxt ty) =
+  let (args, res) = unravelDType ty in
+  (DFACxt cxt args, res)
+unravelDType (DAppT (DAppT DArrowT t1) t2) =
+  let (args, res) = unravelDType t2 in
+  (DFAAnon t1 args, res)
+unravelDType t = (DFANil, t)
+
+-- | The list of arguments in a function 'DType'.
+data DFunArgs
+  = DFANil
+    -- ^ No more arguments.
+  | DFAForalls DForallTelescope DFunArgs
+    -- ^ A series of @forall@ed type variables followed by a dot (if
+    --   'ForallInvis') or an arrow (if 'ForallVis'). For example,
+    --   the type variables @a1 ... an@ in @forall a1 ... an. r@.
+  | DFACxt DCxt DFunArgs
+    -- ^ A series of constraint arguments followed by @=>@. For example,
+    --   the @(c1, ..., cn)@ in @(c1, ..., cn) => r@.
+  | DFAAnon DType DFunArgs
+    -- ^ An anonymous argument followed by an arrow. For example, the @a@
+    --   in @a -> r@.
+  deriving (Eq, Show, Data, Generic)
+
+-- | A /visible/ function argument type (i.e., one that must be supplied
+-- explicitly in the source code). This is in contrast to /invisible/
+-- arguments (e.g., the @c@ in @c => r@), which are instantiated without
+-- the need for explicit user input.
+data DVisFunArg
+  = DVisFADep DTyVarBndrUnit
+    -- ^ A visible @forall@ (e.g., @forall a -> a@).
+  | DVisFAAnon DType
+    -- ^ An anonymous argument followed by an arrow (e.g., @a -> r@).
+  deriving (Eq, Show, Data, Generic)
+
+-- | Filter the visible function arguments from a list of 'DFunArgs'.
+filterDVisFunArgs :: DFunArgs -> [DVisFunArg]
+filterDVisFunArgs DFANil = []
+filterDVisFunArgs (DFAForalls tele args) =
+  case tele of
+    DForallVis tvbs -> map DVisFADep tvbs ++ args'
+    DForallInvis _  -> args'
+  where
+    args' = filterDVisFunArgs args
+filterDVisFunArgs (DFACxt _ args) =
+  filterDVisFunArgs args
+filterDVisFunArgs (DFAAnon t args) =
+  DVisFAAnon t:filterDVisFunArgs args
+
+-- | Decompose an applied type into its individual components. For example, this:
+--
+-- @
+-- Proxy \@Type Char
+-- @
+--
+-- would be unfolded to this:
+--
+-- @
+-- ('DConT' ''Proxy, ['DTyArg' ('DConT' ''Type), 'DTANormal' ('DConT' ''Char)])
+-- @
+unfoldDType :: DType -> (DType, [DTypeArg])
+unfoldDType = go []
+  where
+    go :: [DTypeArg] -> DType -> (DType, [DTypeArg])
+    go acc (DForallT _ ty)   = go acc ty
+    go acc (DAppT ty1 ty2)   = go (DTANormal ty2:acc) ty1
+    go acc (DAppKindT ty ki) = go (DTyArg ki:acc) ty
+    go acc (DSigT ty _)      = go acc ty
+    go acc ty                = (ty, acc)
+
+-- | Extract the kind from a 'DTyVarBndr', if one is present.
+extractTvbKind :: DTyVarBndr flag -> Maybe DKind
+extractTvbKind (DPlainTV _ _)    = Nothing
+extractTvbKind (DKindedTV _ _ k) = Just k
+
+-- | Set the flag in a list of 'DTyVarBndr's. This is often useful in contexts
+-- where one needs to re-use a list of 'DTyVarBndr's from one flag setting to
+-- another flag setting. For example, in order to re-use the 'DTyVarBndr's bound
+-- by a 'DDataD' in a 'DForallT', one can do the following:
+--
+-- @
+-- case x of
+--   'DDataD' _ _ _ tvbs _ _ _ ->
+--     'DForallT' ('DForallInvis' ('changeDTVFlags' 'SpecifiedSpec' tvbs)) ...
+-- @
+changeDTVFlags :: newFlag -> [DTyVarBndr oldFlag] -> [DTyVarBndr newFlag]
+changeDTVFlags new_flag = map (new_flag <$)
+
+-- | Some functions in this module only use certain arguments on particular
+-- versions of GHC. Other versions of GHC (that don't make use of those
+-- arguments) might need to conjure up those arguments out of thin air at the
+-- functions' call sites, so this function serves as a placeholder to use in
+-- those situations. (In other words, this is a slightly more informative
+-- version of 'undefined'.)
+unusedArgument :: a
+unusedArgument = error "Unused"
+
+{-
+Note [Desugaring and sweetening ForallT]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The ForallT constructor from template-haskell is tremendously awkward. Because
+ForallT contains both a list of type variable binders and constraint arguments,
+ForallT expressions can be ambiguous when one of these lists is empty. For
+example, consider this expression with no constraints:
+
+  ForallT [PlainTV a] [] (VarT a)
+
+What should this desugar to in th-desugar, which must maintain a clear
+separation between type variable binders and constraints? There are two
+possibilities:
+
+1. DForallT DForallInvis [DPlainTV a] (DVarT a)
+   (i.e., forall a. a)
+2. DForallT DForallInvis [DPlainTV a] (DConstrainedT [] (DVarT a))
+   (i.e., forall a. () => a)
+
+Template Haskell generally drops these empty lists when splicing Template
+Haskell expressions, so we would like to do the same in th-desugar to mimic
+TH's behavior as closely as possible. However, there are some situations where
+dropping empty lists of `forall`ed type variable binders can change the
+semantics of a program. For instance, contrast `foo :: forall. a -> a` (which
+is an error) with `foo :: a -> a` (which is fine). Therefore, we try to
+preserve empty `forall`s to the best of our ability.
+
+Here is an informal specification of how th-desugar should handle different sorts
+of ambiguity. First, a specification for desugaring.
+Let `tvbs` and `ctxt` be non-empty:
+
+* `ForallT tvbs [] ty` should desugar to `DForallT DForallInvis tvbs ty`.
+* `ForallT [] ctxt ty` should desguar to `DForallT DForallInvis [] (DConstrainedT ctxt ty)`.
+* `ForallT [] [] ty`   should desugar to `DForallT DForallInvis [] ty`.
+* For all other cases, just straightforwardly desugar
+  `ForallT tvbs ctxt ty` to `DForallT DForallInvis tvbs (DConstraintedT ctxt ty)`.
+
+For sweetening:
+
+* `DForallT DForallInvis tvbs (DConstrainedT ctxt ty)` should sweeten to `ForallT tvbs ctxt ty`.
+* `DForallT DForallInvis []   (DConstrainedT ctxt ty)` should sweeten to `ForallT [] ctxt ty`.
+* `DForallT DForallInvis tvbs (DConstrainedT [] ty)`   should sweeten to `ForallT tvbs [] ty`.
+* `DForallT DForallInvis []   (DConstrainedT [] ty)`   should sweeten to `ForallT [] [] ty`.
+* For all other cases, just straightforwardly sweeten
+  `DForallT DForallInvis tvbs ty` to `ForallT tvbs [] ty` and
+  `DConstrainedT ctxt ty` to `ForallT [] ctxt ty`.
+
+Note [Auxiliary tuples in pattern matching]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+th-desugar simplifies the overall treatment of pattern matching in two
+notable ways:
+
+1. Lambda expressions only bind variables and do not directly perform pattern
+   matching. For example, this:
+
+     \True False -> ()
+
+   Roughly desugars to:
+
+     \x y -> case (x, y) of
+               (True, False) -> ()
+               _             -> error "Non-exhaustive patterns"
+2. th-desugar does not have guards, as guards are desugared into pattern
+   matches. For example, this:
+
+     f x y | True <- x
+           , False <- y
+           = ()
+
+  Roughly desugars to:
+
+    f x y = case (x, y) of
+              (True, False) -> ()
+              _             -> error "Non-exhaustive patterns"
+
+In both of these examples, there are multiple expressions being matched on
+simultaneously. When desugaring these examples to `case` expressions, we need a
+construct that allows us to group these patterns together. Auxiliary tuples are
+one way to accomplish this.
+
+While this use of tuples works well when the arguments have lifted types, such
+as Bool, it doesn't work when the arguments have unlifted types, such as Int#.
+Imagine desugaring this lambda expression, for instance:
+
+  \27# 42# -> ()
+
+The approach above would desugar this to:
+
+  \x y -> case (x, y) of
+            (27#, 42#) -> ()
+            _          -> error "Non-exhaustive patterns"
+
+This will not typecheck, however, as we are using _lifted_ tuples, which
+require their arguments to have lifted types. If we want to support unlifted
+types, we need a different approach.
+
+One idea that seems tempting at first is to create an auxiliary `let`
+expression, e.g.,
+
+  \x y ->
+    let aux 27# 42# = ()
+     in aux x y
+
+This avoids having to use lifted tuples, but it creates a new problem: type
+inference. In the general case, auxiliary `let` expressions aren't enough to
+handle GADT pattern matches, such as in this example:
+
+  data T a where
+    MkT :: Int -> T Int
+
+  g :: T a -> T a -> a
+  g = \(MkT x1) (MkT x2) -> x1 + x2
+
+If you desugar `g` to use an auxiliary `let` expression:
+
+  g :: T a -> T a -> a
+  g = \t1 t2 ->
+        let aux (MkT x1) (MkT x2) = x1 + x2
+        in aux t1 t2
+
+Then it will not typecheck. To make this work, you'd need to give `aux` a type
+signature. Doing this in general is tantamount to performing type inference,
+however, which is very challenging in a Template Haskell setting.
+
+Another approach, which is what th-desugar currently uses, is to use auxiliary
+_unboxed_ tuples. This is identical to the previous tuple approach, but with
+slightly different syntax:
+
+  \x y -> case (# x, y #) of
+            (# 27#, 42# #) -> ()
+            _              -> error "Non-exhaustive patterns"
+
+Unboxed tuples can handle lifted and unlifted arguments alike, so it is capable
+of handling all the examples above.
+
+You might worry that this approach would require clients of th-desugar to
+enable the UnboxedTuples extension in non-obvious places, but fortunately, this
+is not the case. For one thing, all unboxed tuples produced by th-desugar would
+be TH-generated, so we would bypass the need to enable UnboxedTuples to lex
+unboxed tuple syntax. GHC's typechecker also imposes a requirement that
+UnboxedTuples be enabled if a variable has an unboxed tuple type, but this
+never happens in th-desugar by construction. It's possible that a future
+version of GHC might be stricter about this, but it seems unlikely.
+
+There are a couple of exceptions to the general rule that auxiliary binders
+should be unboxed:
+
+1. ParallelListComp is desugared using the `mzip` function, which returns a
+   lifted pair. As a result, the variables bound in a parallel list
+   comprehension must be lifted. This is a restriction which is inherited from
+   GHC itself—https://gitlab.haskell.org/ghc/ghc/-/merge_requests/7270.
+
+2. Match flattening desugars lazy patterns that bind multiple variables to code
+   that extracts fields from tuples. For instance, this:
+
+     data Pair a b = MkPair a b
+
+     f :: Pair a b -> Pair b a
+     f ~(MkPair x y) = MkPair y x
+
+   Desugars to this (roughly) when match-flattened:
+
+     f :: Pair a b -> Pair b a
+     f p =
+       let tuple = case p of
+                     MkPair x y -> (x, y)
+
+           x = case tuple of
+                 (x, _) -> x
+
+           y = case tuple of
+                 (_, y) -> x
+
+        in MkPair y x
+
+   One could imagine using an unboxed tuple here instead, but since the
+   intermediate `tuple` value would have an unboxed tuple this, this would
+   require users of match flattening to enable UnboxedTuples. Fortunately,
+   using unboxed tuples here isn't necessary, as GHC doesn't support binding
+   variables with unlifted types in lazy patterns anyway.
+-}
Language/Haskell/TH/Desugar/Expand.hs view
@@ -1,226 +1,226 @@-{- Language/Haskell/TH/Desugar/Expand.hs--(c) Richard Eisenberg 2013-rae@cs.brynmawr.edu--}--{-# LANGUAGE NoMonomorphismRestriction, ScopedTypeVariables #-}---------------------------------------------------------------------------------- |--- Module      :  Language.Haskell.TH.Desugar.Expand--- Copyright   :  (C) 2014 Richard Eisenberg--- License     :  BSD-style (see LICENSE)--- Maintainer  :  Ryan Scott--- Stability   :  experimental--- Portability :  non-portable------ Expands type synonyms and type families in desugared types.--- See also the package th-expand-syns for doing this to--- non-desugared types.----------------------------------------------------------------------------------module Language.Haskell.TH.Desugar.Expand (-  -- * Expand synonyms soundly-  expand, expandType,--  -- * Expand synonyms potentially unsoundly-  expandUnsoundly-  ) where--import qualified Data.Map as M-import Language.Haskell.TH hiding (cxt)-import Language.Haskell.TH.Syntax ( Quasi(..) )-import Data.Data-import Data.Generics-import qualified Data.Traversable as T--import Language.Haskell.TH.Desugar.AST-import Language.Haskell.TH.Desugar.Core-import Language.Haskell.TH.Desugar.Util-import Language.Haskell.TH.Desugar.Sweeten-import Language.Haskell.TH.Desugar.Reify-import Language.Haskell.TH.Desugar.Subst---- | Expands all type synonyms in a desugared type. Also expands open type family--- 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 :: forall q. DsMonad q => IgnoreKinds -> DType -> q DType-expand_type ign = go []-  where-    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 (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-      ki' <- go [] ki-      finish (DSigT ty' ki') args-    go args (DConT n) = expand_con ign n args-    go args ty@(DVarT _)  = finish ty args-    go args ty@DArrowT    = finish ty args-    go args ty@(DLitT _)  = finish ty args-    go args ty@DWildCardT = finish ty args--    finish :: DType -> [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 :: forall q.-              DsMonad q-           => IgnoreKinds-           -> Name       -- ^ Tycon name-           -> [DTypeArg] -- ^ Arguments-           -> q DType    -- ^ Expanded type-expand_con ign n args = do-  info <- reifyWithLocals n-  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--    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 $ 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 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--          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--        _ -> give_up--    -- 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--{--Note [Don't expand synonyms for *]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We deliberately avoid expanding type synonyms for * such as Type and ★.-Why? If you reify any such type synonym using Template Haskell, this is-what you'll get:--  TyConI (TySynD <type synonym name> [] StarT)--If you blindly charge ahead and recursively inspect the right-hand side of-this type synonym, you'll desugar StarT into (DConT ''Type), reify ''Type,-and get back another type synonym with StarT as its right-hand side. Then-you'll recursively inspect StarT and find yourself knee-deep in an infinite-loop.--To prevent these sorts of shenanigans, we simply stop whenever we see a type-synonym with StarT as its right-hand side and return Type.--}---- | Expand all type synonyms and type families in the desugared abstract--- syntax tree provided, where type family simplification is on a "best effort"--- basis. Normally, the first parameter should have a type like--- 'DExp' or 'DLetDec'.-expand :: (DsMonad q, Data a) => a -> q a-expand = expand_ NoIgnore---- | Expand all type synonyms and type families in the desugared abstract--- syntax tree provided, where type family simplification is on a "better--- than best effort" basis. This means that it will try so hard that it will--- sometimes do the wrong thing. Specifically, any kind parameters to type--- families are ignored. So, if we have------ > type family F (x :: k) where--- >   F (a :: *) = Int------ 'expandUnsoundly' will expand @F 'True@ to @Int@, ignoring that the--- expansion should only work for type of kind @*@.------ This function is useful because plain old 'expand' will simply fail--- to expand type families that make use of kinds. Sometimes, the kinds--- are benign and we want to expand anyway. Use this function in that case.-expandUnsoundly :: (DsMonad q, Data a) => a -> q a-expandUnsoundly = expand_ YesIgnore---- | 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))+{- Language/Haskell/TH/Desugar/Expand.hs
+
+(c) Richard Eisenberg 2013
+rae@cs.brynmawr.edu
+-}
+
+{-# LANGUAGE NoMonomorphismRestriction, ScopedTypeVariables #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Language.Haskell.TH.Desugar.Expand
+-- Copyright   :  (C) 2014 Richard Eisenberg
+-- License     :  BSD-style (see LICENSE)
+-- Maintainer  :  Ryan Scott
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- Expands type synonyms and type families in desugared types.
+-- See also the package th-expand-syns for doing this to
+-- non-desugared types.
+--
+----------------------------------------------------------------------------
+
+module Language.Haskell.TH.Desugar.Expand (
+  -- * Expand synonyms soundly
+  expand, expandType,
+
+  -- * Expand synonyms potentially unsoundly
+  expandUnsoundly
+  ) where
+
+import qualified Data.Map as M
+import Language.Haskell.TH hiding (cxt)
+import Language.Haskell.TH.Syntax ( Quasi(..) )
+import Data.Data
+import Data.Generics
+import qualified Data.Traversable as T
+
+import Language.Haskell.TH.Desugar.AST
+import Language.Haskell.TH.Desugar.Core
+import Language.Haskell.TH.Desugar.Util
+import Language.Haskell.TH.Desugar.Sweeten
+import Language.Haskell.TH.Desugar.Reify
+import Language.Haskell.TH.Desugar.Subst
+
+-- | Expands all type synonyms in a desugared type. Also expands open type family
+-- 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 :: forall q. DsMonad q => IgnoreKinds -> DType -> q DType
+expand_type ign = go []
+  where
+    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 (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
+      ki' <- go [] ki
+      finish (DSigT ty' ki') args
+    go args (DConT n) = expand_con ign n args
+    go args ty@(DVarT _)  = finish ty args
+    go args ty@DArrowT    = finish ty args
+    go args ty@(DLitT _)  = finish ty args
+    go args ty@DWildCardT = finish ty args
+
+    finish :: DType -> [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 :: forall q.
+              DsMonad q
+           => IgnoreKinds
+           -> Name       -- ^ Tycon name
+           -> [DTypeArg] -- ^ Arguments
+           -> q DType    -- ^ Expanded type
+expand_con ign n args = do
+  info <- reifyWithLocals n
+  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
+
+    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 $ 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 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
+
+          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
+
+        _ -> give_up
+
+    -- 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
+
+{-
+Note [Don't expand synonyms for *]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We deliberately avoid expanding type synonyms for * such as Type and ★.
+Why? If you reify any such type synonym using Template Haskell, this is
+what you'll get:
+
+  TyConI (TySynD <type synonym name> [] StarT)
+
+If you blindly charge ahead and recursively inspect the right-hand side of
+this type synonym, you'll desugar StarT into (DConT ''Type), reify ''Type,
+and get back another type synonym with StarT as its right-hand side. Then
+you'll recursively inspect StarT and find yourself knee-deep in an infinite
+loop.
+
+To prevent these sorts of shenanigans, we simply stop whenever we see a type
+synonym with StarT as its right-hand side and return Type.
+-}
+
+-- | Expand all type synonyms and type families in the desugared abstract
+-- syntax tree provided, where type family simplification is on a "best effort"
+-- basis. Normally, the first parameter should have a type like
+-- 'DExp' or 'DLetDec'.
+expand :: (DsMonad q, Data a) => a -> q a
+expand = expand_ NoIgnore
+
+-- | Expand all type synonyms and type families in the desugared abstract
+-- syntax tree provided, where type family simplification is on a "better
+-- than best effort" basis. This means that it will try so hard that it will
+-- sometimes do the wrong thing. Specifically, any kind parameters to type
+-- families are ignored. So, if we have
+--
+-- > type family F (x :: k) where
+-- >   F (a :: *) = Int
+--
+-- 'expandUnsoundly' will expand @F 'True@ to @Int@, ignoring that the
+-- expansion should only work for type of kind @*@.
+--
+-- This function is useful because plain old 'expand' will simply fail
+-- to expand type families that make use of kinds. Sometimes, the kinds
+-- are benign and we want to expand anyway. Use this function in that case.
+expandUnsoundly :: (DsMonad q, Data a) => a -> q a
+expandUnsoundly = expand_ YesIgnore
+
+-- | 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))
Language/Haskell/TH/Desugar/FV.hs view
@@ -1,73 +1,73 @@-{- 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.-extractBoundNamesDPat :: DPat -> OSet Name-extractBoundNamesDPat = go-  where-    go :: DPat -> OSet Name-    go (DLitP _)          = OS.empty-    go (DVarP n)          = OS.singleton n-    go (DConP _ tys pats) = foldMap fvDType tys <> foldMap go pats-    go (DTildeP p)        = go p-    go (DBangP p)         = go p-    go (DSigP p _)        = go p-    go DWildP             = OS.empty---------- 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/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.
+extractBoundNamesDPat :: DPat -> OSet Name
+extractBoundNamesDPat = go
+  where
+    go :: DPat -> OSet Name
+    go (DLitP _)          = OS.empty
+    go (DVarP n)          = OS.singleton n
+    go (DConP _ tys pats) = foldMap fvDType tys <> foldMap go pats
+    go (DTildeP p)        = go p
+    go (DBangP p)         = go p
+    go (DSigP p _)        = go p
+    go DWildP             = OS.empty
+
+-----
+-- 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
@@ -1,42 +1,18 @@--------------------------------------------------------------------------------- |--- Module      :  Language.Haskell.TH.Desugar.Lift--- Copyright   :  (C) 2014 Richard Eisenberg--- License     :  BSD-style (see LICENSE)--- 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.----------------------------------------------------------------------------------{-# LANGUAGE CPP, TemplateHaskell #-}-{-# OPTIONS_GHC -Wno-orphans #-}--module Language.Haskell.TH.Desugar.Lift () where--import Language.Haskell.TH.Desugar-import Language.Haskell.TH.Instances ()-import Language.Haskell.TH.Lift--$(deriveLiftMany [ ''DExp, ''DPat, ''DType, ''DForallTelescope, ''DTyVarBndr-                 , ''DMatch, ''DClause, ''DLetDec, ''DDec, ''DDerivClause, ''DCon-                 , ''DConFields, ''DForeign, ''DPragma, ''DRuleBndr, ''DTySynEqn-                 , ''DPatSynDir , ''NewOrData, ''DDerivStrategy-                 , ''DTypeFamilyHead,  ''DFamilyResultSig-#if __GLASGOW_HASKELL__ < 801-                 , ''PatSynArgs-#endif-#if __GLASGOW_HASKELL__ < 900-                 , ''Specificity-#endif--                 , ''TypeArg,   ''DTypeArg-                 , ''FunArgs,   ''DFunArgs-                 , ''VisFunArg, ''DVisFunArg-                 , ''ForallTelescope-                 ])+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Language.Haskell.TH.Desugar.Lift
+-- Copyright   :  (C) 2014 Richard Eisenberg
+-- License     :  BSD-style (see LICENSE)
+-- Maintainer  :  Ryan Scott
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- 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.
+--
+----------------------------------------------------------------------------
+
+module Language.Haskell.TH.Desugar.Lift () where
+
+import Language.Haskell.TH.Desugar ()
Language/Haskell/TH/Desugar/Match.hs view
@@ -1,413 +1,413 @@-{- Language/Haskell/TH/Desugar/Match.hs--(c) Richard Eisenberg 2013-rae@cs.brynmawr.edu--Simplifies case statements in desugared TH. After this pass, there are no-more nested patterns.--This code is directly based on the analogous operation as written in GHC.--}--{-# LANGUAGE CPP, TemplateHaskellQuotes #-}--module Language.Haskell.TH.Desugar.Match (scExp, scLetDec) where--import Prelude hiding ( fail, exp )--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.Set as S-import qualified Data.Map as Map-import Language.Haskell.TH.Instances ()-import Language.Haskell.TH.Syntax--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---- | Remove all nested pattern-matches within this expression. This also--- removes all 'DTildePa's and 'DBangPa's. After this is run, every pattern--- is guaranteed to be either a 'DConPa' with bare variables as arguments,--- a 'DLitPa', or a 'DWildPa'.-scExp :: DsMonad q => DExp -> q DExp-scExp (DAppE e1 e2) = DAppE <$> scExp e1 <*> scExp e2-scExp (DLamE names exp) = DLamE names <$> scExp exp-scExp (DCaseE scrut matches)-  | DVarE name <- scrut-  = simplCaseExp [name] clauses-  | otherwise-  = do scrut_name <- newUniqueName "scrut"-       case_exp <- simplCaseExp [scrut_name] clauses-       return $ DLetE [DValD (DVarP scrut_name) scrut] case_exp-  where-    clauses = map match_to_clause matches-    match_to_clause (DMatch pat exp) = DClause [pat] exp--scExp (DLetE decs body) = DLetE <$> mapM scLetDec decs <*> scExp body-scExp (DSigE exp ty) = DSigE <$> scExp exp <*> pure ty-scExp (DAppTypeE exp ty) = DAppTypeE <$> scExp exp <*> pure ty-scExp e@(DVarE {}) = return e-scExp e@(DConE {}) = return e-scExp e@(DLitE {}) = return e-scExp e@(DStaticE {}) = return e---- | Like 'scExp', but for a 'DLetDec'.-scLetDec :: DsMonad q => DLetDec -> q DLetDec-scLetDec (DFunD name clauses@(DClause pats1 _ : _)) = do-  arg_names <- mapM (const (newUniqueName "_arg")) pats1-  clauses' <- mapM sc_clause_rhs clauses-  case_exp <- simplCaseExp arg_names clauses'-  return $ DFunD name [DClause (map DVarP arg_names) case_exp]-  where-    sc_clause_rhs (DClause pats exp) = DClause pats <$> scExp exp-scLetDec (DValD pat exp) = DValD pat <$> scExp exp-scLetDec (DPragmaD prag) = DPragmaD <$> scLetPragma prag-scLetDec dec@(DSigD {}) = return dec-scLetDec dec@(DInfixD {}) = return dec-scLetDec dec@(DFunD _ []) = return dec--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-matchResultToDExp mr = mr failed_pattern_match-  where-    failed_pattern_match = DAppE (DVarE 'error)-                                 (DLitE $ StringL "Pattern-match failure")--simplCaseExp :: DsMonad q-             => [Name]-             -> [DClause]-             -> q DExp-simplCaseExp vars clauses =-  do let eis = [ EquationInfo pats (\_ -> rhs) |-                 DClause pats rhs <- clauses ]-     matchResultToDExp `liftM` simplCase vars eis--data EquationInfo = EquationInfo [DPat] MatchResult  -- like DClause, but with a hole---- analogous to GHC's match (in deSugar/Match.lhs)-simplCase :: DsMonad q-          => [Name]         -- the names of the scrutinees-          -> [EquationInfo] -- the matches (where the # of pats == length (1st arg))-          -> q MatchResult-simplCase [] clauses = return (foldr1 (.) match_results)-  where-    match_results = [ mr | EquationInfo _ mr <- clauses ]-simplCase vars@(v:_) 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 [] = 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,_) : _) =-      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)--    drop_group = map snd---- 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-  (wrap, pat') <- tidy1 v pat-  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@(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, DWildP)-tidy1 v (DBangP pat) =-  case pat of-    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-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)--wrapBind :: Name -> Name -> DExp -> DExp-wrapBind new old-  | new == old = id-  | otherwise  = DLetE [DValD (DVarP new) (DVarE old)]---- like GHC's mkSelectorBinds-mkSelectorDecs :: DsMonad q-               => DPat      -- pattern to deconstruct-               -> Name      -- variable being matched against-               -> q [DLetDec]-mkSelectorDecs (DVarP v) name = return [DValD (DVarP v) (DVarE name)]-mkSelectorDecs pat name-  | OS.null binders-  = return []--  | OS.size binders == 1-  = do val_var <- newUniqueName "var"-       err_var <- newUniqueName "err"-       bind    <- mk_bind val_var err_var (head $ F.toList binders)-       return [DValD (DVarP val_var) (DVarE name),-               DValD (DVarP err_var) (DVarE 'error `DAppE`-                                       (DLitE $ StringL "Irrefutable match failed")),-               bind]--  | otherwise-  = 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 (DVarP tuple_var) tuple_expr :-               zipWith DValD (map DVarP binders_list) projections)--  where-    binders = extractBoundNamesDPat pat-    binders_list = F.toList binders-    tuple_size = length binders_list-    local_tuple = mkTupleDExp (map DVarE binders_list)--    mk_projection :: DsMonad q-                  => Name   -- of the tuple-                  -> Int    -- which element to get (0-indexed)-                  -> q DExp-    mk_projection tup_name i = do-      var_name <- newUniqueName "proj"-      return $ DCaseE (DVarE tup_name) [DMatch (DConP (tupleDataName tuple_size) [] (mk_tuple_pats var_name i))-                                               (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 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 (DVarP bndr_var) (rhs_mr (DVarE err_var)))--data PatGroup-  = PgAny         -- immediate match (wilds, vars, lazies)-  | PgCon Name-  | PgLit Lit-  | PgBang---- like GHC's groupEquations-groupClauses :: [EquationInfo] -> [[(PatGroup, EquationInfo)]]-groupClauses clauses-  = runs 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 (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--sameGroup :: PatGroup -> PatGroup -> Bool-sameGroup PgAny     PgAny     = True-sameGroup PgBang    PgBang    = True-sameGroup (PgCon _) (PgCon _) = True-sameGroup (PgLit _) (PgLit _) = True-sameGroup _         _         = False--subGroup :: Ord a => [(a, EquationInfo)] -> [[EquationInfo]]-subGroup group-  = map reverse $ Map.elems $ foldl accumulate Map.empty group-  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--firstPat :: EquationInfo -> DPat-firstPat (EquationInfo (pat : _) _) = pat-firstPat _ = error "Clause encountered with no patterns -- should never happen"--data CaseAlt = CaseAlt { alt_con  :: Name         -- con name-                       , _alt_args :: [Name]       -- bound var names-                       , _alt_rhs  :: MatchResult  -- RHS-                       }---- from GHC's MatchCon.lhs-matchConFamily :: DsMonad q => [Name] -> [[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 : _)-  = do arg_vars <- selectMatchVars (pat_args pat1)-       match_result <- match_group arg_vars--       return $ CaseAlt (pat_con pat1) arg_vars match_result-  where-    pat1 = firstPat eqn1--    pat_args (DConP _ _ pats) = pats-    pat_args _                = error "Internal error in th-desugar (pat_args)"--    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)--    shift (EquationInfo (DConP _ _ args : pats) exp) = EquationInfo (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-mkDataConCase var case_alts = do-  all_ctors <- get_all_ctors (alt_con $ head case_alts)-  return $ \fail ->-    let matches = map (mk_alt fail) case_alts in-    DCaseE (DVarE var) (matches ++ mk_default all_ctors fail)-  where-    mk_alt fail (CaseAlt con args body_fn)-      = let body = body_fn fail in-        DMatch (DConP con [] (map DVarP args)) body--    mk_default all_ctors fail | exhaustive_case all_ctors = []-                              | otherwise       = [DMatch DWildP fail]--    mentioned_ctors = S.fromList $ map alt_con case_alts-    exhaustive_case all_ctors = all_ctors `S.isSubsetOf` mentioned_ctors--    get_all_ctors :: DsMonad q => Name -> q (S.Set Name)-    get_all_ctors con_name = do-      ty_name <- dataConNameToDataName con_name-      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_con_name (DCon _ _ n _ _) = n--matchEmpty :: DsMonad q => Name -> q [MatchResult]-matchEmpty var = return [mk_seq]-  where-    mk_seq fail = DCaseE (DVarE var) [DMatch DWildP fail]--matchLiterals :: DsMonad q => [Name] -> [[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 eqns-      = do let lit = case firstPat (head eqns) of-                       DLitP lit' -> lit'-                       _          -> error $ "Internal error in th-desugar "-                                          ++ "(matchLiterals.match_group)"-           match_result <- simplCase vars (shiftEqns eqns)-           return (lit, match_result)-matchLiterals [] _ = error "Internal error in th-desugar (matchLiterals)"--mkCoPrimCaseMatchResult :: Name -- Scrutinee-                        -> [(Lit, MatchResult)]-                        -> MatchResult-mkCoPrimCaseMatchResult var match_alts = mk_case-  where-    mk_case fail = let alts = map (mk_alt fail) match_alts in-                   DCaseE (DVarE var) (alts ++ [DMatch DWildP fail])-    mk_alt fail (lit, body_fn)-      = DMatch (DLitP lit) (body_fn fail)--matchBangs :: DsMonad q => [Name] -> [EquationInfo] -> q MatchResult-matchBangs (var:vars) eqns-  = do match_result <- simplCase (var:vars) $-                       map (decomposeFirstPat getBangPat) eqns-       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)"--getBangPat :: DPat -> DPat-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)"--shiftEqns :: [EquationInfo] -> [EquationInfo]-shiftEqns = map shift-  where-    shift (EquationInfo pats rhs) = EquationInfo (tail pats) rhs---adjustMatchResult :: (DExp -> DExp) -> MatchResult -> MatchResult-adjustMatchResult wrap mr fail = wrap $ mr fail---- from DsUtils-selectMatchVars :: DsMonad q => [DPat] -> q [Name]-selectMatchVars = mapM selectMatchVar---- from DsUtils-selectMatchVar :: DsMonad q => DPat -> q Name-selectMatchVar (DBangP pat)  = selectMatchVar pat-selectMatchVar (DTildeP pat) = selectMatchVar pat-selectMatchVar (DVarP var)   = newUniqueName ('_' : nameBase var)-selectMatchVar _             = newUniqueName "_pat"---- like GHC's runs-runs :: (a -> a -> Bool) -> [a] -> [[a]]-runs _ [] = []-runs p (x:xs) = case span (p x) xs of-                  (first, rest) -> (x:first) : (runs p rest)+{- Language/Haskell/TH/Desugar/Match.hs
+
+(c) Richard Eisenberg 2013
+rae@cs.brynmawr.edu
+
+Simplifies case statements in desugared TH. After this pass, there are no
+more nested patterns.
+
+This code is directly based on the analogous operation as written in GHC.
+-}
+
+{-# LANGUAGE CPP, TemplateHaskellQuotes #-}
+
+module Language.Haskell.TH.Desugar.Match (scExp, scLetDec) where
+
+import Prelude hiding ( fail, exp )
+
+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.Set as S
+import qualified Data.Map as Map
+import Language.Haskell.TH.Instances ()
+import Language.Haskell.TH.Syntax
+
+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
+
+-- | Remove all nested pattern-matches within this expression. This also
+-- removes all 'DTildePa's and 'DBangPa's. After this is run, every pattern
+-- is guaranteed to be either a 'DConPa' with bare variables as arguments,
+-- a 'DLitPa', or a 'DWildPa'.
+scExp :: DsMonad q => DExp -> q DExp
+scExp (DAppE e1 e2) = DAppE <$> scExp e1 <*> scExp e2
+scExp (DLamE names exp) = DLamE names <$> scExp exp
+scExp (DCaseE scrut matches)
+  | DVarE name <- scrut
+  = simplCaseExp [name] clauses
+  | otherwise
+  = do scrut_name <- newUniqueName "scrut"
+       case_exp <- simplCaseExp [scrut_name] clauses
+       return $ DLetE [DValD (DVarP scrut_name) scrut] case_exp
+  where
+    clauses = map match_to_clause matches
+    match_to_clause (DMatch pat exp) = DClause [pat] exp
+
+scExp (DLetE decs body) = DLetE <$> mapM scLetDec decs <*> scExp body
+scExp (DSigE exp ty) = DSigE <$> scExp exp <*> pure ty
+scExp (DAppTypeE exp ty) = DAppTypeE <$> scExp exp <*> pure ty
+scExp e@(DVarE {}) = return e
+scExp e@(DConE {}) = return e
+scExp e@(DLitE {}) = return e
+scExp e@(DStaticE {}) = return e
+
+-- | Like 'scExp', but for a 'DLetDec'.
+scLetDec :: DsMonad q => DLetDec -> q DLetDec
+scLetDec (DFunD name clauses@(DClause pats1 _ : _)) = do
+  arg_names <- mapM (const (newUniqueName "_arg")) pats1
+  clauses' <- mapM sc_clause_rhs clauses
+  case_exp <- simplCaseExp arg_names clauses'
+  return $ DFunD name [DClause (map DVarP arg_names) case_exp]
+  where
+    sc_clause_rhs (DClause pats exp) = DClause pats <$> scExp exp
+scLetDec (DValD pat exp) = DValD pat <$> scExp exp
+scLetDec (DPragmaD prag) = DPragmaD <$> scLetPragma prag
+scLetDec dec@(DSigD {}) = return dec
+scLetDec dec@(DInfixD {}) = return dec
+scLetDec dec@(DFunD _ []) = return dec
+
+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
+matchResultToDExp mr = mr failed_pattern_match
+  where
+    failed_pattern_match = DAppE (DVarE 'error)
+                                 (DLitE $ StringL "Pattern-match failure")
+
+simplCaseExp :: DsMonad q
+             => [Name]
+             -> [DClause]
+             -> q DExp
+simplCaseExp vars clauses =
+  do let eis = [ EquationInfo pats (\_ -> rhs) |
+                 DClause pats rhs <- clauses ]
+     matchResultToDExp `liftM` simplCase vars eis
+
+data EquationInfo = EquationInfo [DPat] MatchResult  -- like DClause, but with a hole
+
+-- analogous to GHC's match (in deSugar/Match.lhs)
+simplCase :: DsMonad q
+          => [Name]         -- the names of the scrutinees
+          -> [EquationInfo] -- the matches (where the # of pats == length (1st arg))
+          -> q MatchResult
+simplCase [] clauses = return (foldr1 (.) match_results)
+  where
+    match_results = [ mr | EquationInfo _ mr <- clauses ]
+simplCase vars@(v:_) 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 [] = 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,_) : _) =
+      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)
+
+    drop_group = map snd
+
+-- 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
+  (wrap, pat') <- tidy1 v pat
+  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@(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, DWildP)
+tidy1 v (DBangP pat) =
+  case pat of
+    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
+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)
+
+wrapBind :: Name -> Name -> DExp -> DExp
+wrapBind new old
+  | new == old = id
+  | otherwise  = DLetE [DValD (DVarP new) (DVarE old)]
+
+-- like GHC's mkSelectorBinds
+mkSelectorDecs :: DsMonad q
+               => DPat      -- pattern to deconstruct
+               -> Name      -- variable being matched against
+               -> q [DLetDec]
+mkSelectorDecs (DVarP v) name = return [DValD (DVarP v) (DVarE name)]
+mkSelectorDecs pat name
+  | OS.null binders
+  = return []
+
+  | OS.size binders == 1
+  = do val_var <- newUniqueName "var"
+       err_var <- newUniqueName "err"
+       bind    <- mk_bind val_var err_var (head $ F.toList binders)
+       return [DValD (DVarP val_var) (DVarE name),
+               DValD (DVarP err_var) (DVarE 'error `DAppE`
+                                       (DLitE $ StringL "Irrefutable match failed")),
+               bind]
+
+  | otherwise
+  = 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 (DVarP tuple_var) tuple_expr :
+               zipWith DValD (map DVarP binders_list) projections)
+
+  where
+    binders = extractBoundNamesDPat pat
+    binders_list = F.toList binders
+    tuple_size = length binders_list
+    local_tuple = mkTupleDExp (map DVarE binders_list)
+
+    mk_projection :: DsMonad q
+                  => Name   -- of the tuple
+                  -> Int    -- which element to get (0-indexed)
+                  -> q DExp
+    mk_projection tup_name i = do
+      var_name <- newUniqueName "proj"
+      return $ DCaseE (DVarE tup_name) [DMatch (DConP (tupleDataName tuple_size) [] (mk_tuple_pats var_name i))
+                                               (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 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 (DVarP bndr_var) (rhs_mr (DVarE err_var)))
+
+data PatGroup
+  = PgAny         -- immediate match (wilds, vars, lazies)
+  | PgCon Name
+  | PgLit Lit
+  | PgBang
+
+-- like GHC's groupEquations
+groupClauses :: [EquationInfo] -> [[(PatGroup, EquationInfo)]]
+groupClauses clauses
+  = runs 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 (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
+
+sameGroup :: PatGroup -> PatGroup -> Bool
+sameGroup PgAny     PgAny     = True
+sameGroup PgBang    PgBang    = True
+sameGroup (PgCon _) (PgCon _) = True
+sameGroup (PgLit _) (PgLit _) = True
+sameGroup _         _         = False
+
+subGroup :: Ord a => [(a, EquationInfo)] -> [[EquationInfo]]
+subGroup group
+  = map reverse $ Map.elems $ foldl accumulate Map.empty group
+  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
+
+firstPat :: EquationInfo -> DPat
+firstPat (EquationInfo (pat : _) _) = pat
+firstPat _ = error "Clause encountered with no patterns -- should never happen"
+
+data CaseAlt = CaseAlt { alt_con  :: Name         -- con name
+                       , _alt_args :: [Name]       -- bound var names
+                       , _alt_rhs  :: MatchResult  -- RHS
+                       }
+
+-- from GHC's MatchCon.lhs
+matchConFamily :: DsMonad q => [Name] -> [[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 : _)
+  = do arg_vars <- selectMatchVars (pat_args pat1)
+       match_result <- match_group arg_vars
+
+       return $ CaseAlt (pat_con pat1) arg_vars match_result
+  where
+    pat1 = firstPat eqn1
+
+    pat_args (DConP _ _ pats) = pats
+    pat_args _                = error "Internal error in th-desugar (pat_args)"
+
+    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)
+
+    shift (EquationInfo (DConP _ _ args : pats) exp) = EquationInfo (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
+mkDataConCase var case_alts = do
+  all_ctors <- get_all_ctors (alt_con $ head case_alts)
+  return $ \fail ->
+    let matches = map (mk_alt fail) case_alts in
+    DCaseE (DVarE var) (matches ++ mk_default all_ctors fail)
+  where
+    mk_alt fail (CaseAlt con args body_fn)
+      = let body = body_fn fail in
+        DMatch (DConP con [] (map DVarP args)) body
+
+    mk_default all_ctors fail | exhaustive_case all_ctors = []
+                              | otherwise       = [DMatch DWildP fail]
+
+    mentioned_ctors = S.fromList $ map alt_con case_alts
+    exhaustive_case all_ctors = all_ctors `S.isSubsetOf` mentioned_ctors
+
+    get_all_ctors :: DsMonad q => Name -> q (S.Set Name)
+    get_all_ctors con_name = do
+      ty_name <- dataConNameToDataName con_name
+      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_con_name (DCon _ _ n _ _) = n
+
+matchEmpty :: DsMonad q => Name -> q [MatchResult]
+matchEmpty var = return [mk_seq]
+  where
+    mk_seq fail = DCaseE (DVarE var) [DMatch DWildP fail]
+
+matchLiterals :: DsMonad q => [Name] -> [[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 eqns
+      = do let lit = case firstPat (head eqns) of
+                       DLitP lit' -> lit'
+                       _          -> error $ "Internal error in th-desugar "
+                                          ++ "(matchLiterals.match_group)"
+           match_result <- simplCase vars (shiftEqns eqns)
+           return (lit, match_result)
+matchLiterals [] _ = error "Internal error in th-desugar (matchLiterals)"
+
+mkCoPrimCaseMatchResult :: Name -- Scrutinee
+                        -> [(Lit, MatchResult)]
+                        -> MatchResult
+mkCoPrimCaseMatchResult var match_alts = mk_case
+  where
+    mk_case fail = let alts = map (mk_alt fail) match_alts in
+                   DCaseE (DVarE var) (alts ++ [DMatch DWildP fail])
+    mk_alt fail (lit, body_fn)
+      = DMatch (DLitP lit) (body_fn fail)
+
+matchBangs :: DsMonad q => [Name] -> [EquationInfo] -> q MatchResult
+matchBangs (var:vars) eqns
+  = do match_result <- simplCase (var:vars) $
+                       map (decomposeFirstPat getBangPat) eqns
+       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)"
+
+getBangPat :: DPat -> DPat
+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)"
+
+shiftEqns :: [EquationInfo] -> [EquationInfo]
+shiftEqns = map shift
+  where
+    shift (EquationInfo pats rhs) = EquationInfo (tail pats) rhs
+
+
+adjustMatchResult :: (DExp -> DExp) -> MatchResult -> MatchResult
+adjustMatchResult wrap mr fail = wrap $ mr fail
+
+-- from DsUtils
+selectMatchVars :: DsMonad q => [DPat] -> q [Name]
+selectMatchVars = mapM selectMatchVar
+
+-- from DsUtils
+selectMatchVar :: DsMonad q => DPat -> q Name
+selectMatchVar (DBangP pat)  = selectMatchVar pat
+selectMatchVar (DTildeP pat) = selectMatchVar pat
+selectMatchVar (DVarP var)   = newUniqueName ('_' : nameBase var)
+selectMatchVar _             = newUniqueName "_pat"
+
+-- like GHC's runs
+runs :: (a -> a -> Bool) -> [a] -> [[a]]
+runs _ [] = []
+runs p (x:xs) = case span (p x) xs of
+                  (first, rest) -> (x:first) : (runs p rest)
Language/Haskell/TH/Desugar/OMap.hs view
@@ -1,142 +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 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
@@ -1,115 +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 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
@@ -1,117 +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 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,1081 +1,1317 @@-{- Language/Haskell/TH/Desugar/Reify.hs--(c) Richard Eisenberg 2014-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-import Language.Haskell.TH.Datatype.TyVarBndr-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, 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 @TyVarBndr@s and constructors given the @Name@ of a type-getDataD :: DsMonad q-         => String       -- ^ Print this out on failure-         -> Name         -- ^ Name of the datatype (@data@ or @newtype@) of interest-         -> q ([TyVarBndrUnit], [Con])-getDataD err name = do-  info <- reifyWithLocals name-  dec <- case info of-           TyConI dec -> return dec-           _ -> badDeclaration-  case dec of-    DataD _cxt _name tvbs mk cons _derivings -> go tvbs mk cons-    NewtypeD _cxt _name tvbs mk con _derivings -> go tvbs mk [con]-    _ -> badDeclaration-  where-    go tvbs mk cons = do-      let k = fromMaybe (ConT typeKindName) mk-      extra_tvbs <- mkExtraKindBinders k-      let all_tvbs = tvbs ++ extra_tvbs-      return (all_tvbs, cons)--    badDeclaration =-          fail $ "The name (" ++ (show name) ++ ") refers to something " ++-                 "other than a datatype. " ++ err---- | 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 [TyVarBndrUnit]-mkExtraKindBinders k = do-  k' <- runQ $ resolveTypeSynonyms k-  let (fun_args, _) = unravelType k'-      vis_fun_args  = filterVisFunArgs fun_args-  mapM mk_tvb vis_fun_args-  where-    mk_tvb :: VisFunArg -> q TyVarBndrUnit-    mk_tvb (VisFADep tvb) = return tvb-    mk_tvb (VisFAAnon ki) = kindedTV <$> qNewName "a" <*> return ki---- | 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, Quasi, Fail.MonadFail-#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 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--reifyInDec n decs (DataD _ ty_name tvbs _mk cons _)-  | Just info <- maybeReifyCon n decs ty_name (map tvbToTANormalWithSig tvbs) cons-  = Just info-reifyInDec n decs (NewtypeD _ ty_name tvbs _mk con _)-  | Just info <- maybeReifyCon n decs ty_name (map tvbToTANormalWithSig tvbs) [con]-  = Just info-reifyInDec n _decs (ClassD _ ty_name tvbs _ sub_decs)-  | Just (n', ty) <- findType n sub_decs-  = Just (n', ClassOpI n (quantifyClassMethodType ty_name tvbs True ty) ty_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__ >= 807-reifyInDec n decs (DataInstD _ _ lhs _ cons _)-  | (ConT ty_name, tys) <- unfoldType lhs-  , Just info <- maybeReifyCon n decs ty_name tys cons-  = Just info-reifyInDec n decs (NewtypeInstD _ _ lhs _ con _)-  | (ConT ty_name, tys) <- unfoldType lhs-  , 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 (map TANormal tys) cons-  = Just info-reifyInDec n decs (NewtypeInstD _ ty_name tys _ con _)-  | Just info <- maybeReifyCon n decs ty_name (map TANormal tys) [con]-  = Just info-#endif--reifyInDec _ _ _ = Nothing--maybeReifyCon :: Name -> [Dec] -> Name -> [TypeArg] -> [Con] -> Maybe (Named Info)-maybeReifyCon n _decs ty_name ty_args 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 -> ([TyVarBndrUnit], Type, Type)-      -- Returns ( Selector type variable binders-      --         , Record field type-      --         , constructor result type )-    extract_rec_sel_info rec_sel_info =-      case rec_sel_info of-        RecSelH98 sel_ty -> (h98_tvbs, sel_ty, h98_res_ty)-        RecSelGADT sel_ty con_res_ty ->-          ( freeVariablesWellScoped [con_res_ty, sel_ty]-          , sel_ty, con_res_ty)--    h98_tvbs   = freeVariablesWellScoped $ map probablyWrongUnTypeArg ty_args-    h98_res_ty = applyType (ConT ty_name) ty_args--maybeReifyCon _ _ _ _ _ = Nothing--{--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.--}---- Reverse-engineer the type of a data constructor.-con_to_type :: [TyVarBndrUnit] -- 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 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)--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 cls_name 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 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-  :: Name            -- ^ The class name.-  -> [TyVarBndrUnit] -- ^ The class's type variable binders.-  -> Bool            -- ^ If 'True', prepend a class predicate.-  -> Type            -- ^ The method type.-  -> Type-quantifyClassMethodType cls_name cls_tvbs prepend meth_ty =-  add_cls_cxt quantified_meth_ty-  where-    add_cls_cxt :: Type -> Type-    add_cls_cxt-      | prepend   = ForallT (changeTVFlags SpecifiedSpec all_cls_tvbs) cls_cxt-      | otherwise = id--    cls_cxt :: Cxt-    cls_cxt = [foldl AppT (ConT cls_name) (map tvbToType cls_tvbs)]--    quantified_meth_ty :: Type-    quantified_meth_ty-      | null meth_tvbs-      = 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 = changeTVFlags SpecifiedSpec $-                List.deleteFirstsBy ((==) `on` tvName)-                  (freeVariablesWellScoped [meth_ty]) all_cls_tvbs--    -- Explicitly quantify any kind variables bound by the class, if any.-    all_cls_tvbs :: [TyVarBndrUnit]-    all_cls_tvbs = freeVariablesWellScoped $ map tvbToTypeWithSig cls_tvbs--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 :: [TyVarBndrUnit] -> Cxt -> Type -> Type-maybeForallT tvbs cxt ty-  | null tvbs && null cxt        = ty-  | ForallT tvbs2 cxt2 ty2 <- ty = ForallT (tvbs_spec ++ tvbs2) (cxt ++ cxt2) ty2-  | otherwise                    = ForallT tvbs_spec cxt ty-  where-    tvbs_spec = changeTVFlags SpecifiedSpec tvbs--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 Type -- The record field's type-               Type -- The GADT return type--findRecSelector :: Name -> [Con] -> Maybe (Named RecSelInfo)-findRecSelector n = firstMatch match_con-  where-    match_con :: Con -> Maybe (Named RecSelInfo)-    match_con (RecC _ vstys)            = fmap (liftSnd RecSelH98) $-                                          firstMatch match_rec_sel vstys-    match_con (RecGadtC _ vstys ret_ty) = fmap (liftSnd (`RecSelGADT` ret_ty)) $-                                          firstMatch match_rec_sel vstys-    match_con (ForallC _ _ c)           = match_con c-    match_con _                         = Nothing--    match_rec_sel (n', _, sel_ty)-      | n `nameMatches` n' = Just (n', sel_ty)-    match_rec_sel _        = Nothing-------------------------------------- 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 <|> tvb_kind_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 <- [tvb_kind_maybe tvb]-                                        ]-  = firstMatch (find_assoc_type_kind n cls_tvb_kind_map) sub_decs-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 :: TyVarBndrUnit -> TyVarBndrUnit-    ascribe_tf_tvb_kind tvb =-      elimTV (\tvn -> kindedTV tvn $ fromMaybe StarT $ Map.lookup tvn cls_tvb_kind_map)-             (\_ _ -> tvb)-             tvb---- Data types have CUSKs when:------ 1. All of their type variables have explicit kinds.--- 2. All kind variables in the result kind are explicitly quantified.-datatype_kind :: [TyVarBndrUnit] -> Maybe Kind -> Maybe Kind-datatype_kind 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 :: [TyVarBndrUnit] -> Maybe Kind-class_kind tvbs = whenAlt (all tvb_is_kinded tvbs) $-                  build_kind tvbs ConstraintT---- Open type families and data families always have CUSKs. Type variables--- without explicit kinds default to Type, as does the return kind if it--- is not specified.-open_ty_fam_kind :: [TyVarBndrUnit] -> Maybe Kind -> Maybe Kind-open_ty_fam_kind 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 :: [TyVarBndrUnit] -> 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 :: [TyVarBndrUnit] -> 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 :: [TyVarBndrUnit] -> Kind -> Maybe Kind-build_kind arg_kinds res_kind =-  fmap quantifyType $ fst $-  foldr go (Just res_kind, Set.fromList (freeVariables res_kind)) arg_kinds-  where-    go :: TyVarBndrUnit -> (Maybe Kind, Set Name) -> (Maybe Kind, Set Name)-    go tvb (res, res_fvs) =-      elimTV (\n ->-               ( if n `Set.member` res_fvs-                 then forall_vis 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_vis tvb res-                 else fmap (ArrowT `AppT` k `AppT`) res-               , Set.fromList (freeVariables k) `Set.union` res_fvs-               ))-             tvb--    forall_vis :: TyVarBndrUnit -> Maybe Kind -> Maybe Kind-#if __GLASGOW_HASKELL__ >= 809-    forall_vis tvb m_ki = fmap (ForallVisT [tvb]) m_ki-      -- 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_vis _   _    = Nothing-#endif--tvb_is_kinded :: TyVarBndr_ flag -> Bool-tvb_is_kinded = isJust . tvb_kind_maybe--tvb_kind_maybe :: TyVarBndr_ flag -> Maybe Kind-tvb_kind_maybe = elimTV (\_ -> Nothing) (\_ k -> Just k)--vis_arg_kind_maybe :: VisFunArg -> Maybe Kind-vis_arg_kind_maybe (VisFADep tvb) = tvb_kind_maybe tvb-vis_arg_kind_maybe (VisFAAnon k)  = Just k--default_tvb :: TyVarBndrUnit -> TyVarBndrUnit-default_tvb tvb = elimTV (\n -> kindedTV n StarT) (\_ _ -> tvb) tvb--default_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) = tvb_kind_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 :: 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-      return $ firstMatch (if ns then find_type_name-                                 else find_value_name) infos--    -- These functions work over Named Infos so we can avoid performing-    -- tiresome pattern-matching to retrieve the name associated with each Info.-    find_type_name, find_value_name :: Named Info -> Maybe Name-    find_type_name (n, info) =-      case infoNameSpace info of-        TcClsName -> Just n-        VarName   -> Nothing-        DataName  -> Nothing--    find_value_name (n, info) =-      case infoNameSpace info of-        VarName   -> Just n-        DataName  -> Just n-        TcClsName -> Nothing---- | 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-            pure $ fmap infoNameSpace mb_info---- | Determine a name's 'NameSpace' from its 'Info'.-infoNameSpace :: Info -> NameSpace-infoNameSpace info =-  case info of-    ClassI{}     -> TcClsName-    TyConI{}     -> TcClsName-    FamilyI{}    -> TcClsName-    PrimTyConI{} -> TcClsName-    TyVarI{}     -> TcClsName--    ClassOpI{}   -> VarName-    VarI{}       -> VarName--    DataConI{}   -> DataName-#if __GLASGOW_HASKELL__ >= 801-    PatSynI{}    -> DataName-#endif+{- Language/Haskell/TH/Desugar/Reify.hs
+
+(c) Richard Eisenberg 2014
+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 Language.Haskell.TH.Desugar.Util as 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, 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, [TyVarBndrUnit], [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 [TyVarBndrUnit]
+mkExtraKindBinders k = do
+  k' <- runQ $ resolveTypeSynonyms k
+  let (fun_args, _) = unravelType k'
+      vis_fun_args  = filterVisFunArgs fun_args
+  mapM mk_tvb vis_fun_args
+  where
+    mk_tvb :: VisFunArg -> q TyVarBndrUnit
+    mk_tvb (VisFADep tvb) = return tvb
+    mk_tvb (VisFAAnon ki) = kindedTV <$> qNewName "a" <*> return ki
+
+-- | 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, Quasi, Fail.MonadFail
+#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 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 (map tvbToTANormalWithSig tvbs) cons
+  = Just info
+reifyInDec n decs (NewtypeD _ ty_name tvbs _mk con _)
+  | Just info <- maybeReifyCon n decs ty_name (map tvbToTANormalWithSig tvbs) [con]
+  = Just info
+reifyInDec n _decs (ClassD _ ty_name tvbs _ sub_decs)
+  | Just (n', ty) <- findType n sub_decs
+  = Just (n', ClassOpI n (quantifyClassMethodType ty_name tvbs True ty) ty_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 _ _ lhs _ cons _)
+  | (ConT ty_name, tys) <- unfoldType lhs
+  , Just info <- maybeReifyCon n decs ty_name tys cons
+  = Just info
+reifyInDec n decs (NewtypeInstD _ _ lhs _ con _)
+  | (ConT ty_name, tys) <- unfoldType lhs
+  , 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 (map TANormal tys) cons
+  = Just info
+reifyInDec n decs (NewtypeInstD _ ty_name tys _ con _)
+  | Just info <- maybeReifyCon n decs ty_name (map TANormal tys) [con]
+  = Just info
+#endif
+#if __GLASGOW_HASKELL__ >= 906
+reifyInDec n decs (TypeDataD ty_name tvbs _mk cons)
+  | Just info <- maybeReifyCon n decs ty_name (map tvbToTANormalWithSig tvbs) cons
+  = Just info
+#endif
+
+reifyInDec _ _ _ = Nothing
+
+maybeReifyCon :: Name -> [Dec] -> Name -> [TypeArg] -> [Con] -> Maybe (Named Info)
+maybeReifyCon n _decs ty_name ty_args 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 ->
+          ( changeTVFlags SpecifiedSpec h98_tvbs
+          , sel_ty
+          , h98_res_ty
+          )
+        RecSelGADT mb_con_tvbs sel_ty con_res_ty ->
+          let -- If the GADT constructor type signature explicitly quantifies
+              -- its type variables, make sure to use that same order in the
+              -- record selector's type.
+              con_tvbs' =
+                case mb_con_tvbs of
+                  Just con_tvbs -> con_tvbs
+                  Nothing ->
+                    changeTVFlags SpecifiedSpec $
+                    freeVariablesWellScoped [con_res_ty, sel_ty] in
+          ( con_tvbs'
+          , sel_ty
+          , con_res_ty
+          )
+
+    h98_tvbs   = freeVariablesWellScoped $
+                 map probablyWrongUnTypeArg ty_args
+    h98_res_ty = applyType (ConT ty_name) ty_args
+
+maybeReifyCon _ _ _ _ _ = Nothing
+
+#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.
+-}
+
+-- Reverse-engineer the type of a data constructor.
+con_to_type :: [TyVarBndrUnit] -- 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
+                                   (changeTVFlags SpecifiedSpec 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)
+
+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 cls_name 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 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
+  :: Name            -- ^ The class name.
+  -> [TyVarBndrUnit] -- ^ The class's type variable binders.
+  -> Bool            -- ^ If 'True', prepend a class predicate.
+  -> Type            -- ^ The method type.
+  -> Type
+quantifyClassMethodType cls_name cls_tvbs prepend meth_ty =
+  add_cls_cxt quantified_meth_ty
+  where
+    add_cls_cxt :: Type -> Type
+    add_cls_cxt
+      | prepend   = ForallT (changeTVFlags SpecifiedSpec all_cls_tvbs) cls_cxt
+      | otherwise = id
+
+    cls_cxt :: Cxt
+    cls_cxt = [foldl AppT (ConT cls_name) (map tvbToType cls_tvbs)]
+
+    quantified_meth_ty :: Type
+    quantified_meth_ty
+      | null meth_tvbs
+      = 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 = changeTVFlags SpecifiedSpec $
+                List.deleteFirstsBy ((==) `on` tvName)
+                  (freeVariablesWellScoped [meth_ty]) all_cls_tvbs
+
+    -- Explicitly quantify any kind variables bound by the class, if any.
+    all_cls_tvbs :: [TyVarBndrUnit]
+    all_cls_tvbs = freeVariablesWellScoped $ map tvbToTypeWithSig cls_tvbs
+
+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]
+
+---------------------------------
+-- 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 <|> tvb_kind_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 <- [tvb_kind_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 :: TyVarBndrUnit -> TyVarBndrUnit
+    ascribe_tf_tvb_kind tvb =
+      elimTV (\tvn -> kindedTV tvn $ fromMaybe StarT $ Map.lookup tvn cls_tvb_kind_map)
+             (\_ _ -> tvb)
+             tvb
+
+-- Data types have CUSKs when:
+--
+-- 1. All of their type variables have explicit kinds.
+-- 2. All kind variables in the result kind are explicitly quantified.
+datatype_kind :: [TyVarBndrUnit] -> Maybe Kind -> Maybe Kind
+datatype_kind 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 :: [TyVarBndrUnit] -> Maybe Kind
+class_kind tvbs = whenAlt (all tvb_is_kinded tvbs) $
+                  build_kind tvbs ConstraintT
+
+-- Open type families and data families always have CUSKs. Type variables
+-- without explicit kinds default to Type, as does the return kind if it
+-- is not specified.
+open_ty_fam_kind :: [TyVarBndrUnit] -> Maybe Kind -> Maybe Kind
+open_ty_fam_kind 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 :: [TyVarBndrUnit] -> 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 :: [TyVarBndrUnit] -> 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 :: [TyVarBndrUnit] -> Kind -> Maybe Kind
+build_kind arg_kinds res_kind =
+  fmap quantifyType $ fst $
+  foldr go (Just res_kind, Set.fromList (freeVariables res_kind)) arg_kinds
+  where
+    go :: TyVarBndrUnit -> (Maybe Kind, Set Name) -> (Maybe Kind, Set Name)
+    go tvb (res, res_fvs) =
+      elimTV (\n ->
+               ( if n `Set.member` res_fvs
+                 then forall_vis 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_vis tvb res
+                 else fmap (ArrowT `AppT` k `AppT`) res
+               , Set.fromList (freeVariables k) `Set.union` res_fvs
+               ))
+             tvb
+
+    forall_vis :: TyVarBndrUnit -> Maybe Kind -> Maybe Kind
+#if __GLASGOW_HASKELL__ >= 809
+    forall_vis tvb m_ki = fmap (ForallVisT [tvb]) m_ki
+      -- 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_vis _   _    = Nothing
+#endif
+
+tvb_is_kinded :: TyVarBndr_ flag -> Bool
+tvb_is_kinded = isJust . tvb_kind_maybe
+
+tvb_kind_maybe :: TyVarBndr_ flag -> Maybe Kind
+tvb_kind_maybe = elimTV (\_ -> Nothing) (\_ k -> Just k)
+
+vis_arg_kind_maybe :: VisFunArg -> Maybe Kind
+vis_arg_kind_maybe (VisFADep tvb) = tvb_kind_maybe tvb
+vis_arg_kind_maybe (VisFAAnon k)  = Just k
+
+default_tvb :: TyVarBndrUnit -> TyVarBndrUnit
+default_tvb tvb = elimTV (\n -> kindedTV n StarT) (\_ _ -> tvb) tvb
+
+default_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) = tvb_kind_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
+
+    find_value_name (n, info) = do
+      name_space <- lookupInfoNameSpace info
+      pure $ case name_space of
+        VarName   -> Just n
+        DataName  -> Just n
+        TcClsName -> Nothing
+
+-- | 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
+    VarI{}       -> pure VarName
+
+    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
@@ -1,145 +1,145 @@-{-# LANGUAGE CPP #-}---------------------------------------------------------------------------------- |--- 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----------------------------------------------------------------------------------module Language.Haskell.TH.Desugar.Subst (-  DSubst,--  -- * Capture-avoiding substitution-  substTy, substForallTelescope, substTyVarBndrs,-  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.Syntax-import Language.Haskell.TH.Desugar.Util---- | A substitution is just a map from names to types-type DSubst = M.Map Name DType---- | Capture-avoiding substitution on types-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--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')--substTyVarBndrs :: Quasi q => DSubst -> [DTyVarBndr flag]-                -> q (DSubst, [DTyVarBndr flag])-substTyVarBndrs = mapAccumLM substTvb--substTvb :: Quasi q => DSubst -> DTyVarBndr flag-         -> q (DSubst, DTyVarBndr flag)-substTvb vars (DPlainTV n flag) = do-  new_n <- qNewName (nameBase n)-  return (M.insert n (DVarT new_n) vars, DPlainTV new_n flag)-substTvb vars (DKindedTV n flag k) = do-  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-  -- this wrong.-matchTy ign (DSigT ty _ki) arg = case ign of-  YesIgnore -> matchTy ign ty arg-  NoIgnore  -> Nothing-  -- but we can safely ignore kind signatures on the target-matchTy ign pat (DSigT ty _ki) = matchTy ign pat ty-matchTy _   (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 CPP #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- 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
+--
+----------------------------------------------------------------------------
+
+module Language.Haskell.TH.Desugar.Subst (
+  DSubst,
+
+  -- * Capture-avoiding substitution
+  substTy, substForallTelescope, substTyVarBndrs,
+  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.Syntax
+import Language.Haskell.TH.Desugar.Util
+
+-- | A substitution is just a map from names to types
+type DSubst = M.Map Name DType
+
+-- | Capture-avoiding substitution on types
+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
+
+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')
+
+substTyVarBndrs :: Quasi q => DSubst -> [DTyVarBndr flag]
+                -> q (DSubst, [DTyVarBndr flag])
+substTyVarBndrs = mapAccumLM substTvb
+
+substTvb :: Quasi q => DSubst -> DTyVarBndr flag
+         -> q (DSubst, DTyVarBndr flag)
+substTvb vars (DPlainTV n flag) = do
+  new_n <- qNewName (nameBase n)
+  return (M.insert n (DVarT new_n) vars, DPlainTV new_n flag)
+substTvb vars (DKindedTV n flag k) = do
+  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
+  -- this wrong.
+matchTy ign (DSigT ty _ki) arg = case ign of
+  YesIgnore -> matchTy ign ty arg
+  NoIgnore  -> Nothing
+  -- but we can safely ignore kind signatures on the target
+matchTy ign pat (DSigT ty _ki) = matchTy ign pat ty
+matchTy _   (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/Sweeten.hs view
@@ -1,406 +1,416 @@-{- Language/Haskell/TH/Desugar/Sweeten.hs--(c) Richard Eisenberg 2013-rae@cs.brynmawr.edu--Converts desugared TH back into real TH.--}--{-# LANGUAGE CPP #-}-{-# LANGUAGE TemplateHaskellQuotes #-}---------------------------------------------------------------------------------- |--- Module      :  Language.Haskell.TH.Desugar.Sweeten--- Copyright   :  (C) 2014 Richard Eisenberg--- License     :  BSD-style (see LICENSE)--- Maintainer  :  Ryan Scott--- Stability   :  experimental--- Portability :  non-portable------ The functions in this module convert desugared Template Haskell back into--- proper Template Haskell.----------------------------------------------------------------------------------module Language.Haskell.TH.Desugar.Sweeten (-  expToTH, matchToTH, patToTH, decsToTH, decToTH,-  letDecToTH, typeToTH,--  conToTH, foreignToTH, pragmaToTH, ruleBndrToTH,-  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.Datatype.TyVarBndr--import Language.Haskell.TH.Desugar.AST-import Language.Haskell.TH.Desugar.Core (DTypeArg(..))-import Language.Haskell.TH.Desugar.Util--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)-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--matchToTH :: DMatch -> Match-matchToTH (DMatch pat exp) = Match (patToTH pat) (NormalB (expToTH exp)) []--patToTH :: DPat -> Pat-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--decsToTH :: [DDec] -> [Dec]-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 _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)-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)-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-  in dataInstDecToTH ndc cxt mtvbs lhs mk derivings-#if __GLASGOW_HASKELL__ >= 807-decToTH (DTySynInstD eqn) = TySynInstD (snd $ tySynEqnToTH eqn)-#else-decToTH (DTySynInstD eqn) =-  let (n, eqn') = tySynEqnToTH eqn in-  TySynInstD n eqn'-#endif-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-decToTH DPatSynD{}    = patSynErr-decToTH DPatSynSigD{} = patSynErr-#endif-#if __GLASGOW_HASKELL__ >= 809-decToTH (DKiSigD n ki) = KiSigD n (typeToTH ki)-#else-decToTH (DKiSigD {})   =-  error "Standalone kind signatures supported only in GHC 8.10+"-#endif-#if __GLASGOW_HASKELL__ >= 903-decToTH (DDefaultD tys) = DefaultD (map typeToTH tys)-#else-decToTH (DDefaultD{})   =-  error "Default declarations supported only in GHC 9.4+"-#endif--#if __GLASGOW_HASKELL__ < 801-patSynErr :: a-patSynErr = error "Pattern synonyms supported only in GHC 8.2+"-#endif---- | 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-      NewtypeInstD (cxtToTH cxt) _n _lhs_args (fmap typeToTH _mk) (conToTH con)-                   (concatMap derivClauseToTH derivings)-#endif--    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)---- | 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 (DPragmaD prag)      = PragmaD (pragmaToTH prag)--conToTH :: DCon -> Con-conToTH (DCon [] [] n (DNormalC _ stys) rty) =-  GadtC [n] (map (second typeToTH) stys) (typeToTH rty)-conToTH (DCon [] [] n (DRecC vstys) rty) =-  RecGadtC [n] (map (thirdOf3 typeToTH) vstys) (typeToTH rty)--- 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 -> Pragma-pragmaToTH (DInlineP n inl rm phases) = InlineP n inl rm phases-pragmaToTH (DSpecialiseP n ty m_inl phases) =-  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 (DRuleP str _ rbs lhs rhs phases) =-  RuleP str (map ruleBndrToTH rbs) (expToTH lhs) (expToTH rhs) phases-#endif-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 (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--ruleBndrToTH :: DRuleBndr -> RuleBndr-ruleBndrToTH (DRuleVar n) = RuleVar n-ruleBndrToTH (DTypedRuleVar n ty) = TypedRuleVar n (typeToTH ty)--#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 -> (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--- 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-typeToTH DWildCardT = WildCardT-#if __GLASGOW_HASKELL__ >= 807-typeToTH (DAppKindT t k)        = AppKindT (typeToTH t) (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.-typeToTH (DAppKindT t _)        = typeToTH t-#endif--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--#if __GLASGOW_HASKELL__ >= 801-derivClauseToTH :: DDerivClause -> [DerivClause]-derivClauseToTH (DDerivClause mds cxt) =-  [DerivClause (fmap derivStrategyToTH mds) (cxtToTH cxt)]-#else-derivClauseToTH :: DDerivClause -> Cxt-derivClauseToTH (DDerivClause _ cxt) = cxtToTH cxt-#endif--#if __GLASGOW_HASKELL__ >= 801-derivStrategyToTH :: DDerivStrategy -> DerivStrategy-derivStrategyToTH DStockStrategy    = StockStrategy-derivStrategyToTH DAnyclassStrategy = AnyclassStrategy-derivStrategyToTH DNewtypeStrategy  = NewtypeStrategy-#if __GLASGOW_HASKELL__ >= 805-derivStrategyToTH (DViaStrategy ty) = ViaStrategy (typeToTH ty)-#else-derivStrategyToTH (DViaStrategy _)  = error "DerivingVia supported only in GHC 8.6+"-#endif-#endif--#if __GLASGOW_HASKELL__ >= 801-patSynDirToTH :: DPatSynDir -> PatSynDir-patSynDirToTH DUnidir              = Unidir-patSynDirToTH DImplBidir           = ImplBidir-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-  | n == ''(~)                  = EqualityT-  | n == '[]                    = PromotedNilT-  | n == '(:)                   = PromotedConsT-  | 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--typeArgToTH :: DTypeArg -> TypeArg-typeArgToTH (DTANormal t) = TANormal (typeToTH t)-typeArgToTH (DTyArg k)    = TyArg    (typeToTH k)+{- Language/Haskell/TH/Desugar/Sweeten.hs
+
+(c) Richard Eisenberg 2013
+rae@cs.brynmawr.edu
+
+Converts desugared TH back into real TH.
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TemplateHaskellQuotes #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Language.Haskell.TH.Desugar.Sweeten
+-- Copyright   :  (C) 2014 Richard Eisenberg
+-- License     :  BSD-style (see LICENSE)
+-- Maintainer  :  Ryan Scott
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- The functions in this module convert desugared Template Haskell back into
+-- proper Template Haskell.
+--
+----------------------------------------------------------------------------
+
+module Language.Haskell.TH.Desugar.Sweeten (
+  expToTH, matchToTH, patToTH, decsToTH, decToTH,
+  letDecToTH, typeToTH,
+
+  conToTH, foreignToTH, pragmaToTH, ruleBndrToTH,
+  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 (Extension(..), cxt)
+import Language.Haskell.TH.Datatype.TyVarBndr
+
+import Language.Haskell.TH.Desugar.AST
+import Language.Haskell.TH.Desugar.Core (DTypeArg(..))
+import Language.Haskell.TH.Desugar.Util
+
+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)
+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
+
+matchToTH :: DMatch -> Match
+matchToTH (DMatch pat exp) = Match (patToTH pat) (NormalB (expToTH exp)) []
+
+patToTH :: DPat -> Pat
+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
+
+decsToTH :: [DDec] -> [Dec]
+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 _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)
+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)
+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 (DTySynInstD eqn) =
+  let (n, eqn') = tySynEqnToTH eqn in
+  TySynInstD n eqn'
+#endif
+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
+decToTH DPatSynD{}    = patSynErr
+decToTH DPatSynSigD{} = patSynErr
+#endif
+#if __GLASGOW_HASKELL__ >= 809
+decToTH (DKiSigD n ki) = KiSigD n (typeToTH ki)
+#else
+decToTH (DKiSigD {})   =
+  error "Standalone kind signatures supported only in GHC 8.10+"
+#endif
+#if __GLASGOW_HASKELL__ >= 903
+decToTH (DDefaultD tys) = DefaultD (map typeToTH tys)
+#else
+decToTH (DDefaultD{})   =
+  error "Default declarations supported only in GHC 9.4+"
+#endif
+#if __GLASGOW_HASKELL__ >= 906
+decToTH (DDataD TypeData _cxt n tvbs mk cons _derivings) =
+  -- NB: Due to the invariants on 'DDataD' and 'TypeData', _cxt and _derivings
+  -- will be empty.
+  TypeDataD n (map tvbToTH tvbs) (fmap typeToTH mk) (map conToTH cons)
+#else
+decToTH (DDataD TypeData _cxt _n _tvbs _mk _cons _derivings) =
+  error "`type data` declarations supported only in GHC 9.6+"
+#endif
+
+#if __GLASGOW_HASKELL__ < 801
+patSynErr :: a
+patSynErr = error "Pattern synonyms supported only in GHC 8.2+"
+#endif
+
+-- | 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
+      NewtypeInstD (cxtToTH cxt) _n _lhs_args (fmap typeToTH _mk) (conToTH con)
+                   (concatMap derivClauseToTH derivings)
+#endif
+
+    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)
+
+-- | 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 (DPragmaD prag)      = PragmaD (pragmaToTH prag)
+
+conToTH :: DCon -> Con
+conToTH (DCon [] [] n (DNormalC _ stys) rty) =
+  GadtC [n] (map (second typeToTH) stys) (typeToTH rty)
+conToTH (DCon [] [] n (DRecC vstys) rty) =
+  RecGadtC [n] (map (thirdOf3 typeToTH) vstys) (typeToTH rty)
+-- 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 -> Pragma
+pragmaToTH (DInlineP n inl rm phases) = InlineP n inl rm phases
+pragmaToTH (DSpecialiseP n ty m_inl phases) =
+  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 (DRuleP str _ rbs lhs rhs phases) =
+  RuleP str (map ruleBndrToTH rbs) (expToTH lhs) (expToTH rhs) phases
+#endif
+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 (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
+
+ruleBndrToTH :: DRuleBndr -> RuleBndr
+ruleBndrToTH (DRuleVar n) = RuleVar n
+ruleBndrToTH (DTypedRuleVar n ty) = TypedRuleVar n (typeToTH ty)
+
+#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 -> (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
+-- 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
+typeToTH DWildCardT = WildCardT
+#if __GLASGOW_HASKELL__ >= 807
+typeToTH (DAppKindT t k)        = AppKindT (typeToTH t) (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.
+typeToTH (DAppKindT t _)        = typeToTH t
+#endif
+
+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
+
+#if __GLASGOW_HASKELL__ >= 801
+derivClauseToTH :: DDerivClause -> [DerivClause]
+derivClauseToTH (DDerivClause mds cxt) =
+  [DerivClause (fmap derivStrategyToTH mds) (cxtToTH cxt)]
+#else
+derivClauseToTH :: DDerivClause -> Cxt
+derivClauseToTH (DDerivClause _ cxt) = cxtToTH cxt
+#endif
+
+#if __GLASGOW_HASKELL__ >= 801
+derivStrategyToTH :: DDerivStrategy -> DerivStrategy
+derivStrategyToTH DStockStrategy    = StockStrategy
+derivStrategyToTH DAnyclassStrategy = AnyclassStrategy
+derivStrategyToTH DNewtypeStrategy  = NewtypeStrategy
+#if __GLASGOW_HASKELL__ >= 805
+derivStrategyToTH (DViaStrategy ty) = ViaStrategy (typeToTH ty)
+#else
+derivStrategyToTH (DViaStrategy _)  = error "DerivingVia supported only in GHC 8.6+"
+#endif
+#endif
+
+#if __GLASGOW_HASKELL__ >= 801
+patSynDirToTH :: DPatSynDir -> PatSynDir
+patSynDirToTH DUnidir              = Unidir
+patSynDirToTH DImplBidir           = ImplBidir
+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
+  | n == ''(~)                  = EqualityT
+  | n == '[]                    = PromotedNilT
+  | n == '(:)                   = PromotedConsT
+  | 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
+
+typeArgToTH :: DTypeArg -> TypeArg
+typeArgToTH (DTANormal t) = TANormal (typeToTH t)
+typeArgToTH (DTyArg k)    = TyArg    (typeToTH k)
Language/Haskell/TH/Desugar/Util.hs view
@@ -1,534 +1,547 @@-{- Language/Haskell/TH/Desugar/Util.hs--(c) Richard Eisenberg 2013-rae@cs.brynmawr.edu--Utility functions for th-desugar package.--}--{-# LANGUAGE CPP, DeriveDataTypeable, RankNTypes, ScopedTypeVariables,-             TupleSections, AllowAmbiguousTypes, TemplateHaskellQuotes,-             TypeApplications #-}--module Language.Haskell.TH.Desugar.Util (-  newUniqueName,-  impossible,-  nameOccursIn, allNamesIn, mkTypeName, mkDataName, mkNameWith, isDataName,-  stripVarP_maybe, extractBoundNamesStmt,-  concatMapM, mapAccumLM, mapMaybeM, expectJustM,-  stripPlainTV_maybe,-  thirdOf3, splitAtList, extractBoundNamesDec,-  extractBoundNamesPat,-  tvbToType, tvbToTypeWithSig, tvbToTANormalWithSig,-  nameMatches, thdOf3, liftFst, liftSnd, firstMatch,-  unboxedSumDegree_maybe, unboxedSumNameDegree_maybe,-  tupleDegree_maybe, tupleNameDegree_maybe, unboxedTupleDegree_maybe,-  unboxedTupleNameDegree_maybe, splitTuple_maybe,-  topEverywhereM, isInfixDataCon,-  isTypeKindName, typeKindName,-  unSigType, unfoldType, ForallTelescope(..), FunArgs(..), VisFunArg(..),-  filterVisFunArgs, ravelType, unravelType,-  TypeArg(..), applyType, filterTANormals, probablyWrongUnTypeArg,-  bindIP-  ) where--import Prelude hiding (mapM, foldl, concatMap, any)--import Language.Haskell.TH hiding ( cxt )-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.Syntax--import qualified Control.Monad.Fail as Fail-import Data.Foldable-import qualified Data.Kind as Kind-import Data.Generics hiding ( Fixity )-import Data.Traversable-import Data.Maybe-import GHC.Classes ( IP )-import Unsafe.Coerce ( unsafeCoerce )--------------------------------------------- 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)---- | 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)---- | Convert a 'TyVarBndr' into a 'TypeArg' (specifically, a 'TANormal'),--- preserving the kind signature (if it has one).-tvbToTANormalWithSig :: TyVarBndr_ flag -> TypeArg-tvbToTANormalWithSig = TANormal . tvbToTypeWithSig---- | Do two names name the same thing?-nameMatches :: Name -> Name -> Bool-nameMatches n1@(Name occ1 flav1) n2@(Name occ2 flav2)-  | 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 sum-unboxedSumDegree_maybe :: String -> Maybe Int-unboxedSumDegree_maybe = unboxedSumTupleDegree_maybe '|'---- | Extract the degree of an unboxed sum name-unboxedSumNameDegree_maybe :: Name -> Maybe Int-unboxedSumNameDegree_maybe = unboxedSumDegree_maybe . nameBase---- | 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-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---- | 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)])--- @-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-#if __GLASGOW_HASKELL__ >= 807-    go acc (AppKindT ty ki) = go (TyArg ki:acc) ty-#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---- | 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--------------------------------------------- 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 -> 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.-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@-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--------------------------------------------- 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---- | 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+{- Language/Haskell/TH/Desugar/Util.hs
+
+(c) Richard Eisenberg 2013
+rae@cs.brynmawr.edu
+
+Utility functions for th-desugar package.
+-}
+
+{-# LANGUAGE CPP, DeriveDataTypeable, DeriveGeneric, DeriveLift, RankNTypes,
+             ScopedTypeVariables, TupleSections, AllowAmbiguousTypes,
+             TemplateHaskellQuotes, TypeApplications #-}
+
+module Language.Haskell.TH.Desugar.Util (
+  newUniqueName,
+  impossible,
+  nameOccursIn, allNamesIn, mkTypeName, mkDataName, mkNameWith, isDataName,
+  stripVarP_maybe, extractBoundNamesStmt,
+  concatMapM, mapAccumLM, mapMaybeM, expectJustM,
+  stripPlainTV_maybe,
+  thirdOf3, splitAtList, extractBoundNamesDec,
+  extractBoundNamesPat,
+  tvbToType, tvbToTypeWithSig, tvbToTANormalWithSig,
+  nameMatches, thdOf3, liftFst, liftSnd, firstMatch, firstMatchM,
+  unboxedSumDegree_maybe, unboxedSumNameDegree_maybe,
+  tupleDegree_maybe, tupleNameDegree_maybe, unboxedTupleDegree_maybe,
+  unboxedTupleNameDegree_maybe, splitTuple_maybe,
+  topEverywhereM, isInfixDataCon,
+  isTypeKindName, typeKindName,
+  unSigType, unfoldType, ForallTelescope(..), FunArgs(..), VisFunArg(..),
+  filterVisFunArgs, ravelType, unravelType,
+  TypeArg(..), applyType, filterTANormals, probablyWrongUnTypeArg,
+  bindIP,
+  DataFlavor(..)
+  ) where
+
+import Prelude hiding (mapM, foldl, concatMap, any)
+
+import Language.Haskell.TH hiding ( cxt )
+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.Syntax
+
+import qualified Control.Monad.Fail as Fail
+import Data.Foldable
+import qualified Data.Kind as Kind
+import Data.Generics ( Data, Typeable, everything, extM, gmapM, mkQ )
+import Data.Traversable
+import Data.Maybe
+import GHC.Classes ( IP )
+import GHC.Generics ( Generic )
+import Unsafe.Coerce ( unsafeCoerce )
+
+----------------------------------------
+-- 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)
+
+-- | 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)
+
+-- | Convert a 'TyVarBndr' into a 'TypeArg' (specifically, a 'TANormal'),
+-- preserving the kind signature (if it has one).
+tvbToTANormalWithSig :: TyVarBndr_ flag -> TypeArg
+tvbToTANormalWithSig = TANormal . tvbToTypeWithSig
+
+-- | Do two names name the same thing?
+nameMatches :: Name -> Name -> Bool
+nameMatches n1@(Name occ1 flav1) n2@(Name occ2 flav2)
+  | 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 sum
+unboxedSumDegree_maybe :: String -> Maybe Int
+unboxedSumDegree_maybe = unboxedSumTupleDegree_maybe '|'
+
+-- | Extract the degree of an unboxed sum name
+unboxedSumNameDegree_maybe :: Name -> Maybe Int
+unboxedSumNameDegree_maybe = unboxedSumDegree_maybe . nameBase
+
+-- | 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
+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
+
+-- | 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)])
+-- @
+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
+#if __GLASGOW_HASKELL__ >= 807
+    go acc (AppKindT ty ki) = go (TyArg ki:acc) ty
+#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
+
+-- | 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
+
+----------------------------------------
+-- 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 -> 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.
+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@
+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
+
+----------------------------------------
+-- 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,106 +1,106 @@-`th-desugar` Package-====================--[![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.-This desugaring discards surface syntax information (such as the use of infix-operators) but retains the original meaning of the TH code. The intended use-of this package is as a preprocessor for more advanced code manipulation-tools. Note that the input to any of the `ds...` functions should be produced-from a TH quote, using the syntax `[| ... |]`. If the input to these functions-is a hand-coded TH syntax tree, the results may be unpredictable. In-particular, it is likely that promoted datatypes will not work as expected.--One explicit goal of this package is to reduce the burden of supporting multiple-GHC / TH versions. Thus, the desugared language is the same across all GHC versions,-and any inconsistencies are handled internally.--The package was designed for use with the `singletons` package, so some design-decisions are based on that use case, when more than one design choice was-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--------------------## 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).+`th-desugar` Package
+====================
+
+[![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.
+This desugaring discards surface syntax information (such as the use of infix
+operators) but retains the original meaning of the TH code. The intended use
+of this package is as a preprocessor for more advanced code manipulation
+tools. Note that the input to any of the `ds...` functions should be produced
+from a TH quote, using the syntax `[| ... |]`. If the input to these functions
+is a hand-coded TH syntax tree, the results may be unpredictable. In
+particular, it is likely that promoted datatypes will not work as expected.
+
+One explicit goal of this package is to reduce the burden of supporting multiple
+GHC / TH versions. Thus, the desugared language is the same across all GHC versions,
+and any inconsistencies are handled internally.
+
+The package was designed for use with the `singletons` package, so some design
+decisions are based on that use case, when more than one design choice was
+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
+-----------------
+
+## 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).
Setup.hs view
@@ -1,2 +1,2 @@-import Distribution.Simple-main = defaultMain+import Distribution.Simple
+main = defaultMain
Test/Dec.hs view
@@ -1,54 +1,54 @@-{- Tests for the th-desugar package--(c) Richard Eisenberg 2013-rae@cs.brynmawr.edu--}--{-# LANGUAGE TemplateHaskell, GADTs, PolyKinds, TypeFamilies,-             MultiParamTypeClasses, FunctionalDependencies,-             FlexibleInstances, DataKinds, CPP, RankNTypes,-             StandaloneDeriving, DefaultSignatures,-             ConstraintKinds, RoleAnnotations, DeriveAnyClass #-}--{-# OPTIONS_GHC -Wno-orphans -Wno-name-shadowing-                -Wno-redundant-constraints #-}--module Dec where--import qualified Splices as S-import Splices ( unqualify )--$(S.dectest1)-$(S.dectest2)-$(S.dectest3)-$(S.dectest4)-$(S.dectest5)-$(S.dectest6)-$(S.dectest7)-$(S.dectest8)-$(S.dectest9)-$(S.dectest10)-$(S.dectest11)-$(S.dectest12)-$(S.dectest13)-$(S.dectest14)--$(S.dectest15)--#if __GLASGOW_HASKELL__ >= 802-$(S.dectest16)-$(S.dectest17)-#endif--#if __GLASGOW_HASKELL__ >= 809-$(S.dectest18)-#endif--$(fmap unqualify S.instance_test)--$(fmap unqualify S.imp_inst_test1)-$(fmap unqualify S.imp_inst_test2)-$(fmap unqualify S.imp_inst_test3)-$(fmap unqualify S.imp_inst_test4)--$(S.rec_sel_test)+{- Tests for the th-desugar package
+
+(c) Richard Eisenberg 2013
+rae@cs.brynmawr.edu
+-}
+
+{-# LANGUAGE TemplateHaskell, GADTs, PolyKinds, TypeFamilies,
+             MultiParamTypeClasses, FunctionalDependencies,
+             FlexibleInstances, DataKinds, CPP, RankNTypes,
+             StandaloneDeriving, DefaultSignatures,
+             ConstraintKinds, RoleAnnotations, DeriveAnyClass #-}
+
+{-# OPTIONS_GHC -Wno-orphans -Wno-name-shadowing
+                -Wno-redundant-constraints #-}
+
+module Dec where
+
+import qualified Splices as S
+import Splices ( unqualify )
+
+$(S.dectest1)
+$(S.dectest2)
+$(S.dectest3)
+$(S.dectest4)
+$(S.dectest5)
+$(S.dectest6)
+$(S.dectest7)
+$(S.dectest8)
+$(S.dectest9)
+$(S.dectest10)
+$(S.dectest11)
+$(S.dectest12)
+$(S.dectest13)
+$(S.dectest14)
+
+$(S.dectest15)
+
+#if __GLASGOW_HASKELL__ >= 802
+$(S.dectest16)
+$(S.dectest17)
+#endif
+
+#if __GLASGOW_HASKELL__ >= 809
+$(S.dectest18)
+#endif
+
+$(fmap unqualify S.instance_test)
+
+$(fmap unqualify S.imp_inst_test1)
+$(fmap unqualify S.imp_inst_test2)
+$(fmap unqualify S.imp_inst_test3)
+$(fmap unqualify S.imp_inst_test4)
+
+$(S.rec_sel_test)
Test/DsDec.hs view
@@ -1,86 +1,86 @@-{- Tests for the th-desugar package--(c) Richard Eisenberg 2013-rae@cs.brynmawr.edu--}--{-# LANGUAGE TemplateHaskell, GADTs, PolyKinds, TypeFamilies,-             MultiParamTypeClasses, FunctionalDependencies,-             FlexibleInstances, DataKinds, CPP, RankNTypes,-             StandaloneDeriving, DefaultSignatures,-             ConstraintKinds, RoleAnnotations, DeriveAnyClass #-}-#if __GLASGOW_HASKELL__ >= 801-{-# LANGUAGE DerivingStrategies #-}-#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.Desugar-import Language.Haskell.TH.Syntax ( qReport )--import Control.Monad--$(dsDecSplice S.dectest1)-$(dsDecSplice S.dectest2)-$(dsDecSplice S.dectest3)-$(dsDecSplice S.dectest4)-$(dsDecSplice S.dectest5)-$(dsDecSplice S.dectest6)-$(dsDecSplice S.dectest7)-$(dsDecSplice S.dectest8)-$(dsDecSplice S.dectest9)--$(dsDecSplice (fmap unqualify S.instance_test))--$(dsDecSplice (fmap unqualify S.imp_inst_test1))-$(dsDecSplice (fmap unqualify S.imp_inst_test2))-$(dsDecSplice (fmap unqualify S.imp_inst_test3))-$(dsDecSplice (fmap unqualify S.imp_inst_test4))--$(dsDecSplice S.dectest10)--$(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--$(do decs <- S.rec_sel_test-     withLocalDeclarations decs $ do-       [DDataD nd [] name [DPlainTV tvbName ()] 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 ()] k (map unrecord cons) []]-       return (decsToTH plaindata ++ map letDecToTH recsels))+{- Tests for the th-desugar package
+
+(c) Richard Eisenberg 2013
+rae@cs.brynmawr.edu
+-}
+
+{-# LANGUAGE TemplateHaskell, GADTs, PolyKinds, TypeFamilies,
+             MultiParamTypeClasses, FunctionalDependencies,
+             FlexibleInstances, DataKinds, CPP, RankNTypes,
+             StandaloneDeriving, DefaultSignatures,
+             ConstraintKinds, RoleAnnotations, DeriveAnyClass #-}
+#if __GLASGOW_HASKELL__ >= 801
+{-# LANGUAGE DerivingStrategies #-}
+#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.Desugar
+import Language.Haskell.TH.Syntax ( qReport )
+
+import Control.Monad
+
+$(dsDecSplice S.dectest1)
+$(dsDecSplice S.dectest2)
+$(dsDecSplice S.dectest3)
+$(dsDecSplice S.dectest4)
+$(dsDecSplice S.dectest5)
+$(dsDecSplice S.dectest6)
+$(dsDecSplice S.dectest7)
+$(dsDecSplice S.dectest8)
+$(dsDecSplice S.dectest9)
+
+$(dsDecSplice (fmap unqualify S.instance_test))
+
+$(dsDecSplice (fmap unqualify S.imp_inst_test1))
+$(dsDecSplice (fmap unqualify S.imp_inst_test2))
+$(dsDecSplice (fmap unqualify S.imp_inst_test3))
+$(dsDecSplice (fmap unqualify S.imp_inst_test4))
+
+$(dsDecSplice S.dectest10)
+
+$(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
+
+$(do decs <- S.rec_sel_test
+     withLocalDeclarations decs $ do
+       [DDataD nd [] name [DPlainTV tvbName ()] 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 ()] k (map unrecord cons) []]
+       return (decsToTH plaindata ++ map letDecToTH recsels))
Test/ReifyTypeCUSKs.hs view
@@ -1,118 +1,121 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeInType #-}-#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))+{-# 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
@@ -1,76 +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)+{-# 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,682 +1,858 @@-{- Tests for the th-desugar package--(c) Richard Eisenberg 2013-rae@cs.brynmawr.edu--}--{-# LANGUAGE TemplateHaskell, UnboxedTuples, ParallelListComp, CPP,-             RankNTypes, TypeFamilies,-             DataKinds, ConstraintKinds, PolyKinds, MultiParamTypeClasses,-             FlexibleInstances, ExistentialQuantification,-             ScopedTypeVariables, GADTs, ViewPatterns, TupleSections,-             TypeOperators, PartialTypeSignatures, PatternSynonyms,-             TypeApplications #-}-{-# 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__ >= 805-{-# LANGUAGE DerivingVia #-}-{-# LANGUAGE QuantifiedConstraints #-}-#endif--#if __GLASGOW_HASKELL__ >= 809-{-# LANGUAGE StandaloneKindSignatures #-}-#endif--module Main where--import Prelude hiding ( exp )--import Test.HUnit-import Test.Hspec hiding ( runIO )--- import Test.Hspec.HUnit--import Splices-import qualified DsDec-import qualified Dec-import Dec ( RecordSel )-import ReifyTypeCUSKs-import ReifyTypeSigs-import T159Decs ( t159A, t159B )-import Language.Haskell.TH.Desugar-import qualified Language.Haskell.TH.Desugar.OSet as OS-import Language.Haskell.TH.Desugar.Expand  ( expandUnsoundly )-import Language.Haskell.TH-import qualified Language.Haskell.TH.Syntax as Syn ( lift )--import Control.Exception ( ErrorCall )-import Control.Monad--import qualified Data.Map as M-import Data.Proxy--#if __GLASGOW_HASKELL__ >= 900-import Prelude as P-#endif---- |--- Convert a HUnit test suite to a spec.  This can be used to run existing--- HUnit tests with Hspec.-fromHUnitTest :: Test -> Spec--- copied from https://github.com/hspec/hspec/blob/master/hspec-contrib/src/Test/Hspec/Contrib/HUnit.hs-fromHUnitTest t = case t of-  TestList xs -> mapM_ go xs-  x -> go x-  where-    go :: Test -> Spec-    go t_ = case t_ of-      TestLabel s (TestCase e) -> it s e-      TestLabel s (TestList xs) -> describe s (mapM_ go xs)-      TestLabel s x -> describe s (go x)-      TestList xs -> describe "<unlabeled>" (mapM_ go xs)-      TestCase e -> it "<unlabeled>" e--tests :: Test-tests = test [ "sections" ~: $test1_sections  @=? $(dsSplice test1_sections)-             , "lampats"  ~: $test2_lampats   @=? $(dsSplice test2_lampats)-             , "lamcase"  ~: $test3_lamcase   @=? $(dsSplice test3_lamcase)--- Must fix nested pattern-matching for this to work. Argh.---           , "tuples"   ~: $test4_tuples    @=? $(dsSplice test4_tuples)-             , "ifs"      ~: $test5_ifs       @=? $(dsSplice test5_ifs)-             , "ifs2"     ~: $test6_ifs2      @=? $(dsSplice test6_ifs2)-             , "let"      ~: $test7_let       @=? $(dsSplice test7_let)-             , "case"     ~: $test8_case      @=? $(dsSplice test8_case)-             , "do"       ~: $test9_do        @=? $(dsSplice test9_do)-             , "comp"     ~: $test10_comp     @=? $(dsSplice test10_comp)-             , "parcomp"  ~: $test11_parcomp  @=? $(dsSplice test11_parcomp)-             , "parcomp2" ~: $test12_parcomp2 @=? $(dsSplice test12_parcomp2)-             , "sig"      ~: $test13_sig      @=? $(dsSplice test13_sig)-             , "record"   ~: $test14_record   @=? $(dsSplice test14_record)-             , "litp"     ~: $test15_litp     @=? $(dsSplice test15_litp)-             , "tupp"     ~: $test16_tupp     @=? $(dsSplice test16_tupp)-             , "infixp"   ~: $test17_infixp   @=? $(dsSplice test17_infixp)-             , "tildep"   ~: $test18_tildep   @=? $(dsSplice test18_tildep)-             , "bangp"    ~: $test19_bangp    @=? $(dsSplice test19_bangp)-             , "asp"      ~: $test20_asp      @=? $(dsSplice test20_asp)-             , "wildp"    ~: $test21_wildp    @=? $(dsSplice test21_wildp)-             , "listp"    ~: $test22_listp    @=? $(dsSplice test22_listp)-#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)-             , "kisig"    ~: $test27_kisig    @=? $(dsSplice test27_kisig)-             , "tupt"     ~: $test28_tupt     @=? $(dsSplice test28_tupt)-             , "listt"    ~: $test29_listt    @=? $(dsSplice test29_listt)-             , "promoted" ~: $test30_promoted @=? $(dsSplice test30_promoted)-             , "constraint" ~: $test31_constraint @=? $(dsSplice test31_constraint)-             , "tylit"    ~: $test32_tylit    @=? $(dsSplice test32_tylit)-             , "tvbs"     ~: $test33_tvbs     @=? $(dsSplice test33_tvbs)-             , "let_as"   ~: $test34_let_as   @=? $(dsSplice test34_let_as)-             , "pred"     ~: $test37_pred     @=? $(dsSplice test37_pred)-             , "pred2"    ~: $test38_pred2    @=? $(dsSplice test38_pred2)-             , "eq"       ~: $test39_eq       @=? $(dsSplice test39_eq)-             , "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-             ]--test35a = $test35_expand-test35b = $(test35_expand >>= dsExp >>= expand >>= return . expToTH)-test36a = $test36_expand-test36b = $(test36_expand >>= dsExp >>= expand >>= return . expToTH)-test_e3a = $test_expand3-test_e3b = $(test_expand3 >>= dsExp >>= expand >>= return . expToTH)-test_e4a = $test_expand4-test_e4b = $(test_expand4 >>= dsExp >>= expand >>= return . expToTH)-test_e5a = $test_expand5-test_e5b = $(test_expand5 >>= dsExp >>= expand >>= return . expToTH)-test_e6a = $test_expand6-test_e6b = $(test_expand6 >>= dsExp >>= expand >>= return . expToTH)-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)-  -- 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--test_expand :: Bool-test_expand = and [ hasSameType test35a test35b-                  , hasSameType test36a test36b-                  , hasSameType test_e3a test_e3b-                  , hasSameType test_e4a test_e4b-                  , 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]-test_dec = $(do bools <- mapM testDecSplice dec_test_nums-                return $ ListE bools)--$( do fuzzType <- mkTypeName "Fuzz"-      fuzzData <- mkDataName "Fuzz"-      let tySynDecs = TySynD (mkName "FuzzSyn") [] (ConT fuzzType)-          dataSynDecs = TySynD (mkName "FuzzDataSyn") [] (ConT fuzzData)-      fuzzDecs <- [d| data Fuzz = Fuzz |]-      return $ tySynDecs : dataSynDecs : fuzzDecs )--test_mkName :: Bool-test_mkName = and [ hasSameType (Proxy :: Proxy FuzzSyn) (Proxy :: Proxy Fuzz)-                  , hasSameType (Proxy :: Proxy FuzzDataSyn) (Proxy :: Proxy 'Fuzz) ]--test_bug8884 :: Bool-test_bug8884 = $(do info <- reify ''Poly-                    dinfo@(DTyConI (DOpenTypeFamilyD (DTypeFamilyHead _name _tvbs (DKindSig resK) _ann))-                                   (Just [DTySynInstD (DTySynEqn _ lhs _rhs)]))-                      <- dsInfo info-                    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:"-                          putStrLn $ show dinfo-                        [| False |] )--flatten_dvald :: Bool-flatten_dvald = let s1 = $(flatten_dvald_test)-                    s2 = $(do expr <- flatten_dvald_test-                              DLetE ddecs dexpr <- dsExp expr-                              flattened <- fmap concat $ mapM flattenDValD ddecs-                              return $ expToTH $ DLetE flattened dexpr ) in-                s1 == s2--test_rec_sels :: Bool-test_rec_sels = and $(do bools <- mapM testRecSelTypes [1..rec_sel_test_num_sels]-                         return $ ListE bools)--test_standalone_deriving :: Bool-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_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 () (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 ()]-                                            (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 ()] []-                            [ DLetDec (DInfixD fixity m)-                            , DLetDec (DSigD m (DVarT a))-                            ]-                          ]-           expected = Just fixity-       actual <- withLocalDeclarations decs (reifyFixityWithLocals m)-       expected `eqTHSplice` actual)--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---- 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 $-                                     mapM reifyWithLocals_maybe reifyDecsNames-                          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-              -- reifications below. Weird.--normal_reifications :: [String]-normal_reifications = $(do infos <- mapM reify reifyDecsNames-                           ListE <$> mapM (Syn.lift . show . Just)-                                          (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)-zipWith3M _ _ _ _ = return []--simplCase :: [Bool]-simplCase = $( do exps <- sequence simplCaseTests-                  dexps <- mapM dsExp exps-                  sexps <- mapM scExp dexps-                  bools <- zipWithM (\e1 e2 -> [| $(return e1) == $(return e2) |])-                    exps (map sweeten sexps)-                  return $ ListE bools )--test_roundtrip :: [Bool]-test_roundtrip = $( do exprs <- sequence test_exprs-                       ds_exprs1 <- mapM dsExp exprs-                       let th_exprs1 = map expToTH ds_exprs1-                       ds_exprs2 <- mapM dsExp th_exprs1-                       let th_exprs2 = map expToTH ds_exprs2-                       ds_exprs3 <- mapM dsExp th_exprs2-                       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-  , 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))-  ]-  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-    it "compiles" $ True-    it "expands"  $ test_expand--    zipWithM (\num success -> it ("passes dec test " ++ show num) success)-      dec_test_nums test_dec--    -- instance test 1 is part of dectest 6.-    it "passes instance test" $ $(do ty <- [t| Int -> Bool |]-                                     [inst1, inst2] <- reifyInstances ''Show [ty]-                                     inst1 `eqTHSplice` inst2)--    it "makes type names" $ test_mkName--    it "fixes bug 8884" $ test_bug8884--    it "flattens DValDs" $ flatten_dvald--    it "extracts record selectors" $ test_rec_sels--    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--    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--    -- 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)-             $(sequence round_trip_types >>=-               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..]--    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+{- Tests for the th-desugar package
+
+(c) Richard Eisenberg 2013
+rae@cs.brynmawr.edu
+-}
+
+{-# LANGUAGE TemplateHaskell, UnboxedTuples, ParallelListComp, CPP,
+             RankNTypes, TypeFamilies,
+             DataKinds, ConstraintKinds, PolyKinds, MultiParamTypeClasses,
+             FlexibleInstances, ExistentialQuantification,
+             ScopedTypeVariables, GADTs, ViewPatterns, TupleSections,
+             TypeOperators, PartialTypeSignatures, PatternSynonyms,
+             TypeApplications #-}
+{-# 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__ >= 805
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+#endif
+
+#if __GLASGOW_HASKELL__ >= 809
+{-# LANGUAGE StandaloneKindSignatures #-}
+#endif
+
+#if __GLASGOW_HASKELL__ >= 906
+{-# LANGUAGE TypeData #-}
+#endif
+
+module Main where
+
+import Prelude hiding ( exp )
+
+import Test.HUnit
+import Test.Hspec hiding ( runIO )
+-- import Test.Hspec.HUnit
+
+import Splices
+import qualified DsDec
+import qualified Dec
+import Dec ( RecordSel )
+import ReifyTypeCUSKs
+import ReifyTypeSigs
+import T159Decs ( t159A, t159B )
+import Language.Haskell.TH.Desugar
+import qualified Language.Haskell.TH.Desugar.OSet as OS
+import Language.Haskell.TH.Desugar.Expand  ( expandUnsoundly )
+import Language.Haskell.TH
+import qualified Language.Haskell.TH.Syntax as Syn ( NameSpace(..), lift )
+
+import Control.Exception ( ErrorCall )
+import Control.Monad
+
+import qualified Data.Map as M
+import Data.Proxy
+
+#if __GLASGOW_HASKELL__ >= 900
+import Prelude as P
+#endif
+
+-- |
+-- Convert a HUnit test suite to a spec.  This can be used to run existing
+-- HUnit tests with Hspec.
+fromHUnitTest :: Test -> Spec
+-- copied from https://github.com/hspec/hspec/blob/master/hspec-contrib/src/Test/Hspec/Contrib/HUnit.hs
+fromHUnitTest t = case t of
+  TestList xs -> mapM_ go xs
+  x -> go x
+  where
+    go :: Test -> Spec
+    go t_ = case t_ of
+      TestLabel s (TestCase e) -> it s e
+      TestLabel s (TestList xs) -> describe s (mapM_ go xs)
+      TestLabel s x -> describe s (go x)
+      TestList xs -> describe "<unlabeled>" (mapM_ go xs)
+      TestCase e -> it "<unlabeled>" e
+
+tests :: Test
+tests = test [ "sections" ~: $test1_sections  @=? $(dsSplice test1_sections)
+             , "lampats"  ~: $test2_lampats   @=? $(dsSplice test2_lampats)
+             , "lamcase"  ~: $test3_lamcase   @=? $(dsSplice test3_lamcase)
+-- Must fix nested pattern-matching for this to work. Argh.
+--           , "tuples"   ~: $test4_tuples    @=? $(dsSplice test4_tuples)
+             , "ifs"      ~: $test5_ifs       @=? $(dsSplice test5_ifs)
+             , "ifs2"     ~: $test6_ifs2      @=? $(dsSplice test6_ifs2)
+             , "let"      ~: $test7_let       @=? $(dsSplice test7_let)
+             , "case"     ~: $test8_case      @=? $(dsSplice test8_case)
+             , "do"       ~: $test9_do        @=? $(dsSplice test9_do)
+             , "comp"     ~: $test10_comp     @=? $(dsSplice test10_comp)
+             , "parcomp"  ~: $test11_parcomp  @=? $(dsSplice test11_parcomp)
+             , "parcomp2" ~: $test12_parcomp2 @=? $(dsSplice test12_parcomp2)
+             , "sig"      ~: $test13_sig      @=? $(dsSplice test13_sig)
+             , "record"   ~: $test14_record   @=? $(dsSplice test14_record)
+             , "litp"     ~: $test15_litp     @=? $(dsSplice test15_litp)
+             , "tupp"     ~: $test16_tupp     @=? $(dsSplice test16_tupp)
+             , "infixp"   ~: $test17_infixp   @=? $(dsSplice test17_infixp)
+             , "tildep"   ~: $test18_tildep   @=? $(dsSplice test18_tildep)
+             , "bangp"    ~: $test19_bangp    @=? $(dsSplice test19_bangp)
+             , "asp"      ~: $test20_asp      @=? $(dsSplice test20_asp)
+             , "wildp"    ~: $test21_wildp    @=? $(dsSplice test21_wildp)
+             , "listp"    ~: $test22_listp    @=? $(dsSplice test22_listp)
+#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)
+             , "kisig"    ~: $test27_kisig    @=? $(dsSplice test27_kisig)
+             , "tupt"     ~: $test28_tupt     @=? $(dsSplice test28_tupt)
+             , "listt"    ~: $test29_listt    @=? $(dsSplice test29_listt)
+             , "promoted" ~: $test30_promoted @=? $(dsSplice test30_promoted)
+             , "constraint" ~: $test31_constraint @=? $(dsSplice test31_constraint)
+             , "tylit"    ~: $test32_tylit    @=? $(dsSplice test32_tylit)
+             , "tvbs"     ~: $test33_tvbs     @=? $(dsSplice test33_tvbs)
+             , "let_as"   ~: $test34_let_as   @=? $(dsSplice test34_let_as)
+             , "pred"     ~: $test37_pred     @=? $(dsSplice test37_pred)
+             , "pred2"    ~: $test38_pred2    @=? $(dsSplice test38_pred2)
+             , "eq"       ~: $test39_eq       @=? $(dsSplice test39_eq)
+             , "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
+             ]
+
+test35a = $test35_expand
+test35b = $(test35_expand >>= dsExp >>= expand >>= return . expToTH)
+test36a = $test36_expand
+test36b = $(test36_expand >>= dsExp >>= expand >>= return . expToTH)
+test_e3a = $test_expand3
+test_e3b = $(test_expand3 >>= dsExp >>= expand >>= return . expToTH)
+test_e4a = $test_expand4
+test_e4b = $(test_expand4 >>= dsExp >>= expand >>= return . expToTH)
+test_e5a = $test_expand5
+test_e5b = $(test_expand5 >>= dsExp >>= expand >>= return . expToTH)
+test_e6a = $test_expand6
+test_e6b = $(test_expand6 >>= dsExp >>= expand >>= return . expToTH)
+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)
+  -- 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
+
+test_expand :: Bool
+test_expand = and [ hasSameType test35a test35b
+                  , hasSameType test36a test36b
+                  , hasSameType test_e3a test_e3b
+                  , hasSameType test_e4a test_e4b
+                  , 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]
+test_dec = $(do bools <- mapM testDecSplice dec_test_nums
+                return $ ListE bools)
+
+$( do fuzzType <- mkTypeName "Fuzz"
+      fuzzData <- mkDataName "Fuzz"
+      let tySynDecs = TySynD (mkName "FuzzSyn") [] (ConT fuzzType)
+          dataSynDecs = TySynD (mkName "FuzzDataSyn") [] (ConT fuzzData)
+      fuzzDecs <- [d| data Fuzz = Fuzz |]
+      return $ tySynDecs : dataSynDecs : fuzzDecs )
+
+test_mkName :: Bool
+test_mkName = and [ hasSameType (Proxy :: Proxy FuzzSyn) (Proxy :: Proxy Fuzz)
+                  , hasSameType (Proxy :: Proxy FuzzDataSyn) (Proxy :: Proxy 'Fuzz) ]
+
+test_bug8884 :: Bool
+test_bug8884 = $(do info <- reify ''Poly
+                    dinfo@(DTyConI (DOpenTypeFamilyD (DTypeFamilyHead _name _tvbs (DKindSig resK) _ann))
+                                   (Just [DTySynInstD (DTySynEqn _ lhs _rhs)]))
+                      <- dsInfo info
+                    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:"
+                          putStrLn $ show dinfo
+                        [| False |] )
+
+flatten_dvald :: Bool
+flatten_dvald = let s1 = $(flatten_dvald_test)
+                    s2 = $(do expr <- flatten_dvald_test
+                              DLetE ddecs dexpr <- dsExp expr
+                              flattened <- fmap concat $ mapM flattenDValD ddecs
+                              return $ expToTH $ DLetE flattened dexpr ) in
+                s1 == s2
+
+test_rec_sels :: Bool
+test_rec_sels = and $(do bools <- mapM testRecSelTypes [1..rec_sel_test_num_sels]
+                         return $ ListE bools)
+
+test_standalone_deriving :: Bool
+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_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 () (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 ()]
+                                 (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 ()] []
+                            [ DLetDec (DInfixD fixity 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 (), DPlainTV y ()]
+                   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 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 $
+                                     mapM reifyWithLocals_maybe reifyDecsNames
+                          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
+              -- reifications below. Weird.
+
+normal_reifications :: [String]
+normal_reifications = $(do infos <- mapM reify reifyDecsNames
+                           ListE <$> mapM (Syn.lift . show . Just)
+                                          (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)
+zipWith3M _ _ _ _ = return []
+
+simplCase :: [Bool]
+simplCase = $( do exps <- sequence simplCaseTests
+                  dexps <- mapM dsExp exps
+                  sexps <- mapM scExp dexps
+                  bools <- zipWithM (\e1 e2 -> [| $(return e1) == $(return e2) |])
+                    exps (map sweeten sexps)
+                  return $ ListE bools )
+
+test_roundtrip :: [Bool]
+test_roundtrip = $( do exprs <- sequence test_exprs
+                       ds_exprs1 <- mapM dsExp exprs
+                       let th_exprs1 = map expToTH ds_exprs1
+                       ds_exprs2 <- mapM dsExp th_exprs1
+                       let th_exprs2 = map expToTH ds_exprs2
+                       ds_exprs3 <- mapM dsExp th_exprs2
+                       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
+  , 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))
+  ]
+  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
+    it "compiles" $ True
+    it "expands"  $ test_expand
+
+    zipWithM (\num success -> it ("passes dec test " ++ show num) success)
+      dec_test_nums test_dec
+
+    -- instance test 1 is part of dectest 6.
+    it "passes instance test" $ $(do ty <- [t| Int -> Bool |]
+                                     [inst1, inst2] <- reifyInstances ''Show [ty]
+                                     inst1 `eqTHSplice` inst2)
+
+    it "makes type names" $ test_mkName
+
+    it "fixes bug 8884" $ test_bug8884
+
+    it "flattens DValDs" $ flatten_dvald
+
+    it "extracts record selectors" $ test_rec_sels
+
+    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
+
+    -- 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)
+             $(sequence round_trip_types >>=
+               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..]
+
+    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,778 +1,791 @@-{- Tests for the th-desugar package--(c) Richard Eisenberg 2013-rae@cs.brynmawr.edu--}--{-# LANGUAGE TemplateHaskell, LambdaCase, MagicHash, UnboxedTuples,-             MultiWayIf, ParallelListComp, CPP, BangPatterns,-             ScopedTypeVariables, RankNTypes, TypeFamilies, ImpredicativeTypes,-             DataKinds, PolyKinds, GADTs, MultiParamTypeClasses,-             FunctionalDependencies, FlexibleInstances, StandaloneDeriving,-             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__ >= 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--{-# OPTIONS_GHC -Wno-missing-signatures -Wno-type-defaults-                -Wno-name-shadowing #-}--module Splices where--import qualified Data.List as L-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__ >= 803-import GHC.OverloadedLabels ( IsLabel(..) )-#endif--import Prelude as P--dsSplice :: Q Exp -> Q Exp-dsSplice expq = expq >>= dsExp >>= (return . expToTH)--dsDecSplice :: Q [Dec] -> Q [Dec]-dsDecSplice decsQ = decsQ >>= dsDecs >>= (return . decsToTH)--testDecSplice :: Int -> Q Exp-testDecSplice n = do-  let dsName  = mkName $ "DsDec.Dec" ++ show n-      regName = mkName $ "Dec.Dec" ++ show n-  infoDs  <- reify dsName-  infoReg <- reify regName-  rolesDs  <- reifyRoles dsName-  rolesReg <- reifyRoles regName-  fixityDs  <- reifyFixity dsName-  fixityReg <- reifyFixity regName-  eqTHSplice (infoDs, rolesDs, fixityDs) (infoReg, rolesReg, fixityReg)--unqualify :: Data a => a -> a-unqualify = everywhere (mkT (mkName . nameBase))--assumeStarT :: Data a => a -> a-assumeStarT = everywhere (mkT assume_spec . mkT assume_unit)-  where-    assume_spec :: TyVarBndrSpec -> TyVarBndrSpec-#if __GLASGOW_HASKELL__ >= 900-    assume_spec (PlainTV n spec)    = KindedTV n spec StarT-    assume_spec (KindedTV n spec k) = KindedTV n spec (assumeStarT k)-#else-    assume_spec = assume_unit-#endif--    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       = 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 :: (Quasi q, Data a, Show a) => a -> a -> q Exp-eqTHSplice a b = runQ $-  if a `eqTH` b-  then [| True |]-  else [| False |]--test1_sections = [| map ((* 3) . (4 +) . (\x -> x * x)) [10, 11, 12] |]-test2_lampats = [| (\(Just x) (Left z) -> x + z) (Just 5) (Left 10) |]-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 |]-test7_let = [| let { x :: Double; x = 5; f :: Double -> Double; f x = x + 1 } in f (x * 2) + x |]-test8_case = [| case Just False of { Just True -> 1 ; Just _ -> 2 ; Nothing -> 3 } |]-test9_do = [| show $ do { foo <- Just "foo"-                        ; let fool = foo ++ "l"-                        ; L.elemIndex 'o' fool-                        ; x <- L.elemIndex 'l' fool-                        ; return (x + 10) } |]-test10_comp = [| [ (x, x+1) | x <- [1..10], x `mod` 2 == 0 ] |]-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] ] |]-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) |]--test15_litp = [| map (\case { 5 -> True ; _ -> False }) [5,6] |]-test16_tupp = [| map (\(x,y,z) -> x + y + z) [(1,2,3),(4,5,6)] |]--data InfixType = Int :+: Bool-  deriving (Show, Eq)--test17_infixp = [| map (\(x :+: y) -> if y then x + 1 else x - 1) [5 :+: True, 10 :+: False] |]-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]] |]-#if __GLASGOW_HASKELL__ >= 801-test23_sigp = [| map (\ (a :: Int) -> a + a) [5, 10] |]-#endif--test24_fun = [| let f (Just x) = x-                    f Nothing = Nothing in-                f (Just (Just 10)) |]--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, Just 0] |]--test26_forall = [| let f :: Num a => a -> a-                       f x = x + 10 in-                   (f 5, f 3.0) |]--test27_kisig = [| let f :: Proxy (a :: Bool) -> ()-                      f _ = () in-                  (f (Proxy :: Proxy 'False), f (Proxy :: Proxy 'True)) |]-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-                  map f [ [[1]], [[2]] ] |]-test30_promoted = [| let f :: Proxy '() -> Proxy '[Int, Bool] -> ()-                         f _ _ = () in-                     f Proxy Proxy |]-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 :: Kind.Type -> Kind.Type). Monad b => a -> b a-                     f = return in-                 [f 1, f 2] :: [Maybe Int] |]--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 Constant a b = b-test36_expand = [| let f :: Constant Int (,) Bool Char -> Char-                       f = snd in-                   f |]--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--type family TFExpand x-type instance TFExpand Int = Bool-type instance TFExpand (Maybe a) = [a]-test_expand3 = [| let f :: TFExpand Int -> ()-                      f True = () in-                  f |]-test_expand4 = [| let f :: TFExpand (Maybe Bool) -> ()-                      f [True, False] = () in-                  f |]--type family ClosedTF a where-  ClosedTF Int = Bool-  ClosedTF x   = Char--test_expand5 = [| let f :: ClosedTF Int -> ()-                      f True = () in-                  f |]-test_expand6 = [| let f :: ClosedTF Double -> ()-                      f 'x' = () in-                  f |]--#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-                  f |]-test_expand8 = [| let f :: PolyTF IO -> ()-                      f True = () in-                  f |]---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) |]--test38_pred2 = [| let f :: a b => Proxy a -> b -> b-                      f _ x = x in-                  (f (Proxy :: Proxy Show) False, f (Proxy :: Proxy Num) (3 :: Int)) |]--test39_eq = [| let f :: (a ~ b) => a -> b-                   f x = x in-               (f ()) |]--dec_test_nums = [1..11] :: [Int]--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-               |]-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 :: Kind.Type -> Kind.Type) m2 | m1 -> m2  where-                 lift :: forall a. m1 a -> m2 a-                 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 :: Kind.Type -> Kind.Type) :: Kind.Type -> Kind.Type |]-dectest10 = [d| type family Dec10 a :: Kind.Type -> Kind.Type where-                  Dec10 Int = Maybe-                  Dec10 Bool = [] |]--data Blarggie a = MkBlarggie Int a-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-                  MkGInt :: Dec12 Int-                  MkGOther :: Dec12 b--              |]--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--instance_test = [d| instance (Show a, Show b) => Show (a -> b) where-                       show _ = "function" |]--class Dec6 a b where { lift :: a x -> b x; type M2 a }-imp_inst_test1 = [d| instance Dec6 Maybe (Either ()) where-                       lift Nothing = Left ()-                       lift (Just x) = Right x-                       type M2 Maybe = Either () |]--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) :: 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 = Show a =>-                                      MkRecord { recsel1 :: (Int, a)-                                               , 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-  VarI _ ty1 _ <- reify (mkName ("DsDec.recsel" ++ show n))-  VarI _ ty2 _ <- reify (mkName ("Dec.recsel"   ++ show n))-  let ty1' = return $ unqualify ty1-      ty2' = return $ unqualify ty2-  [| let x :: $ty1'-         x _ = undefined-         y :: $ty2'-         y _ = undefined-     in-     $(return $ VarE $ mkName "hasSameType") (\d -> x d) (\d -> y d) |]----- used for expand---reifyDecs :: Q [Dec]-reifyDecs = [d|-  -- 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 :: 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 }--  instance R2 (R6 a) a where-    r3 = undefined-    type R4 a (R6 a) = a-    data R5 (R6 a) = forall b. Show b => R10 { r11 :: a, naughty :: b }--  type family R12 a b :: Kind.Type--  data family R13 a :: Kind.Type--  data instance R13 Int = R14 { r15 :: Bool }--  r16, r17 :: Int-  (r16, r17) = (5, 6)--  newtype R18 = R19 Bool--  type R20 = Bool-  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-  |]--reifyDecsNames :: [Name]-reifyDecsNames = map mkName-  [ "r1"-  , "R4", "R5", "R6", "R7", "r8", "r9", "R10", "r11"-  , "R12", "R13", "R14", "r15", "r16", "r17", "R18", "R19", "R20"-  , "R21"-  , "r22"-  , "R25", "r26", "R28", "r29"-  , "R30", "r31"-#if __GLASGOW_HASKELL__ >= 809-  , "R32"-#endif-  , "R33", "R34", "r35"-  ]--simplCaseTests :: [Q Exp]-simplCaseTests =-  [ [| map (\a -> case a :: [Int] of-        (_:_:_:_) -> (5 :: Int)-        _         -> 6) [[], [1], [1,2,3]]-     |]-  , [| 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.-round_trip_types :: [TypeQ]-round_trip_types =-    [ [t|forall a. a ~ Int => a|]-    , [t|forall a. [a]|]-    , [t|forall a b. (a,b)|] ]--test_exprs :: [Q Exp]-test_exprs = [ test1_sections-             , test2_lampats-             , test3_lamcase--- see above             , test4_tuples-             , test5_ifs-             , test6_ifs2-             , test7_let-             , test8_case-             , test9_do-             , test10_comp-             , test11_parcomp-             , test12_parcomp2-             , test13_sig-             , test14_record-             , test15_litp-             , test16_tupp-             , test17_infixp-             , test18_tildep-             , test19_bangp-             , test20_asp-             , test21_wildp-             , test22_listp-#if __GLASGOW_HASKELL__ >= 801-             , test23_sigp-#endif-             , test24_fun-             , test25_fun2-             , test26_forall-             , test27_kisig-             , test28_tupt-             , test29_listt-             , test30_promoted-             , test31_constraint-             , test32_tylit-             , test33_tvbs-             , test34_let_as-             , 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-             ]+{- Tests for the th-desugar package
+
+(c) Richard Eisenberg 2013
+rae@cs.brynmawr.edu
+-}
+
+{-# LANGUAGE TemplateHaskell, LambdaCase, MagicHash, UnboxedTuples,
+             MultiWayIf, ParallelListComp, CPP, BangPatterns,
+             ScopedTypeVariables, RankNTypes, TypeFamilies, ImpredicativeTypes,
+             DataKinds, PolyKinds, GADTs, MultiParamTypeClasses,
+             FunctionalDependencies, FlexibleInstances, StandaloneDeriving,
+             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__ >= 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
+
+{-# OPTIONS_GHC -Wno-missing-signatures -Wno-type-defaults
+                -Wno-name-shadowing #-}
+
+module Splices where
+
+import qualified Data.List as L
+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__ >= 803
+import GHC.OverloadedLabels ( IsLabel(..) )
+#endif
+
+import Prelude as P
+
+dsSplice :: Q Exp -> Q Exp
+dsSplice expq = expq >>= dsExp >>= (return . expToTH)
+
+dsDecSplice :: Q [Dec] -> Q [Dec]
+dsDecSplice decsQ = decsQ >>= dsDecs >>= (return . decsToTH)
+
+testDecSplice :: Int -> Q Exp
+testDecSplice n = do
+  let dsName  = mkName $ "DsDec.Dec" ++ show n
+      regName = mkName $ "Dec.Dec" ++ show n
+  infoDs  <- reify dsName
+  infoReg <- reify regName
+  rolesDs  <- reifyRoles dsName
+  rolesReg <- reifyRoles regName
+  fixityDs  <- reifyFixity dsName
+  fixityReg <- reifyFixity regName
+  eqTHSplice (infoDs, rolesDs, fixityDs) (infoReg, rolesReg, fixityReg)
+
+unqualify :: Data a => a -> a
+unqualify = everywhere (mkT (mkName . nameBase))
+
+assumeStarT :: Data a => a -> a
+assumeStarT = everywhere (mkT assume_spec . mkT assume_unit)
+  where
+    assume_spec :: TyVarBndrSpec -> TyVarBndrSpec
+#if __GLASGOW_HASKELL__ >= 900
+    assume_spec (PlainTV n spec)    = KindedTV n spec StarT
+    assume_spec (KindedTV n spec k) = KindedTV n spec (assumeStarT k)
+#else
+    assume_spec = assume_unit
+#endif
+
+    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       = 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 :: (Quasi q, Data a, Show a) => a -> a -> q Exp
+eqTHSplice a b = runQ $
+  if a `eqTH` b
+  then [| True |]
+  else [| False |]
+
+test1_sections = [| map ((* 3) . (4 +) . (\x -> x * x)) [10, 11, 12] |]
+test2_lampats = [| (\(Just x) (Left z) -> x + z) (Just 5) (Left 10) |]
+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 |]
+test7_let = [| let { x :: Double; x = 5; f :: Double -> Double; f x = x + 1 } in f (x * 2) + x |]
+test8_case = [| case Just False of { Just True -> 1 ; Just _ -> 2 ; Nothing -> 3 } |]
+test9_do = [| show $ do { foo <- Just "foo"
+                        ; let fool = foo ++ "l"
+                        ; L.elemIndex 'o' fool
+                        ; x <- L.elemIndex 'l' fool
+                        ; return (x + 10) } |]
+test10_comp = [| [ (x, x+1) | x <- [1..10], x `mod` 2 == 0 ] |]
+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] ] |]
+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) |]
+
+test15_litp = [| map (\case { 5 -> True ; _ -> False }) [5,6] |]
+test16_tupp = [| map (\(x,y,z) -> x + y + z) [(1,2,3),(4,5,6)] |]
+
+data InfixType = Int :+: Bool
+  deriving (Show, Eq)
+
+test17_infixp = [| map (\(x :+: y) -> if y then x + 1 else x - 1) [5 :+: True, 10 :+: False] |]
+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]] |]
+#if __GLASGOW_HASKELL__ >= 801
+test23_sigp = [| map (\ (a :: Int) -> a + a) [5, 10] |]
+#endif
+
+test24_fun = [| let f (Just x) = x
+                    f Nothing = Nothing in
+                f (Just (Just 10)) |]
+
+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, Just 0] |]
+
+test26_forall = [| let f :: Num a => a -> a
+                       f x = x + 10 in
+                   (f 5, f 3.0) |]
+
+test27_kisig = [| let f :: Proxy (a :: Bool) -> ()
+                      f _ = () in
+                  (f (Proxy :: Proxy 'False), f (Proxy :: Proxy 'True)) |]
+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
+                  map f [ [[1]], [[2]] ] |]
+test30_promoted = [| let f :: Proxy '() -> Proxy '[Int, Bool] -> ()
+                         f _ _ = () in
+                     f Proxy Proxy |]
+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 :: Kind.Type -> Kind.Type). Monad b => a -> b a
+                     f = return in
+                 [f 1, f 2] :: [Maybe Int] |]
+
+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 Constant a b = b
+test36_expand = [| let f :: Constant Int (,) Bool Char -> Char
+                       f = snd in
+                   f |]
+
+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
+
+type family TFExpand x
+type instance TFExpand Int = Bool
+type instance TFExpand (Maybe a) = [a]
+test_expand3 = [| let f :: TFExpand Int -> ()
+                      f True = () in
+                  f |]
+test_expand4 = [| let f :: TFExpand (Maybe Bool) -> ()
+                      f [True, False] = () in
+                  f |]
+
+type family ClosedTF a where
+  ClosedTF Int = Bool
+  ClosedTF x   = Char
+
+test_expand5 = [| let f :: ClosedTF Int -> ()
+                      f True = () in
+                  f |]
+test_expand6 = [| let f :: ClosedTF Double -> ()
+                      f 'x' = () in
+                  f |]
+
+#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
+                  f |]
+test_expand8 = [| let f :: PolyTF IO -> ()
+                      f True = () in
+                  f |]
+
+
+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) |]
+
+test38_pred2 = [| let f :: a b => Proxy a -> b -> b
+                      f _ x = x in
+                  (f (Proxy :: Proxy Show) False, f (Proxy :: Proxy Num) (3 :: Int)) |]
+
+test39_eq = [| let f :: (a ~ b) => a -> b
+                   f x = x in
+               (f ()) |]
+
+dec_test_nums = [1..11] :: [Int]
+
+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
+               |]
+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 :: Kind.Type -> Kind.Type) m2 | m1 -> m2  where
+                 lift :: forall a. m1 a -> m2 a
+                 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 :: Kind.Type -> Kind.Type) :: Kind.Type -> Kind.Type |]
+dectest10 = [d| type family Dec10 a :: Kind.Type -> Kind.Type where
+                  Dec10 Int = Maybe
+                  Dec10 Bool = [] |]
+
+data Blarggie a = MkBlarggie Int a
+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
+                  MkGInt :: Dec12 Int
+                  MkGOther :: Dec12 b
+
+              |]
+
+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
+
+instance_test = [d| instance (Show a, Show b) => Show (a -> b) where
+                       show _ = "function" |]
+
+class Dec6 a b where { lift :: a x -> b x; type M2 a }
+imp_inst_test1 = [d| instance Dec6 Maybe (Either ()) where
+                       lift Nothing = Left ()
+                       lift (Just x) = Right x
+                       type M2 Maybe = Either () |]
+
+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) :: 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 = Show a =>
+                                      MkRecord { recsel1 :: (Int, a)
+                                               , 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
+  VarI _ ty1 _ <- reify (mkName ("DsDec.recsel" ++ show n))
+  VarI _ ty2 _ <- reify (mkName ("Dec.recsel"   ++ show n))
+  let ty1' = return $ unqualify ty1
+      ty2' = return $ unqualify ty2
+  [| let x :: $ty1'
+         x _ = undefined
+         y :: $ty2'
+         y _ = undefined
+     in
+     $(return $ VarE $ mkName "hasSameType") (\d -> x d) (\d -> y d) |]
+
+
+-- used for expand
+
+
+reifyDecs :: Q [Dec]
+reifyDecs = [d|
+  -- 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 :: 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 }
+
+  instance R2 (R6 a) a where
+    r3 = undefined
+    type R4 a (R6 a) = a
+    data R5 (R6 a) = forall b. Show b => R10 { r11 :: a, naughty :: b }
+
+  type family R12 a b :: Kind.Type
+
+  data family R13 a :: Kind.Type
+
+  data instance R13 Int = R14 { r15 :: Bool }
+
+  r16, r17 :: Int
+  (r16, r17) = (5, 6)
+
+  newtype R18 = R19 Bool
+
+  type R20 = Bool
+  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
+  |]
+
+reifyDecsNames :: [Name]
+reifyDecsNames = map mkName
+  [ "r1"
+  , "R4", "R5", "R6", "R7", "r8", "r9", "R10", "r11"
+  , "R12", "R13", "R14", "r15", "r16", "r17", "R18", "R19", "R20"
+  , "R21"
+  , "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
+  ]
+
+simplCaseTests :: [Q Exp]
+simplCaseTests =
+  [ [| map (\a -> case a :: [Int] of
+        (_:_:_:_) -> (5 :: Int)
+        _         -> 6) [[], [1], [1,2,3]]
+     |]
+  , [| 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.
+round_trip_types :: [TypeQ]
+round_trip_types =
+    [ [t|forall a. a ~ Int => a|]
+    , [t|forall a. [a]|]
+    , [t|forall a b. (a,b)|] ]
+
+test_exprs :: [Q Exp]
+test_exprs = [ test1_sections
+             , test2_lampats
+             , test3_lamcase
+-- see above             , test4_tuples
+             , test5_ifs
+             , test6_ifs2
+             , test7_let
+             , test8_case
+             , test9_do
+             , test10_comp
+             , test11_parcomp
+             , test12_parcomp2
+             , test13_sig
+             , test14_record
+             , test15_litp
+             , test16_tupp
+             , test17_infixp
+             , test18_tildep
+             , test19_bangp
+             , test20_asp
+             , test21_wildp
+             , test22_listp
+#if __GLASGOW_HASKELL__ >= 801
+             , test23_sigp
+#endif
+             , test24_fun
+             , test25_fun2
+             , test26_forall
+             , test27_kisig
+             , test28_tupt
+             , test29_listt
+             , test30_promoted
+             , test31_constraint
+             , test32_tylit
+             , test33_tvbs
+             , test34_let_as
+             , 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
+             ]
Test/T158Exp.hs view
@@ -1,14 +1,15 @@-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE TemplateHaskell #-}---- | 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)+{-# 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
@@ -1,20 +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 ()-                |])+{-# 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 ()
+                |])
th-desugar.cabal view
@@ -1,102 +1,102 @@-name:           th-desugar-version:        1.14-cabal-version:  >= 1.10-synopsis:       Functions to desugar Template Haskell-homepage:       https://github.com/goldfirere/th-desugar-category:       Template Haskell-author:         Richard Eisenberg <rae@cs.brynmawr.edu>-maintainer:     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.2-description:-    This package provides the Language.Haskell.TH.Desugar module, which desugars-    Template Haskell's rich encoding of Haskell syntax into a simpler encoding.-    This desugaring discards surface syntax information (such as the use of infix-    operators) but retains the original meaning of the TH code. The intended use-    of this package is as a preprocessor for more advanced code manipulation-    tools. Note that the input to any of the ds... functions should be produced-    from a TH quote, using the syntax [| ... |]. If the input to these functions-    is a hand-coded TH syntax tree, the results may be unpredictable. In-    particular, it is likely that promoted datatypes will not work as expected.--source-repository this-  type:     git-  location: https://github.com/goldfirere/th-desugar.git-  tag:      v1.10--source-repository head-  type:     git-  location: https://github.com/goldfirere/th-desugar.git-  branch:   master--library-  build-depends:-      base >= 4.9 && < 5,-      ghc-prim,-      template-haskell >= 2.11 && < 2.20,-      containers >= 0.5,-      mtl >= 2.1 && < 2.4,-      ordered-containers >= 0.2.2,-      syb >= 0.4,-      th-abstraction >= 0.4 && < 0.5,-      th-lift >= 0.6.1,-      th-orphans >= 0.13.7,-      transformers-compat >= 0.6.3-  default-extensions: TemplateHaskell-  exposed-modules:    Language.Haskell.TH.Desugar-                      Language.Haskell.TH.Desugar.Expand-                      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.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-  default-language:   Haskell2010-  default-extensions: TemplateHaskell-  hs-source-dirs:     Test-  main-is:            Run.hs-  other-modules:      Dec-                      DsDec-                      ReifyTypeCUSKs-                      ReifyTypeSigs-                      Splices-                      T158Exp-                      T159Decs--  build-depends:-      base >= 4 && < 5,-      template-haskell,-      containers >= 0.5,-      mtl >= 2.1,-      syb >= 0.4,-      HUnit >= 1.2,-      hspec >= 1.3,-      th-abstraction >= 0.4 && < 0.5,-      th-desugar,-      th-lift >= 0.6.1,-      th-orphans >= 0.13.9+name:           th-desugar
+version:        1.15
+cabal-version:  >= 1.10
+synopsis:       Functions to desugar Template Haskell
+homepage:       https://github.com/goldfirere/th-desugar
+category:       Template Haskell
+author:         Richard Eisenberg <rae@cs.brynmawr.edu>
+maintainer:     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.6
+              , GHC == 9.4.4
+              , GHC == 9.6.1
+description:
+    This package provides the Language.Haskell.TH.Desugar module, which desugars
+    Template Haskell's rich encoding of Haskell syntax into a simpler encoding.
+    This desugaring discards surface syntax information (such as the use of infix
+    operators) but retains the original meaning of the TH code. The intended use
+    of this package is as a preprocessor for more advanced code manipulation
+    tools. Note that the input to any of the ds... functions should be produced
+    from a TH quote, using the syntax [| ... |]. If the input to these functions
+    is a hand-coded TH syntax tree, the results may be unpredictable. In
+    particular, it is likely that promoted datatypes will not work as expected.
+
+source-repository this
+  type:     git
+  location: https://github.com/goldfirere/th-desugar.git
+  tag:      v1.10
+
+source-repository head
+  type:     git
+  location: https://github.com/goldfirere/th-desugar.git
+  branch:   master
+
+library
+  build-depends:
+      base >= 4.9 && < 5,
+      ghc-prim,
+      template-haskell >= 2.11 && < 2.21,
+      containers >= 0.5,
+      mtl >= 2.1 && < 2.4,
+      ordered-containers >= 0.2.2,
+      syb >= 0.4,
+      th-abstraction >= 0.5 && < 0.6,
+      th-orphans >= 0.13.7,
+      transformers-compat >= 0.6.3
+  default-extensions: TemplateHaskell
+  exposed-modules:    Language.Haskell.TH.Desugar
+                      Language.Haskell.TH.Desugar.Expand
+                      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.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
+  default-language:   Haskell2010
+  default-extensions: TemplateHaskell
+  hs-source-dirs:     Test
+  main-is:            Run.hs
+  other-modules:      Dec
+                      DsDec
+                      ReifyTypeCUSKs
+                      ReifyTypeSigs
+                      Splices
+                      T158Exp
+                      T159Decs
+
+  build-depends:
+      base >= 4 && < 5,
+      template-haskell,
+      containers >= 0.5,
+      mtl >= 2.1,
+      syb >= 0.4,
+      HUnit >= 1.2,
+      hspec >= 1.3,
+      th-abstraction,
+      th-desugar,
+      th-orphans >= 0.13.9