th-desugar 1.15 → 1.16
raw patch · 29 files changed
+9712/−9117 lines, 29 filesdep ~template-haskelldep ~th-abstractionsetup-changed
Dependency ranges changed: template-haskell, th-abstraction
Files
- CHANGES.md +657/−591
- LICENSE +26/−26
- Language/Haskell/TH/Desugar.hs +455/−441
- Language/Haskell/TH/Desugar/AST.hs +321/−313
- Language/Haskell/TH/Desugar/Core.hs +2056/−1986
- Language/Haskell/TH/Desugar/Expand.hs +226/−226
- Language/Haskell/TH/Desugar/FV.hs +73/−73
- Language/Haskell/TH/Desugar/Lift.hs +18/−18
- Language/Haskell/TH/Desugar/Match.hs +427/−413
- Language/Haskell/TH/Desugar/OMap.hs +142/−142
- Language/Haskell/TH/Desugar/OMap/Strict.hs +115/−115
- Language/Haskell/TH/Desugar/OSet.hs +117/−117
- Language/Haskell/TH/Desugar/Reify.hs +1368/−1317
- Language/Haskell/TH/Desugar/Subst.hs +150/−145
- Language/Haskell/TH/Desugar/Sweeten.hs +425/−416
- Language/Haskell/TH/Desugar/Util.hs +653/−547
- README.md +146/−106
- Setup.hs +2/−2
- Test/Dec.hs +64/−54
- Test/DsDec.hs +98/−86
- Test/FakeTuples.hs +13/−0
- Test/ReifyTypeCUSKs.hs +121/−121
- Test/ReifyTypeSigs.hs +76/−76
- Test/Run.hs +945/−858
- Test/Splices.hs +845/−791
- Test/T158Exp.hs +15/−15
- Test/T159Decs.hs +20/−20
- Test/T183.hs +32/−0
- th-desugar.cabal +106/−102
CHANGES.md view
@@ -1,591 +1,657 @@-`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 +`th-desugar` release notes+==========================++Version 1.16 [2023.10.13]+-------------------------+* Support GHC 9.8.+* Require `th-abstraction-0.6` or later.+* Add support for invisible binders in type-level declarations. As part of this+ change:++ * `Language.Haskell.TH.Desugar` now exports a `DTyVarBndrVis` type synonym,+ which is the `th-desugar` counterpart to `TyVarBndrVis`. It also exports a+ `dsTvbVis` function, which is the `DTyVarBndrVis` counterpart to `dsTvbSpec`+ and `dsTvbUnit`.+ * `Language.Haskell.TH.Desugar` now re-exports `BndrVis` from+ `template-haskell`.+ * The `DDataD`, `DTySynD`, `DClassD`, `DDataFamilyD`, and `DTypeFamilyHead`+ parts of the `th-desugar` AST now use `DTyVarBndrVis` instead of+ `DTyVarBndrUnit`.+ * The `mkExtraDKindBinders`, `dsCon`, and `dsDataDec` functions now use+ `DTyVarBndrVis` instead of `DTyVarBndrUnit`.+ * The `getDataD` function now uses `TyVarBndrVis` instead of `TyVarBndrUnit`.++ It is possible that you will need to convert between `TyVarBndrUnit` and+ `TyVarBndrVis` to adapt your existing `th-desugar` code. (Note that `TyVarBndr+ flag` is an instance of `Functor`, so this can be accomplished with `fmap`.)+* `Language.Haskell.TH.Desugar` now exports a family of functions for converting+ type variable binders into type arguments while preserving their visibility:++ * The `tyVarBndrVisToTypeArg` and `tyVarBndrVisToTypeArgWithSig` functions+ convert a `TyVarBndrVis` to a `TypeArg`. `tyVarBndrVisToTypeArg` omits kind+ signatures when converting `KindedTV`s, while `tyVarBndrVisToTypeArgWithSig`+ preserves kind signatures.+ * The `dTyVarBndrVisToDTypeArg` and `dTyVarBndrVisToDTypeArgWithSig` functions+ convert a `DTyVarBndrVis` to a `DTypeArg`. `dTyVarBndrVisToDTypeArg` omits+ kind signatures when converting `DKindedTV`s, while+ `dTyVarBndrVisToDTypeArgWithSig` preserves kind signatures.+* `th-desugar` now supports generating typed Template Haskell quotes and splices+ via the new `DTypedBracketE` and `DTypedSpliceE` constructors of `DExp`,+ respectively.+* The `lookupValueNameWithLocals` function will no longer reify field selectors+ when the `NoFieldSelectors` language extension is set, mirroring the behavior+ of the `lookupValueName` function in `template-haskell`. Note that this will+ only happen when using GHC 9.8 or later, as previous versions of GHC do not+ equip Template Haskell with enough information to conclude whether a value is+ a record field or not.+* The `tupleNameDegree_maybe` function now returns:+ * `Just 0` when the argument is `''Unit`+ * `Just 1` when the argument is `''Solo` or `'MkSolo`+ * `Just <N>` when the argument is `''Tuple<N>`+ This is primarily motivated by the fact that with GHC 9.8 or later, `''()` is+ syntactic sugar for `''Unit`, `''(,)` is syntactic sugar for `Tuple2`, and so+ on. We also include cases for `''Solo` and `'MkSolo` for the sake of+ completeness, even though they do not have any special syntactic sugar.+* The `tupleDegree_maybe`, `unboxedSumDegree_maybe`, and+ `unboxedTupleDegree_maybe` functions have been removed. Their only use sites+ were in the `tupleNameDegree_maybe`, `unboxedSumNameDegree_maybe`, and+ `unboxedTupleNameDegree_maybe` functions, respectively. Moreover,+ `tupleDegree_maybe`'s semantics were questionable, considering that it could+ potentially return `Just <N>` for a custom data type named `Tuple<N>`, even+ if the custom data type has no relation to the `Tuple<N>` types defined in+ `GHC.Tuple`.+* The `matchTy` function now looks through visible kind applications (i.e.,+ `DAppKindT`s) whenever `YesIgnoreKinds` is given.+* Fix a bug in which infix data family declaration would mistakenly be rejected+ when reified locally.+* Fix a bug in which data types that use visible dependent quantification would+ produce ill-scoped code when desugared.++Version 1.15 [2023.03.12]+-------------------------+* Support GHC 9.6.+* The `NewOrData` data type has been renamed to `DataFlavor` and extended to+ support `type data` declarations:++ ```diff+ -data NewOrData = NewType | Data+ +data DataFlavor = NewType | Data | TypeData+ ```++ Desugaring upholds the following properties regarding `TypeData`:++ * A `DDataD` with a `DataFlavor` of `TypeData` cannot have any deriving+ clauses or datatype contexts, and the `DConFields` in each `DCon` will be a+ `NormalC` where each `Bang` is equal to+ `Bang NoSourceUnpackedness NoSourceStrictness`.+ * A `DDataInstD` can have a `DataFlavor` of `NewType` or `Data`, but not+ `TypeData`.+* The type of `getDataD` has been changed to also include a `DataFlavor`:++ ```diff+ -getDataD :: DsMonad q => String -> Name -> q ([TyVarBndrUnit], [Con])+ +getDataD :: DsMonad q => String -> Name -> q (DataFlavor, [TyVarBndrUnit], [Con])+ ```+* Local reification can now reify the types of pattern synonym record+ selectors.+* Fix a bug in which the types of locally reified GADT record selectors would+ sometimes have type variables quantified in the wrong order.++Version 1.14 [2022.08.23]+-------------------------+* Support GHC 9.4.+* Drop support for GHC 7.8 and 7.10. As a consequence of this, the+ `strictToBang` function was removed as it no longer serves a useful purpose.+* Desugared lambda expressions and guards that bind multiple patterns can now+ have patterns with unlifted types. The desugared code uses `UnboxedTuples` to+ make this possible, so if you load the desugared code into GHCi on prior to+ GHC 9.2, you will need to enable `-fobject-code`.+* `th-desugar` now desugars `PromotedInfixT` and `PromotedUInfixT`, which were+ added in GHC 9.4. Mirroring the existing treatment of other `Promoted*`+ `Type`s, `PromotedInfixT` is desugared to an application of a `DConT` applied+ to two arguments, just like `InfixT` is desugared. Similarly, attempting to+ desugar a `PromotedUInfixT` results in an error, just like attempting to+ desugar a `UInfixT` would be.+* `th-desugar` now supports `DefaultD` (i.e., `default` declarations) and+ `OpaqueP` (i.e., `OPAQUE` pragmas), which were added in GHC 9.4.+* `th-desugar` now desugars `LamCasesE` (i.e., `\cases` expressions), which was+ added in GHC 9.4. A `\cases` expression is desugared to an ordinary lambda+ expression, much like `\case` is currently desugared.+* Fix an inconsistency which caused non-exhaustive `case` expressions to be+ desugared into uses of `EmptyCase`. Non-exhaustive `case` expressions are now+ desugared into code that throws a "`Non-exhaustive patterns in...`" error at+ runtime, just as all other forms of non-exhaustive expressions are desugared.+* Fix a bug in which `expandType` would not expand closed type families when+ applied to arguments containing type variables.++Version 1.13.1 [2022.05.20]+---------------------------+* Allow building with `mtl-2.3.*`.++Version 1.13 [2021.10.30]+-------------------------+* Support GHC 9.2.+* Add support for visible type application in data constructor patterns. As a+ result of these changes, the `DConP` constructor now has an extra field to+ represent type arguments:++ ```diff+ data DPat+ = ...+ - | DConP Name [DPat] -- fun (Just x) = ...+ + | DConP Name [DType] [DPat] -- fun (Just @t x) = ...+ | ...+ ```+* Add support for the `e.field` and `(.field)` syntax from the+ `OverloadedRecordDot` language extension.+* The `Maybe [DTyVarBndrUnit]` fields in `DInstanceD` and `DStandaloneDerivD`+ are no longer used when sweetening. Previously, `th-desugar` would attempt to+ sweeten these `DTyVarBndrUnit`s by turning them into a nested `ForallT`, but+ GHC 9.2 or later no longer allow this, as they forbid nested `forall`s in+ instance heads entirely. As a result, the `Maybe [DTyVarBndrUnit]` fields are+ now only useful for functions that consume `DDec`s directly.+* Fix a bug in which desugared GADT constructors would sometimes incorrectly+ claim that they were declared infix, despite this not being the case.++Version 1.12 [2021.03.12]+-------------------------+* Support GHC 9.0.+* Add support for explicit specificity. As part of this change,+ the way `th-desugar` represents type variable binders has been overhauled:+ * The `DTyVarBndr` data type is now parameterized by a `flag` type parameter:++ ```hs+ data DTyVarBndr flag+ = DPlainTV Name flag+ | DKindedTV Name flag DKind+ ```++ This can be instantiated to `Specificity` (for type variable binders that+ can be specified or inferred) or `()` (for type variable binders where+ specificity is irrelevant). `DTyVarBndrSpec` and `DTyVarBndrUnit` are also+ provided as type synonyms for `DTyVarBndr Specificity` and `DTyVarBndr ()`,+ respectively.+ * In order to interface with `TyVarBndr` (the TH counterpart to `DTyVarBndr`)+ in a backwards-compatible way, `th-desugar` now depends on the+ `th-abstraction` library.+ * The `ForallVisFlag` has been removed in favor of the new `DForallTelescope`+ data type, which not only distinguishes between invisible and visible+ `forall`s but also uses the correct type variable flag for invisible type+ variables (`Specificity`) and visible type variables (`()`).+ * The type of the `dsTvb` is now different on pre-9.0 versions of GHC:++ ```hs+ #if __GLASGOW_HASKELL__ >= 900+ dsTvb :: DsMonad q => TyVarBndr flag -> q (DTyVarBndr flag)+ #else+ dsTvb :: DsMonad q => flag -> TyVarBndr -> q (DTyVarBndr flag)+ #endif+ ```++ This is unfortunately required by the fact that prior to GHC 9.0, there is+ no `flag` information stored anywhere in a `TyVarBndr`. If you need to use+ `dsTvb` in a backward-compatible way, `L.H.TH.Desugar` now provides+ `dsTvbSpec` and `dsTvbUnit` functions which specialise `dsTvb` to+ particular `flag` types:++ ```hs+ dsTvbSpec :: DsMonad q => TyVarBndrSpec -> q DTyVarBndrSpec+ dsTvbUnit :: DsMonad q => TyVarBndrUnit -> q DTyVarBndrUnit+ ```+* The type of the `getRecordSelectors` function has changed:++ ```diff+ -getRecordSelectors :: DsMonad q => DType -> [DCon] -> q [DLetDec]+ +getRecordSelectors :: DsMonad q => [DCon] -> q [DLetDec]+ ```++ The old type signature had a `DType` argument whose sole purpose was to help+ determine which type variables were existential, as this information was used+ to filter out "naughty" record selectors, like the example below:++ ```hs+ data Some :: (Type -> Type) -> Type where+ MkSome :: { getSome :: f a } -> Some f+ ```++ The old implementation of `getRecordSelectors` would not include `getSome` in+ the returned list, as its type `f a` mentions an existential type variable,+ `a`, that is not mentioned in the return type `Some f`. The new+ implementation of `getRecordSelectors`, on the other hand, makes no attempt+ to filter out naughty record selectors, so it would include `getSome`.++ This reason for this change is ultimately because determining which type+ variables are existentially quantified in the context of Template+ Haskell is rather challenging in the general case. There are heuristics we+ could employ to guess which variables are existential, but we have found+ these heuristics difficult to predict (let alone specify). As a result, we+ take the slightly less correct (but much easier to explain) approach of+ returning all record selectors, regardless of whether they are naughty or not.+* The `conExistentialTvbs` function has been removed. It was horribly buggy,+ especially in the presence of GADT constructors. Moreover, this function was+ used in the implementation of `getRecordSelectors` function, so bugs in+ `conExistentialTvbs` often affected the results of `getRecordSelectors`.+* The types of `decToTH`, `letDecToTH`, and `pragmaToTH` have changed:++ ```diff+ -decToTH :: DDec -> [Dec]+ +decToTH :: DDec -> Dec++ -letDecToTH :: DLetDec -> Maybe Dec+ +letDecToTH :: DLetDec -> Dec++ -pragmaToTH :: DPragma -> Maybe Pragma+ +pragmaToTH :: DPragma -> Pragma+ ```++ The semantics of `pragmaToTH` have changed accordingly. Previously,+ `pragmaToTH` would return `Nothing` when the argument is a `DPragma` that is+ not supported on an old version of GHC, but now an error will be thrown+ instead. `decToTH` and `letDecToTH`, which transitively invoke `pragmaToTH`,+ have had their types updated to accommodate `pragmaToTH`'s type change.+* The type of the `substTyVarBndrs` function has been simplified to avoid the+ needless use of continuation-passing style:++ ```diff+ -substTyVarBndrs :: Quasi q => DSubst -> [DTyVarBndr flag] -> (DSubst -> [DTyVarBndr flag] -> q a) -> q a+ +substTyVarBndrs :: Quasi q => DSubst -> [DTyVarBndr flag] -> q (DSubst, [DTyVarBndr flag])+ ```+* `mkDLamEFromDPats` has now generates slightly more direct code for certain+ lambda expressions with `@`-patterns. For example, `\x@y -> f x y` would+ previously desugar to `\arg -> case arg of { y -> let x = y in f x y }`, but+ it now desugars to `\y -> let x = y in f x y`.+* `mkDLamEFromDPats` now requires only a `Quasi` context instead of `DsMonad`.++Version 1.11 [2020.03.25]+-------------------------+* Support GHC 8.10.+* Add support for visible dependent quantification. As part of this change,+ the way `th-desugar` represents `forall` and constraint types has been+ overhauled:+ * The existing `DForallT` constructor has been split into two smaller+ constructors:++ ```diff+ data DType+ = ...+ - | DForallT [DTyVarBndr] DCxt DType+ + | DForallT ForallVisFlag [DTyVarBndr] DType+ + | DConstrainedT DCxt DType+ | ...++ +data ForallVisFlag+ + = ForallVis+ + | ForallInvis+ ```++ The previous design combined `forall`s and constraints into a single+ constructor, while the new design puts them in distinct constructors+ `DForallT` and `DConstrainedT`, respectively. The new `DForallT`+ constructor also has a `ForallVisFlag` field to distinguish invisible+ `forall`s (e.g., `forall a. a`) from visible `forall`s (e.g.,+ `forall a -> a`).+ * The `unravel` function has been renamed to `unravelDType` and now returns+ `(DFunArgs, DType)`, where `DFunArgs` is a data type that represents+ the possible arguments in a function type (see the Haddocks for `DFunArgs`+ for more details). There is also an `unravelDType` counterpart for `Type`s+ named `unravelType`, complete with its own `FunArgs` data type.++ `{D}FunArgs` also have some supporting operations, including+ `filter{D}VisFunArgs` (to obtain only the visible arguments) and+ `ravel{D}Type` (to construct a function type using `{D}FunArgs` and+ a return `{D}Type`).+* Support standalone kind signatures by adding a `DKiSigD` constructor to+ `DDec`.+* Add `dsReifyType`, `reifyTypeWithLocals_maybe`, and `reifyTypeWithLocals`,+ which allow looking up the types or kinds of locally declared entities.+* Fix a bug in which `reifyFixityWithLocals` would not look into local fixity+ declarations inside of type classes.+* Fix a bug in which `reifyFixityWithLocals` would return incorrect results+ for classes with associated type family defaults.++Version 1.10+------------+* Support GHC 8.8. Drop support for GHC 7.6.+* Add support for visible kind application, type variable `foralls` in `RULES`,+ and explicit `forall`s in type family instances. Correspondingly,+ * There is now a `DAppKindT` constructor in `DType`.+ * Previously, the `DDataInstD` constructor had fields of type `Name` and+ `[DType]`. Those have been scrapped in favor of a single field of type+ `DType`, representing the application of the data family name (which was+ previously the `Name`) to its arguments (which was previously the+ `[DType]`).++ `DDataInstD` also has a new field of type `Maybe [DTyVarBndr]` to represent+ its explicitly quantified type variables (if present).+ * Previously, the `DTySynEqn` constructor had a field of type `[DType]`.+ That has been scrapped in favor of a field of type `DType`, representing+ the application of the type family name (which `DTySynEqn` did not used to+ contain!) to its arguments (which was previously the `[DType]`).++ `DTySynEqn` also has a new field of type `Maybe [DTyVarBndr]` to represent+ its explicitly quantified type variables (if present).+ * `DTySynInstD` no longer has a field of type `Name`, as that is redundant+ now that each `DTySynEqn` contains the same `Name`.+ * There is now a field of type `Maybe [DTyVarBndr]` in the `DRuleP`+ constructor to represent bound type variables in `RULES` (if present).+* Add a field of type `Maybe [DTyVarBndr]` to `DInstanceD` and+ `DStandaloneDerivD` for optionally quantifying type variables explicitly.+ If supplied with a `Just`, this sweetens the instance type to use a `ForallT`+ to represent the explicit quantification. This trick is not supported for+ `InstanceD` on GHC 8.0 and for `StandaloneDerivD` on GHC 7.10 or 8.0, so be+ aware of this limitation if you supply `Just` for this field.+* Add support for desugaring implicit params. This does not involve any changes+ to the `th-desugar` AST, as:+ * `(?x :: a) => ...` is desugared to `IP "x" a => ...`.+ * `id ?x` is desugared to `id (ip @"x")`.+ * `let ?x = 42 in ...` is desugared to+ `let new_x_val = 42 in bindIP @"x" new_x_val ...` (where `bindIP` is a new+ utility function exported by `Language.Haskell.TH.Desugar` on GHC 8.0 or+ later).++ In order to support this desugaring, the type signatures of `dsLetDec` and+ `dsLetDecs` now return `([DLetDec], DExp -> DExp)` instead of just+ `[DLetDec]`, where `DExp -> DExp` is the expression which binds the values of+ implicit params (e.g., `\z -> bindIP @"x" new_x_val z`) if any are bound.+ (If none are bound, this is simply the `id` function.)+* Fix a bug in which `toposortTyVarsOf` would error at runtime if given types+ containing `forall`s as arguments.+* Fix a bug in which `fvDType` would return incorrect results if given a type+ containing quantified constraints.+* Fix a bug in which `expandType` would not expand type synonyms in the kinds+ of type variable binders in `forall`s.+* Fix a bug in which `getRecordSelectors` would omit record selectors from+ GADT constructors.+* Fix a bug in which `toposortTyVarsOf` would sometimes not preserve+ the left-to-right ordering of `Name`s generated with `qNewName`.+* Locally reified class methods, data constructors, and record selectors now+ quantify kind variables properly.+* Desugared ADT constructors now quantify kind variables properly.+* Remove `DPred`, as it has become too similar to `DType`. This also means+ that the `DPat` constructors, which previously ended with the suffix `Pa`,+ can now use the suffix `P`, mirroring TH.+* The type of `applyDType` has changed from `DType -> [DType] -> DType` to+ `DType -> [DTypeArg] -> DType`, where `DTypeArg` is a new data type that+ encodes whether an argument is a normal type argument (e.g., the `Int` in+ `Maybe Int`) or a visible kind argument (e.g., the `@Type` in+ `Proxy @Type Char`). A `TypeArg` data type (which is like `DTypeArg`, but+ with `Type`s/`Kind`s instead of `DType`s/`DKind`s) is also provided.++ A handful of utility functions for manipulating `TypeArg`s and `DTypeArg`s+ are also exported.+* `th-desugar` functions that compute free variables (e.g., `fvDType`) now+ return an `OSet`, a variant of `Set` that remembers the order in which+ elements were inserted. A consequence of this change is that it fixes a bug+ that causes free variables to be computed in different orders depending on+ which unique numbers GHC happened to generate internally.+* Substition and type synonym expansion are now more efficient by avoiding+ the use of `syb` in inner loops.++Version 1.9+-----------+* Suppose GHC 8.6.++* Add support for `DerivingVia`. Correspondingly, there is now a+ `DDerivStrategy` data type.++* Add support for `QuantifiedConstraints`. Correspondingly, there is now a+ `DForallPr` constructor in `DPred` to represent quantified constraint types.++* Remove the `DStarT` constructor of `DType` in favor of `DConT ''Type`.+ Two utility functions have been added to `Language.Haskell.TH.Desugar` to+ ease this transition:++ * `isTypeKindName`: returns `True` if the argument `Name` is that+ of `Type` or `★` (or `*`, to support older GHCs).+ * `typeKindName`: the name of `Type` (on GHC 8.0 or later) or `*` (on older+ GHCs).++* `th-desugar` now desugars all data types to GADT syntax. The most significant+ API-facing changes resulting from this new design are:++ * The `DDataD`, `DDataFamilyD`, and `DDataFamInstD` constructors of `DDec`+ now have `Maybe DKind` fields that either have `Just` an explicit return+ kind (e.g., the `k -> Type -> Type` in `data Foo :: k -> Type -> Type`)+ or `Nothing` (if lacking an explicit return kind).+ * The `DCon` constructor previously had a field of type `Maybe DType`, since+ there was a possibility it could be a GADT (with an explicit return type)+ or non-GADT (without an explicit return type) constructor. Since all data+ types are desugared to GADTs now, this field has been changed to be simply+ a `DType`.+ * The type signature of `dsCon` was previously:++ ```haskell+ dsCon :: DsMonad q => Con -> q [DCon]+ ```++ However, desugaring constructors now needs more information than before,+ since GADT constructors have richer type signatures. Accordingly, the type+ of `dsCon` is now:++ ```haskell+ dsCon :: DsMonad q+ => [DTyVarBndr] -- ^ The universally quantified type variables+ -- (used if desugaring a non-GADT constructor)+ -> DType -- ^ The original data declaration's type+ -- (used if desugaring a non-GADT constructor).+ -> Con -> q [DCon]+ ```++ The `instance Desugar [Con] [DCon]` has also been removed, as the previous+ implementation of `desugar` (`concatMapM dsCon`) no longer has enough+ information to work.++ Some other utility functions have also been added as part of this change:++ * A `conExistentialTvbs` function has been introduced to determine the+ existentially quantified type variables of a `DCon`. Note that this+ function is not 100% accurate—refer to the documentation for+ `conExistentialTvbs` for more information.++ * A `mkExtraDKindBinders` function has been introduced to turn a data type's+ return kind into explicit, fresh type variable binders.++ * A `toposortTyVarsOf` function, which finds the free variables of a list of+ `DType`s and returns them in a well scoped list that has been sorted in+ reverse topological order.++* `th-desugar` now desugars partial pattern matches in `do`-notation and+ list/monad comprehensions to the appropriate invocation of `fail`.+ (Previously, these were incorrectly desugared into `case` expressions with+ incomplete patterns.)++* Add a `mkDLamEFromDPats` function for constructing a `DLamE` expression using+ a list of `DPat` arguments and a `DExp` body.++* Add an `unravel` function for decomposing a function type into its `forall`'d+ type variables, its context, its argument types, and its result type.++* Export a `substTyVarBndrs` function from `Language.Haskell.TH.Desugar.Subst`,+ which substitutes over type variable binders in a capture-avoiding fashion.++* `getDataD`, `dataConNameToDataName`, and `dataConNameToCon` from+ `Language.Haskell.TH.Desugar.Reify` now look up local declarations. As a+ result, the contexts in their type signatures have been strengthened from+ `Quasi` to `DsMonad`.++* Export a `dTyVarBndrToDType` function which converts a `DTyVarBndr` to a+ `DType`, which preserves its kind.++* Previously, `th-desugar` would silently accept illegal uses of record+ construction with fields that did not belong to the constructor, such as+ `Identity { notAField = "wat" }`. This is now an error.++Version 1.8+-----------+* Support GHC 8.4.++* `substTy` now properly substitutes into kind signatures.++* Expose `fvDType`, which computes the free variables of a `DType`.++* Incorporate a `DDeclaredInfix` field into `DNormalC` to indicate if it is+ a constructor that was declared infix.++* Implement `lookupValueNameWithLocals`, `lookupTypeNameWithLocals`,+ `mkDataNameWithLocals`, and `mkTypeNameWithLocals`, counterparts to+ `lookupValueName`, `lookupTypeName`, `mkDataName`, and `mkTypeName` which+ have access to local Template Haskell declarations.++* Implement `reifyNameSpace` to determine a `Name`'s `NameSpace`.++* Export `reifyFixityWithLocals` from `Language.Haskell.TH.Desugar`.++* Export `matchTy` (among other goodies) from new module `Language.Haskell.TH.Subst`.+ This function matches a type template against a target.++Version 1.7+-----------+* Support for TH's support for `TypeApplications`, thanks to @RyanGlScott.++* Support for unboxed sums, thanks to @RyanGlScott.++* Support for `COMPLETE` pragmas.++* `getRecordSelectors` now requires a list of `DCon`s as an argument. This+ makes it easier to return correct record selector bindings in the event that+ a record selector appears in multiple constructors. (See+ [goldfirere/singletons#180](https://github.com/goldfirere/singletons/issues/180)+ for an example of where the old behavior of `getRecordSelectors` went wrong.)++* Better type family expansion (expanding an open type family with variables works now).++Version 1.6+-----------+* Work with GHC 8, with thanks to @christiaanb for getting this change going.+ 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,455 @@-{- 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.hs++(c) Richard Eisenberg 2013+rae@cs.brynmawr.edu+-}++{-# LANGUAGE CPP, MultiParamTypeClasses, FunctionalDependencies,+ TypeSynonymInstances, FlexibleInstances, LambdaCase,+ ScopedTypeVariables, PatternSynonyms #-}++-----------------------------------------------------------------------------+-- |+-- 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(..),+ DTyVarBndrVis,+#if __GLASGOW_HASKELL__ >= 907+ BndrVis(..),+#else+ BndrVis,+ pattern BndrReq,+ pattern BndrInvis,+#endif+ DMatch(..), DClause(..), DDec(..),+ DDerivClause(..), DDerivStrategy(..), DPatSynDir(..), DPatSynType,+ Overlap(..), PatSynArgs(..), DataFlavor(..),+ DTypeFamilyHead(..), DFamilyResultSig(..), InjectivityAnn(..),+ DCon(..), DConFields(..), 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, dsTvbVis, 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,+ tupleNameDegree_maybe,+ unboxedSumNameDegree_maybe, unboxedTupleNameDegree_maybe,+ isTypeKindName, typeKindName, bindIP,+ mkExtraDKindBinders, dTyVarBndrToDType, changeDTVFlags,+ toposortTyVarsOf, toposortKindVarsOfTvbs,++ -- ** 'FunArgs' and 'VisFunArg'+ FunArgs(..), ForallTelescope(..), VisFunArg(..),+ filterVisFunArgs, ravelType, unravelType,++ -- ** 'DFunArgs' and 'DVisFunArg'+ DFunArgs(..), DVisFunArg(..),+ filterDVisFunArgs, ravelDType, unravelDType,++ -- ** 'TypeArg'+ TypeArg(..), applyType, filterTANormals,+ tyVarBndrVisToTypeArg, tyVarBndrVisToTypeArgWithSig,+ unfoldType,++ -- ** 'DTypeArg'+ DTypeArg(..), applyDType, filterDTANormals,+ dTyVarBndrVisToDTypeArg, dTyVarBndrVisToDTypeArgWithSig,+ unfoldDType,++ -- ** Extracting bound names+ extractBoundNamesStmt, extractBoundNamesDec, extractBoundNamesPat+ ) where++import Language.Haskell.TH.Datatype.TyVarBndr+import Language.Haskell.TH.Desugar.AST+import Language.Haskell.TH.Desugar.Core+import Language.Haskell.TH.Desugar.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 [DTyVarBndrVis]+mkExtraDKindBinders k = do+ k' <- expandType k+ let (fun_args, _) = unravelDType k'+ vis_fun_args = filterDVisFunArgs fun_args+ mapM mk_tvb vis_fun_args+ where+ mk_tvb :: DVisFunArg -> q (DTyVarBndrVis)+ mk_tvb (DVisFADep tvb) = return (BndrReq <$ tvb)+ mk_tvb (DVisFAAnon ki) = do+ name <- qNewName "a"+ pure $ DKindedTV name BndrReq 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,313 +1,321 @@-{- 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/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+#if __GLASGOW_HASKELL__ < 907+import Language.Haskell.TH.Datatype.TyVarBndr (BndrVis)+#endif++import Language.Haskell.TH.Desugar.Util (DataFlavor)++-- | Corresponds to TH's @Exp@ type. Note that @DLamE@ takes names, not patterns.+data DExp = DVarE Name+ | DConE Name+ | DLitE Lit+ | DAppE DExp DExp+ | DAppTypeE DExp DType+ | DLamE [Name] DExp+ | DCaseE DExp [DMatch]+ | DLetE [DLetDec] DExp+ | DSigE DExp DType+ | DStaticE DExp+ | DTypedBracketE DExp+ | DTypedSpliceE 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 @TyVarBndrVis@+type DTyVarBndrVis = DTyVarBndr BndrVis++-- | 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 [DTyVarBndrVis] (Maybe DKind) [DCon] [DDerivClause]+ | DTySynD Name [DTyVarBndrVis] DType+ | DClassD DCxt Name [DTyVarBndrVis] [FunDep] [DDec]+ -- | Note that the @Maybe [DTyVarBndrUnit]@ field is dropped+ -- entirely when sweetened, so it is only useful for functions+ -- that directly consume @DDec@s.+ | DInstanceD (Maybe Overlap) (Maybe [DTyVarBndrUnit]) DCxt DType [DDec]+ | DForeignD DForeign+ | DOpenTypeFamilyD DTypeFamilyHead+ | DClosedTypeFamilyD DTypeFamilyHead [DTySynEqn]+ | DDataFamilyD Name [DTyVarBndrVis] (Maybe DKind)+ -- | A data family instance declaration. Note that desugaring+ -- upholds the following properties regarding the 'DataFlavor'+ -- field:+ --+ -- * If the 'DataFlavor' is 'NewType', then there will be exactly+ -- one 'DCon'.+ --+ -- * The 'DataFlavor' will never be 'TypeData', as GHC does not+ -- permit combining data families with @type data@.+ | DDataInstD DataFlavor DCxt (Maybe [DTyVarBndrUnit]) DType (Maybe DKind)+ [DCon] [DDerivClause]+ | DTySynInstD DTySynEqn+ | DRoleAnnotD Name [Role]+ -- | Note that the @Maybe [DTyVarBndrUnit]@ field is dropped+ -- entirely when sweetened, so it is only useful for functions+ -- that directly consume @DDec@s.+ | DStandaloneDerivD (Maybe DDerivStrategy) (Maybe [DTyVarBndrUnit]) DCxt DType+ | DDefaultSigD Name DType+ | DPatSynD Name PatSynArgs DPatSynDir DPat+ | DPatSynSigD Name DPatSynType+ | DKiSigD Name DKind+ -- DKiSigD is part of DDec, not DLetDec, because standalone kind+ -- signatures can only appear on the top level.+ | DDefaultD [DType]+ deriving (Eq, Show, Data, Generic, Lift)++-- | Corresponds to TH's 'PatSynDir' type+data DPatSynDir = DUnidir -- ^ @pattern P x {<-} p@+ | DImplBidir -- ^ @pattern P x {=} p@+ | DExplBidir [DClause] -- ^ @pattern P x {<-} p where P x = e@+ deriving (Eq, Show, Data, Generic, Lift)++-- | Corresponds to TH's 'PatSynType' type+type DPatSynType = DType++#if __GLASGOW_HASKELL__ < 801+-- | Same as @PatSynArgs@ from TH; defined here for backwards compatibility.+data PatSynArgs+ = PrefixPatSyn [Name] -- ^ @pattern P {x y z} = p@+ | InfixPatSyn Name Name -- ^ @pattern {x P y} = p@+ | RecordPatSyn [Name] -- ^ @pattern P { {x,y,z} } = p@+ deriving (Eq, Show, Data, Generic, Lift)+#endif++-- | Corresponds to TH's 'TypeFamilyHead' type+data DTypeFamilyHead = DTypeFamilyHead Name [DTyVarBndrVis] DFamilyResultSig+ (Maybe InjectivityAnn)+ deriving (Eq, Show, Data, Generic, Lift)++-- | Corresponds to TH's 'FamilyResultSig' type+data DFamilyResultSig = DNoSig+ | DKindSig DKind+ | DTyVarSig DTyVarBndrUnit+ deriving (Eq, Show, Data, Generic, Lift)++-- | Corresponds to TH's 'Con' type. Unlike 'Con', all 'DCon's reflect GADT+-- syntax. This is beneficial for @th-desugar@'s since it means+-- that all data type declarations can support explicit return kinds, so+-- one does not need to represent them with something like @'Maybe' 'DKind'@,+-- since Haskell98-style data declaration syntax isn't used. Accordingly,+-- there are some differences between 'DCon' and 'Con' to keep in mind:+--+-- * Unlike 'ForallC', where the meaning of the 'TyVarBndr's changes depending+-- on whether it's followed by 'GadtC'/'RecGadtC' or not, the meaning of the+-- 'DTyVarBndr's in a 'DCon' is always the same: it is the list of+-- universally /and/ existentially quantified type variables. Note that it is+-- not guaranteed that one set of type variables will appear before the+-- other.+--+-- * A 'DCon' always has an explicit return type.+data DCon = DCon [DTyVarBndrSpec] DCxt Name DConFields+ DType -- ^ The GADT result type+ deriving (Eq, Show, Data, Generic, Lift)++-- | A list of fields either for a standard data constructor or a record+-- data constructor.+data DConFields = DNormalC DDeclaredInfix [DBangType]+ | DRecC [DVarBangType]+ deriving (Eq, Show, Data, Generic, Lift)++-- | 'True' if a constructor is declared infix. For normal ADTs, this means+-- that is was written in infix style. For example, both of the constructors+-- below are declared infix.+--+-- @+-- data Infix = Int `Infix` Int | Int :*: Int+-- @+--+-- Whereas neither of these constructors are declared infix:+--+-- @+-- data Prefix = Prefix Int Int | (:+:) Int Int+-- @+--+-- For GADTs, detecting whether a constructor is declared infix is a bit+-- trickier, as one cannot write a GADT constructor "infix-style" like one+-- can for normal ADT constructors. GHC considers a GADT constructor to be+-- declared infix if it meets the following three criteria:+--+-- 1. Its name uses operator syntax (e.g., @(:*:)@).+-- 2. It has exactly two fields (without record syntax).+-- 3. It has a programmer-specified fixity declaration.+--+-- For example, in the following GADT:+--+-- @+-- infixl 5 :**:, :&&:, :^^:, `ActuallyPrefix`+-- data InfixGADT a where+-- (:**:) :: Int -> b -> InfixGADT (Maybe b) -- Only this one is infix+-- ActuallyPrefix :: Char -> Bool -> InfixGADT Double+-- (:&&:) :: { infixGADT1 :: b, infixGADT2 :: Int } -> InfixGADT [b]+-- (:^^:) :: Int -> Int -> Int -> InfixGADT Int+-- (:!!:) :: Char -> Char -> InfixGADT Char+-- @+--+-- Only the @(:**:)@ constructor is declared infix. The other constructors+-- are not declared infix, because:+--+-- * @ActuallyPrefix@ does not use operator syntax (criterion 1).+-- * @(:&&:)@ uses record syntax (criterion 2).+-- * @(:^^:)@ does not have exactly two fields (criterion 2).+-- * @(:!!:)@ does not have a programmer-specified fixity declaration (criterion 3).+type DDeclaredInfix = Bool++-- | Corresponds to TH's @BangType@ type.+type DBangType = (Bang, DType)++-- | Corresponds to TH's @VarBangType@ type.+type DVarBangType = (Name, Bang, DType)++-- | Corresponds to TH's @Foreign@ type.+data DForeign = DImportF Callconv Safety String Name DType+ | DExportF Callconv String Name DType+ deriving (Eq, Show, Data, Generic, Lift)++-- | Corresponds to TH's @Pragma@ type.+data DPragma = DInlineP Name Inline RuleMatch Phases+ | 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,1986 +1,2056 @@-{- 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/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 Data.Function (on)+import qualified Data.List as L+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+#if __GLASGOW_HASKELL__ >= 907+dsExp (TypedBracketE exp) = DTypedBracketE <$> dsExp exp+dsExp (TypedSpliceE exp) = DTypedSpliceE <$> dsExp exp+#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 dsTvbVis tvbs <*> dsType ty)+dsDec (ClassD cxt n tvbs fds decs) =+ (:[]) <$> (DClassD <$> dsCxt cxt <*> pure n <*> mapM dsTvbVis tvbs+ <*> pure fds <*> dsDecs decs)+dsDec (InstanceD over cxt ty decs) =+ (:[]) <$> (DInstanceD over Nothing <$> dsCxt cxt <*> dsType ty <*> dsDecs decs)+dsDec d@(SigD {}) = dsTopLevelLetDec d+dsDec (ForeignD f) = (:[]) <$> (DForeignD <$> dsForeign f)+dsDec d@(InfixD {}) = dsTopLevelLetDec d+dsDec d@(PragmaD {}) = dsTopLevelLetDec d+dsDec (OpenTypeFamilyD tfHead) =+ (:[]) <$> (DOpenTypeFamilyD <$> dsTypeFamilyHead tfHead)+dsDec (DataFamilyD n tvbs m_k) =+ (:[]) <$> (DDataFamilyD n <$> mapM dsTvbVis tvbs <*> mapM dsType m_k)+#if __GLASGOW_HASKELL__ >= 807+dsDec (DataInstD cxt mtvbs lhs mk cons derivings) =+ case unfoldType lhs of+ (ConT n, tys) -> dsDataInstDec Data cxt n mtvbs tys mk cons derivings+ (_, _) -> fail $ "Unexpected data instance LHS: " ++ pprint lhs+dsDec (NewtypeInstD cxt mtvbs lhs mk con derivings) =+ case unfoldType lhs of+ (ConT n, tys) -> dsDataInstDec Newtype cxt n mtvbs tys mk [con] derivings+ (_, _) -> fail $ "Unexpected newtype instance LHS: " ++ pprint lhs+#else+dsDec (DataInstD cxt n tys mk cons derivings) =+ dsDataInstDec Data cxt n Nothing (map TANormal tys) mk cons derivings+dsDec (NewtypeInstD cxt n tys mk con derivings) =+ dsDataInstDec Newtype cxt n Nothing (map TANormal tys) mk [con] derivings+#endif+#if __GLASGOW_HASKELL__ >= 807+dsDec (TySynInstD eqn) = (:[]) <$> (DTySynInstD <$> dsTySynEqn unusedArgument eqn)+#else+dsDec (TySynInstD n eqn) = (:[]) <$> (DTySynInstD <$> dsTySynEqn n eqn)+#endif+dsDec (ClosedTypeFamilyD tfHead eqns) =+ (:[]) <$> (DClosedTypeFamilyD <$> dsTypeFamilyHead tfHead+ <*> mapM (dsTySynEqn (typeFamilyHeadName tfHead)) eqns)+dsDec (RoleAnnotD n roles) = return [DRoleAnnotD n roles]+#if __GLASGOW_HASKELL__ >= 801+dsDec (PatSynD n args dir pat) = do+ dir' <- dsPatSynDir n dir+ (pat', vars) <- dsPatX pat+ unless (null vars) $+ fail $ "Pattern synonym definition cannot contain as-patterns (@)."+ return [DPatSynD n args dir' pat']+dsDec (PatSynSigD n ty) = (:[]) <$> (DPatSynSigD n <$> dsType ty)+dsDec (StandaloneDerivD mds cxt ty) =+ (:[]) <$> (DStandaloneDerivD <$> mapM dsDerivStrategy mds+ <*> pure Nothing <*> dsCxt cxt <*> dsType ty)+#else+dsDec (StandaloneDerivD cxt ty) =+ (:[]) <$> (DStandaloneDerivD Nothing Nothing <$> dsCxt cxt <*> dsType ty)+#endif+dsDec (DefaultSigD n ty) = (:[]) <$> (DDefaultSigD n <$> dsType ty)+#if __GLASGOW_HASKELL__ >= 807+dsDec (ImplicitParamBindD {}) = impossible "Non-`let`-bound implicit param binding"+#endif+#if __GLASGOW_HASKELL__ >= 809+dsDec (KiSigD n ki) = (:[]) <$> (DKiSigD n <$> dsType ki)+#endif+#if __GLASGOW_HASKELL__ >= 903+dsDec (DefaultD tys) = (:[]) <$> (DDefaultD <$> mapM dsType tys)+#endif+#if __GLASGOW_HASKELL__ >= 906+dsDec (TypeDataD n tys mk cons) =+ dsDataDec TypeData [] n tys mk cons []+#endif++-- | Desugar a 'DataD', 'NewtypeD', or 'TypeDataD'.+dsDataDec :: DsMonad q+ => DataFlavor -> Cxt -> Name -> [TyVarBndrVis]+ -> Maybe Kind -> [Con] -> [DerivingClause] -> q [DDec]+dsDataDec nd cxt n tvbs mk cons derivings = do+ tvbs' <- mapM dsTvbVis tvbs+ 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 =+ changeDTVFlags defaultBndrFlag $+ case (mk, mtvbs') of+ -- If there's an explicit return kind, we're dealing with a+ -- GADT, so this argument goes unused in dsCon.+ (Just {}, _) -> unusedArgument+ -- H98, and there is an explicit `forall` in front. Just reuse the+ -- type variable binders from the `forall`.+ (Nothing, Just tvbs') -> tvbs'+ -- H98, and no explicit `forall`. Compute the bound variables+ -- manually.+ (Nothing, Nothing) -> dataFamInstTvbs tys'+ h98_fam_inst_type = dataFamInstReturnType n tys'+ (:[]) <$> (DDataInstD nd <$> dsCxt cxt <*> pure mtvbs'+ <*> pure lhs' <*> mapM dsType mk+ <*> concatMapM (dsCon h98_tvbs h98_fam_inst_type) cons+ <*> mapM dsDerivClause derivings)++-- | Desugar a @FamilyResultSig@+dsFamilyResultSig :: DsMonad q => FamilyResultSig -> q DFamilyResultSig+dsFamilyResultSig NoSig = return DNoSig+dsFamilyResultSig (KindSig k) = DKindSig <$> dsType k+dsFamilyResultSig (TyVarSig tvb) = DTyVarSig <$> dsTvbUnit tvb++-- | Desugar a @TypeFamilyHead@+dsTypeFamilyHead :: DsMonad q => TypeFamilyHead -> q DTypeFamilyHead+dsTypeFamilyHead (TypeFamilyHead n tvbs result inj)+ = DTypeFamilyHead n <$> mapM dsTvbVis tvbs+ <*> dsFamilyResultSig result+ <*> pure inj++typeFamilyHeadName :: TypeFamilyHead -> Name+typeFamilyHeadName (TypeFamilyHead n _ _ _) = n++-- | Desugar @Dec@s that can appear in a @let@ expression. See the+-- documentation for 'dsLetDec' for an explanation of what the return type+-- represents.+dsLetDecs :: DsMonad q => [Dec] -> q ([DLetDec], DExp -> DExp)+dsLetDecs decs = do+ (let_decss, ip_binders) <- mapAndUnzipM dsLetDec decs+ let let_decs :: [DLetDec]+ let_decs = concat let_decss++ ip_binder :: DExp -> DExp+ ip_binder = foldr (.) id ip_binders+ return (let_decs, ip_binder)++-- | Desugar a single 'Dec' that can appear in a @let@ expression.+-- This produces the following output:+--+-- * One or more 'DLetDec's (a single 'Dec' can produce multiple 'DLetDec's+-- in the event of a value declaration that binds multiple things by way+-- of pattern matching.+--+-- * A function of type @'DExp' -> 'DExp'@, which should be applied to the+-- expression immediately following the 'DLetDec's. This function prepends+-- binding forms for any implicit params that were bound in the argument+-- 'Dec'. (If no implicit params are bound, this is simply the 'id'+-- function.)+--+-- For instance, if the argument to 'dsLetDec' is the @?x = 42@ part of this+-- expression:+--+-- @+-- let { ?x = 42 } in ?x+-- @+--+-- Then the output is:+--+-- * @let new_x_val = 42@+--+-- * @\\z -> 'bindIP' \@\"x\" new_x_val z@+--+-- This way, the expression+-- @let { new_x_val = 42 } in 'bindIP' \@"x" new_x_val ('ip' \@\"x\")@ can be+-- formed. The implicit param binders always come after all the other+-- 'DLetDec's to support parallel assignment of implicit params.+dsLetDec :: DsMonad q => Dec -> q ([DLetDec], DExp -> DExp)+dsLetDec (FunD name clauses) = do+ clauses' <- dsClauses (FunRhs name) clauses+ return ([DFunD name clauses'], id)+dsLetDec (ValD pat body where_decs) = do+ (pat', vars) <- dsPatX pat+ body' <- dsBody body where_decs error_exp+ let extras = uncurry (zipWith (DValD . DVarP)) $ unzip vars+ return (DValD pat' body' : extras, id)+ where+ error_exp = mkErrorMatchExpr (LetDecRhs pat)+dsLetDec (SigD name ty) = do+ ty' <- dsType ty+ return ([DSigD name ty'], id)+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+ => [DTyVarBndrVis] -- ^ 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 $+ toposortKindVarsOfTvbs expl_dtvbs in+ DCon (impl_dtvbs ++ expl_dtvbs) dcxt n fields data_type+ Just gadt_type ->+ let univ_ex_dtvbs = dtvbs in+ DCon univ_ex_dtvbs dcxt n fields gadt_type++-- Desugar a Con in isolation. The meaning of the returned DTyVarBndrs changes+-- depending on what the returned Maybe DType value is:+--+-- * If returning Just gadt_ty, then we've encountered a GadtC or RecGadtC,+-- so the returned DTyVarBndrs are both the universally and existentially+-- quantified tyvars.+-- * If returning Nothing, we're dealing with a non-GADT constructor, so+-- the returned DTyVarBndrs are the existentials only.+dsCon' :: DsMonad q+ => Con -> q [(Name, [DTyVarBndrSpec], DCxt, DConFields, Maybe DType)]+dsCon' (NormalC n stys) = do+ dtys <- mapM dsBangType stys+ return [(n, [], [], DNormalC False dtys, Nothing)]+dsCon' (RecC n vstys) = do+ vdtys <- mapM dsVarBangType vstys+ return [(n, [], [], DRecC vdtys, Nothing)]+dsCon' (InfixC sty1 n sty2) = do+ dty1 <- dsBangType sty1+ dty2 <- dsBangType sty2+ return [(n, [], [], DNormalC True [dty1, dty2], Nothing)]+dsCon' (ForallC tvbs cxt con) = do+ dtvbs <- mapM dsTvbSpec tvbs+ dcxt <- dsCxt cxt+ dcons' <- dsCon' con+ return $ flip map dcons' $ \(n, dtvbs', dcxt', fields, m_gadt_type) ->+ (n, dtvbs ++ dtvbs', dcxt ++ dcxt', fields, m_gadt_type)+dsCon' (GadtC nms btys rty) = do+ dbtys <- mapM dsBangType btys+ drty <- dsType rty+ sequence $ flip map nms $ \nm -> do+ mbFi <- reifyFixityWithLocals nm+ -- A GADT data constructor is declared infix when these three+ -- properties hold:+ let decInfix = isInfixDataCon (nameBase nm) -- 1. Its name uses operator syntax+ -- (e.g., (:*:))+ && length dbtys == 2 -- 2. It has exactly two fields+ && isJust mbFi -- 3. It has a programmer-specified+ -- fixity declaration+ return (nm, [], [], DNormalC decInfix dbtys, Just drty)+dsCon' (RecGadtC nms vbtys rty) = do+ dvbtys <- mapM dsVarBangType vbtys+ drty <- dsType rty+ return $ flip map nms $ \nm ->+ (nm, [], [], DRecC dvbtys, Just drty)++-- | Desugar a @BangType@.+dsBangType :: DsMonad q => BangType -> q DBangType+dsBangType (b, ty) = (b, ) <$> dsType ty++-- | Desugar a @VarBangType@.+dsVarBangType :: DsMonad q => VarBangType -> q DVarBangType+dsVarBangType (n, b, ty) = (n, b, ) <$> dsType ty++-- | Desugar a @Foreign@.+dsForeign :: DsMonad q => Foreign -> q DForeign+dsForeign (ImportF cc safety str n ty) = DImportF cc safety str n <$> dsType ty+dsForeign (ExportF cc str n ty) = DExportF cc str n <$> dsType ty++-- | Desugar a @Pragma@.+dsPragma :: DsMonad q => Pragma -> q DPragma+dsPragma (InlineP n inl rm phases) = return $ DInlineP n inl rm phases+dsPragma (SpecialiseP n ty m_inl phases) = DSpecialiseP n <$> dsType ty+ <*> pure m_inl+ <*> pure phases+dsPragma (SpecialiseInstP ty) = DSpecialiseInstP <$> dsType ty+#if __GLASGOW_HASKELL__ >= 807+dsPragma (RuleP str mtvbs rbs lhs rhs phases)+ = DRuleP str <$> mapM (mapM dsTvbUnit) mtvbs+ <*> mapM dsRuleBndr rbs+ <*> dsExp lhs+ <*> dsExp rhs+ <*> pure phases+#else+dsPragma (RuleP str rbs lhs rhs phases) = DRuleP str Nothing+ <$> mapM dsRuleBndr rbs+ <*> dsExp lhs+ <*> dsExp rhs+ <*> pure phases+#endif+dsPragma (AnnP target exp) = DAnnP target <$> dsExp exp+dsPragma (LineP n str) = return $ DLineP n str+#if __GLASGOW_HASKELL__ >= 801+dsPragma (CompleteP cls mty) = return $ DCompleteP cls mty+#endif+#if __GLASGOW_HASKELL__ >= 903+dsPragma (OpaqueP n) = return $ DOpaqueP n+#endif++-- | 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 'TyVarBndrVis'.+dsTvbVis :: DsMonad q => TyVarBndrVis -> q DTyVarBndrVis+#if __GLASGOW_HASKELL__ >= 900+dsTvbVis = dsTvb+#else+dsTvbVis = dsTvb BndrReq+#endif++-- | Desugar a @Cxt@+dsCxt :: DsMonad q => Cxt -> q DCxt+dsCxt = concatMapM dsPred++#if __GLASGOW_HASKELL__ >= 801+-- | A backwards-compatible type synonym for the thing representing a single+-- derived class in a @deriving@ clause. (This is a @DerivClause@, @Pred@, or+-- @Name@ depending on the GHC version.)+type DerivingClause = DerivClause++-- | Desugar a @DerivingClause@.+dsDerivClause :: DsMonad q => DerivingClause -> q DDerivClause+dsDerivClause (DerivClause mds cxt) =+ DDerivClause <$> mapM dsDerivStrategy mds <*> dsCxt cxt+#else+type DerivingClause = Pred++dsDerivClause :: DsMonad q => DerivingClause -> q DDerivClause+dsDerivClause p = DDerivClause Nothing <$> dsPred p+#endif++#if __GLASGOW_HASKELL__ >= 801+-- | Desugar a @DerivStrategy@.+dsDerivStrategy :: DsMonad q => DerivStrategy -> q DDerivStrategy+dsDerivStrategy StockStrategy = pure DStockStrategy+dsDerivStrategy AnyclassStrategy = pure DAnyclassStrategy+dsDerivStrategy NewtypeStrategy = pure DNewtypeStrategy+#if __GLASGOW_HASKELL__ >= 805+dsDerivStrategy (ViaStrategy ty) = DViaStrategy <$> dsType ty+#endif+#endif++#if __GLASGOW_HASKELL__ >= 801+-- | Desugar a @PatSynDir@. (Available only with GHC 8.2+)+dsPatSynDir :: DsMonad q => Name -> PatSynDir -> q DPatSynDir+dsPatSynDir _ Unidir = pure DUnidir+dsPatSynDir _ ImplBidir = pure DImplBidir+dsPatSynDir n (ExplBidir clauses) = DExplBidir <$> dsClauses (FunRhs n) clauses+#endif++-- | Desugar a @Pred@, flattening any internal tuples+dsPred :: DsMonad q => Pred -> q DCxt+dsPred t+ | Just ts <- splitTuple_maybe t+ = concatMapM dsPred ts+dsPred (ForallT tvbs cxt p) = dsForallPred tvbs cxt p+dsPred (AppT t1 t2) = do+ [p1] <- dsPred t1 -- tuples can't be applied!+ (:[]) <$> DAppT p1 <$> dsType t2+dsPred (SigT ty ki) = do+ preds <- dsPred ty+ case preds of+ [p] -> (:[]) <$> DSigT p <$> dsType ki+ other -> return other -- just drop the kind signature on a tuple.+dsPred (VarT n) = return [DVarT n]+dsPred (ConT n) = return [DConT n]+dsPred t@(PromotedT _) =+ impossible $ "Promoted type seen as head of constraint: " ++ show t+dsPred (TupleT 0) = return [DConT (tupleTypeName 0)]+dsPred (TupleT _) =+ impossible "Internal error in th-desugar in detecting tuple constraints."+dsPred t@(UnboxedTupleT _) =+ impossible $ "Unboxed tuple seen as head of constraint: " ++ show t+dsPred ArrowT = impossible "Arrow seen as head of constraint."+dsPred ListT = impossible "List seen as head of constraint."+dsPred (PromotedTupleT _) =+ impossible "Promoted tuple seen as head of constraint."+dsPred PromotedNilT = impossible "Promoted nil seen as head of constraint."+dsPred PromotedConsT = impossible "Promoted cons seen as head of constraint."+dsPred StarT = impossible "* seen as head of constraint."+dsPred ConstraintT =+ impossible "The kind `Constraint' seen as head of constraint."+dsPred t@(LitT _) =+ impossible $ "Type literal seen as head of constraint: " ++ show t+dsPred EqualityT = return [DConT ''(~)]+dsPred (InfixT t1 n t2) = (:[]) <$> dsInfixT t1 n t2+dsPred (UInfixT{}) = dsUInfixT+dsPred (ParensT t) = dsPred t+dsPred WildCardT = return [DWildCardT]+#if __GLASGOW_HASKELL__ >= 801+dsPred t@(UnboxedSumT {}) =+ impossible $ "Unboxed sum seen as head of constraint: " ++ show t+#endif+#if __GLASGOW_HASKELL__ >= 807+dsPred (AppKindT t k) = do+ [p] <- dsPred t+ (:[]) <$> (DAppKindT p <$> dsType k)+dsPred (ImplicitParamT n t) = do+ t' <- dsType t+ return [DConT ''IP `DAppT` DLitT (StrTyLit n) `DAppT` t']+#endif+#if __GLASGOW_HASKELL__ >= 809+dsPred t@(ForallVisT {}) =+ impossible $ "Visible dependent quantifier seen as head of constraint: " ++ show t+#endif+#if __GLASGOW_HASKELL__ >= 900+dsPred MulArrowT = impossible "Linear arrow seen as head of constraint."+#endif+#if __GLASGOW_HASKELL__ >= 903+dsPred t@PromotedInfixT{} =+ impossible $ "Promoted infix type seen as head of constraint: " ++ show t+dsPred PromotedUInfixT{} = dsUInfixT+#endif++-- | Desugar a quantified constraint.+dsForallPred :: DsMonad q => [TyVarBndrSpec] -> Cxt -> Pred -> q DCxt+dsForallPred tvbs cxt p = do+ ps' <- dsPred p+ case ps' of+ [p'] -> (:[]) <$> (mkDForallConstrainedT <$>+ (DForallInvis <$> mapM dsTvbSpec tvbs) <*> dsCxt cxt <*> pure p')+ _ -> fail "Cannot desugar constraint tuples in the body of a quantified constraint"+ -- See GHC #15334.++-- | Like 'reify', but safer and desugared. Uses local declarations where+-- available.+dsReify :: DsMonad q => Name -> q (Maybe DInfo)+dsReify = traverse dsInfo <=< reifyWithLocals_maybe++-- | Like 'reifyType', but safer and desugared. Uses local declarations where+-- available.+dsReifyType :: DsMonad q => Name -> q (Maybe DType)+dsReifyType = traverse dsType <=< reifyTypeWithLocals_maybe++-- Given a list of `forall`ed type variable binders and a context, construct+-- a DType using DForallT and DConstrainedT as appropriate. The phrase+-- "as appropriate" is used because DConstrainedT will not be used if the+-- context is empty, per Note [Desugaring and sweetening ForallT].+mkDForallConstrainedT :: DForallTelescope -> DCxt -> DType -> DType+mkDForallConstrainedT tele ctxt ty =+ DForallT tele $ if null ctxt then ty else DConstrainedT ctxt ty++-- create a list of expressions in the same order as the fields in the first argument+-- but with the values as given in the second argument+-- if a field is missing from the second argument, use the corresponding expression+-- from the third argument+reorderFields :: DsMonad q => Name -> [VarStrictType] -> [FieldExp] -> [DExp] -> q [DExp]+reorderFields = reorderFields' dsExp++reorderFieldsPat :: DsMonad q => Name -> [VarStrictType] -> [FieldPat] -> PatM q [DPat]+reorderFieldsPat con_name field_decs field_pats =+ reorderFields' dsPat con_name field_decs field_pats (repeat DWildP)++reorderFields' :: (Applicative m, Fail.MonadFail m)+ => (a -> m da)+ -> Name -- ^ The name of the constructor (used for error reporting)+ -> [VarStrictType] -> [(Name, a)]+ -> [da] -> m [da]+reorderFields' ds_thing con_name field_names_types field_things deflts =+ check_valid_fields >> reorder field_names deflts+ where+ field_names = map (\(a, _, _) -> a) field_names_types++ check_valid_fields =+ forM_ field_things $ \(thing_name, _) ->+ unless (thing_name `elem` field_names) $+ fail $ "Constructor ‘" ++ nameBase con_name ++ "‘ does not have field ‘"+ ++ nameBase thing_name ++ "‘"++ reorder [] _ = return []+ reorder (field_name : rest) (deflt : rest_deflt) = do+ rest' <- reorder rest rest_deflt+ case find (\(thing_name, _) -> thing_name == field_name) field_things of+ Just (_, thing) -> (: rest') <$> ds_thing thing+ Nothing -> return $ deflt : rest'+ reorder (_ : _) [] = error "Internal error in th-desugar."++-- mkTupleDExp, 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++-- | Convert a 'DTyVarBndrVis' to a 'DTypeArg'. That is, convert a binder with a+-- 'BndrReq' visibility to a 'DTANormal' and a binder with 'BndrInvis'+-- visibility to a 'DTyArg'.+--+-- If given a 'DKindedTV', the resulting 'DTypeArg' will omit the kind+-- signature. Use 'dTyVarBndrVisToDTypeArgWithSig' if you want to preserve the+-- kind signature.+dTyVarBndrVisToDTypeArg :: DTyVarBndrVis -> DTypeArg+dTyVarBndrVisToDTypeArg bndr =+ case dtvbFlag bndr of+ BndrReq -> DTANormal bndr_ty+ BndrInvis -> DTyArg bndr_ty+ where+ bndr_ty = case bndr of+ DPlainTV a _ -> DVarT a+ DKindedTV a _ _ -> DVarT a++-- | Convert a 'DTyVarBndrVis' to a 'DTypeArg'. That is, convert a binder with a+-- 'BndrReq' visibility to a 'DTANormal' and a binder with 'BndrInvis'+-- visibility to a 'DTyArg'.+--+-- If given a 'DKindedTV', the resulting 'DTypeArg' will preserve the kind+-- signature. Use 'dTyVarBndrVisToDTypeArg' if you want to omit the kind+-- signature.+dTyVarBndrVisToDTypeArgWithSig :: DTyVarBndrVis -> DTypeArg+dTyVarBndrVisToDTypeArgWithSig bndr =+ case dtvbFlag bndr of+ BndrReq -> DTANormal bndr_ty+ BndrInvis -> DTyArg bndr_ty+ where+ bndr_ty = dTyVarBndrToDType bndr++-- | Extract the underlying 'DType' or 'DKind' from a 'DTypeArg'. This forgets+-- information about whether a type is a normal argument or not, so use with+-- caution.+probablyWrongUnDTypeArg :: DTypeArg -> DType+probablyWrongUnDTypeArg (DTANormal t) = t+probablyWrongUnDTypeArg (DTyArg k) = k++-- Take a data type name (which does not belong to a data family) and+-- apply it to its type variable binders to form a DType.+nonFamilyDataReturnType :: Name -> [DTyVarBndrVis] -> DType+nonFamilyDataReturnType con_name =+ applyDType (DConT con_name) . map dTyVarBndrVisToDTypeArg++-- Take a data family name and apply it to its argument types to form a+-- data family instance DType.+dataFamInstReturnType :: Name -> [DTypeArg] -> DType+dataFamInstReturnType fam_name = applyDType (DConT fam_name)++-- Data family instance declarations did not come equipped with a list of bound+-- type variables until GHC 8.8 (and even then, it's optional whether the user+-- provides them or not). This means that there are situations where we must+-- reverse engineer this information ourselves from the list of type+-- arguments. We accomplish this by taking the free variables of the types+-- and performing a reverse topological sort on them to ensure that the+-- returned list is well scoped.+dataFamInstTvbs :: [DTypeArg] -> [DTyVarBndrUnit]+dataFamInstTvbs = toposortTyVarsOf . map probablyWrongUnDTypeArg++-- | Take a list of 'DType's, find their free variables, and sort them in+-- reverse topological order to ensure that they are well scoped. In other+-- words, the free variables are ordered such that:+--+-- 1. Whenever an explicit kind signature of the form @(A :: K)@ is+-- encountered, the free variables of @K@ will always appear to the left of+-- the free variables of @A@ in the returned result.+--+-- 2. The constraint in (1) notwithstanding, free variables will appear in+-- left-to-right order of their original appearance.+--+-- On older GHCs, this takes measures to avoid returning explicitly bound+-- kind variables, which was not possible before @TypeInType@.+toposortTyVarsOf :: [DType] -> [DTyVarBndrUnit]+toposortTyVarsOf tys =+ let freeVars :: [Name]+ freeVars = F.toList $ foldMap fvDType tys++ varKindSigs :: Map Name DKind+ varKindSigs = foldMap go_ty tys+ where+ go_ty :: DType -> Map Name DKind+ go_ty (DForallT tele t) = go_tele tele (go_ty t)+ go_ty (DConstrainedT ctxt t) = foldMap go_ty ctxt `mappend` go_ty t+ go_ty (DAppT t1 t2) = go_ty t1 `mappend` go_ty t2+ go_ty (DAppKindT t k) = go_ty t `mappend` go_ty k+ go_ty (DSigT t k) =+ let kSigs = go_ty k+ in case t of+ DVarT n -> M.insert n k kSigs+ _ -> go_ty t `mappend` kSigs+ go_ty (DVarT {}) = mempty+ go_ty (DConT {}) = mempty+ go_ty DArrowT = mempty+ go_ty (DLitT {}) = mempty+ go_ty DWildCardT = mempty++ go_tele :: DForallTelescope -> Map Name DKind -> Map Name DKind+ go_tele (DForallVis tvbs) = go_tvbs tvbs+ go_tele (DForallInvis tvbs) = go_tvbs tvbs++ go_tvbs :: [DTyVarBndr flag] -> Map Name DKind -> Map Name DKind+ go_tvbs tvbs m = foldr go_tvb m tvbs++ go_tvb :: DTyVarBndr flag -> Map Name DKind -> Map Name DKind+ go_tvb (DPlainTV n _) m = M.delete n m+ go_tvb (DKindedTV n _ k) m = M.delete n m `mappend` go_ty k++ -- | Do a topological sort on a list of tyvars,+ -- so that binders occur before occurrences+ -- E.g. given [ a::k, k::*, b::k ]+ -- it'll return a well-scoped list [ k::*, a::k, b::k ]+ --+ -- This is a deterministic sorting operation+ -- (that is, doesn't depend on Uniques).+ --+ -- It is also meant to be stable: that is, variables should not+ -- be reordered unnecessarily.+ scopedSort :: [Name] -> [Name]+ scopedSort = go [] []++ go :: [Name] -- already sorted, in reverse order+ -> [Set Name] -- each set contains all the variables which must be placed+ -- before the tv corresponding to the set; they are accumulations+ -- of the fvs in the sorted tvs' kinds++ -- This list is in 1-to-1 correspondence with the sorted tyvars+ -- INVARIANT:+ -- all (\tl -> all (`isSubsetOf` head tl) (tail tl)) (tails fv_list)+ -- That is, each set in the list is a superset of all later sets.+ -> [Name] -- yet to be sorted+ -> [Name]+ go acc _fv_list [] = reverse acc+ go acc fv_list (tv:tvs)+ = go acc' fv_list' tvs+ where+ (acc', fv_list') = insert tv acc fv_list++ insert :: Name -- var to insert+ -> [Name] -- sorted list, in reverse order+ -> [Set Name] -- list of fvs, as above+ -> ([Name], [Set Name]) -- augmented lists+ insert tv [] [] = ([tv], [kindFVSet tv])+ insert tv (a:as) (fvs:fvss)+ | tv `S.member` fvs+ , (as', fvss') <- insert tv as fvss+ = (a:as', fvs `S.union` fv_tv : fvss')++ | otherwise+ = (tv:a:as, fvs `S.union` fv_tv : fvs : fvss)+ where+ fv_tv = kindFVSet tv++ -- lists not in correspondence+ insert _ _ _ = error "scopedSort"++ kindFVSet n =+ maybe S.empty (OS.toSet . fvDType)+ (M.lookup n varKindSigs)+ ascribeWithKind n =+ maybe (DPlainTV n ()) (DKindedTV n ()) (M.lookup n varKindSigs)++ in map ascribeWithKind $+ scopedSort freeVars++-- | Take a telescope of 'DTyVarBndr's, find the free variables in their kinds,+-- and sort them in reverse topological order to ensure that they are well+-- scoped. Because the argument list is assumed to be telescoping, kind+-- variables that are bound earlier in the list are not returned. For example,+-- this:+--+-- @+-- 'toposortKindVarsOfTvbs' [a :: k, b :: Proxy a]+-- @+--+-- Will return @[k]@, not @[k, a]@, since @a@ is bound earlier by @a :: k@.+toposortKindVarsOfTvbs :: [DTyVarBndr flag] -> [DTyVarBndrUnit]+toposortKindVarsOfTvbs tvbs =+ foldr (\tvb kvs ->+ foldMap (\t -> toposortTyVarsOf [t]) (extractTvbKind tvb) `L.union`+ L.deleteBy ((==) `on` dtvbName) tvb kvs)+ []+ (changeDTVFlags () tvbs)++dtvbName :: DTyVarBndr flag -> Name+dtvbName (DPlainTV n _) = n+dtvbName (DKindedTV n _ _) = n++dtvbFlag :: DTyVarBndr flag -> flag+dtvbFlag (DPlainTV _ flag) = flag+dtvbFlag (DKindedTV _ flag _) = flag++-- @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,18 +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 --- --- 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 () +-----------------------------------------------------------------------------+-- |+-- 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,427 @@-{- 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.List.NonEmpty as NE+import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.Set as S+import qualified Data.Map as Map+import Language.Haskell.TH.Instances ()+import Language.Haskell.TH.Syntax++import Language.Haskell.TH.Desugar.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 (DTypedBracketE exp) = DTypedBracketE <$> scExp exp+scExp (DTypedSpliceE exp) = DTypedSpliceE <$> scExp exp+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 (to_ne_pats pats) (\_ -> rhs) |+ DClause pats rhs <- clauses ]+ matchResultToDExp `liftM` simplCase vars eis+ where+ to_ne_pats :: [DPat] -> NonEmpty DPat+ to_ne_pats pats =+ case pats of+ p:ps -> p:|ps+ [] -> error "Clause encountered with no patterns -- should never happen"++data EquationInfo = EquationInfo (NonEmpty 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 (v:vs) clauses = do+ (aux_binds, tidy_clauses) <- mapAndUnzipM (tidyClause v) clauses+ let grouped = groupClauses tidy_clauses+ match_results <- match_groups grouped+ return (adjustMatchResult (foldr (.) id aux_binds) $+ foldr1 (.) match_results)+ where+ match_groups :: DsMonad q => [NonEmpty (PatGroup, EquationInfo)] -> q [MatchResult]+ match_groups [] = matchEmpty v+ match_groups gs = mapM match_group gs++ match_group :: DsMonad q => NonEmpty (PatGroup, EquationInfo) -> q MatchResult+ match_group eqns@((group,_) :| _) =+ case group of+ PgCon _ -> matchConFamily vars $ subGroup [(c,e) | (PgCon c, e) <- NE.toList eqns]+ PgLit _ -> matchLiterals vars $ subGroup [(l,e) | (PgLit l, e) <- NE.toList eqns]+ PgBang -> matchBangs vars $ drop_group eqns+ PgAny -> matchVariables vars $ drop_group eqns++ drop_group :: NonEmpty (PatGroup, EquationInfo) -> NonEmpty EquationInfo+ drop_group = fmap snd++ vars = v:|vs++-- analogous to GHC's tidyEqnInfo+tidyClause :: DsMonad q => Name -> EquationInfo -> q (DExp -> DExp, EquationInfo)+tidyClause 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 []++ | [binder] <- F.toList binders+ = do val_var <- newUniqueName "var"+ err_var <- newUniqueName "err"+ bind <- mk_bind val_var err_var binder+ return [DValD (DVarP val_var) (DVarE name),+ DValD (DVarP err_var) (DVarE 'error `DAppE`+ (DLitE $ StringL "Irrefutable match failed")),+ bind]++ | 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] -> [NonEmpty (PatGroup, EquationInfo)]+groupClauses clauses+ = NE.groupBy same_gp [(patGroup (firstPat clause), clause) | clause <- clauses]+ where+ same_gp :: (PatGroup, EquationInfo) -> (PatGroup, EquationInfo) -> Bool+ (pg1,_) `same_gp` (pg2,_) = pg1 `sameGroup` pg2++patGroup :: DPat -> PatGroup+patGroup (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++-- Precondition: the input list contains at least one element.+subGroup :: Ord a => [(a, EquationInfo)] -> NonEmpty (NonEmpty EquationInfo)+subGroup group+ = case map NE.reverse $ Map.elems $ foldl accumulate Map.empty group of+ e:es -> e:|es+ [] -> error "Internal error in th-desugar (subGroup)"+ where+ accumulate pg_map (pg, eqn)+ = case Map.lookup pg pg_map of+ Just eqns -> Map.insert pg (NE.cons eqn eqns) pg_map+ Nothing -> Map.insert pg (eqn :| []) pg_map++firstPat :: EquationInfo -> DPat+firstPat (EquationInfo (pat :| _) _) = pat++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 => NonEmpty Name -> NonEmpty (NonEmpty EquationInfo) -> q MatchResult+matchConFamily (var:|vars) groups+ = do alts <- mapM (matchOneCon vars) groups+ mkDataConCase var alts++-- like matchOneConLike from MatchCon+matchOneCon :: DsMonad q => [Name] -> NonEmpty EquationInfo -> q CaseAlt+matchOneCon vars eqns@(eqn1 :| _)+ = do arg_vars <- selectMatchVars (pat_args pat1)+ match_result <- match_group arg_vars++ 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) $ NE.toList $ fmap shift eqns++ shift (EquationInfo (DConP _ _ args :| pats) exp)+ = EquationInfo (to_ne_pats (args ++ pats)) exp+ shift _ = error "Internal error in th-desugar (shift)"++ to_ne_pats :: [DPat] -> NonEmpty DPat+ to_ne_pats pats =+ case pats of+ p:ps -> p:|ps+ [] -> error "Internal error in th-desugar (matchOneCon.to_ne_pats)"++mkDataConCase :: DsMonad q => Name -> NonEmpty CaseAlt -> q MatchResult+mkDataConCase var case_alts = do+ all_ctors <- get_all_ctors (alt_con $ NE.head case_alts)+ return $ \fail ->+ let matches = fmap (mk_alt fail) case_alt_list in+ DCaseE (DVarE var) (matches ++ mk_default all_ctors fail)+ where+ case_alt_list = NE.toList case_alts++ mk_alt fail (CaseAlt con args body_fn)+ = let body = body_fn fail in+ DMatch (DConP con [] (map DVarP args)) body++ mk_default all_ctors fail | exhaustive_case all_ctors = []+ | otherwise = [DMatch DWildP fail]++ mentioned_ctors = S.fromList $ map alt_con case_alt_list+ exhaustive_case all_ctors = all_ctors `S.isSubsetOf` mentioned_ctors++ get_all_ctors :: DsMonad q => Name -> q (S.Set Name)+ 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 => NonEmpty Name -> NonEmpty (NonEmpty EquationInfo) -> q MatchResult+matchLiterals (var:|vars) sub_groups+ = do alts <- mapM match_group sub_groups+ return (mkCoPrimCaseMatchResult var alts)+ where+ match_group :: DsMonad q => NonEmpty EquationInfo -> q (Lit, MatchResult)+ match_group eqns+ = do let lit = case firstPat (NE.head eqns) of+ DLitP lit' -> lit'+ _ -> error $ "Internal error in th-desugar "+ ++ "(matchLiterals.match_group)"+ match_result <- simplCase vars $ NE.toList $ shiftEqns eqns+ return (lit, match_result)++mkCoPrimCaseMatchResult :: Name -- Scrutinee+ -> NonEmpty (Lit, MatchResult)+ -> MatchResult+mkCoPrimCaseMatchResult var match_alts = mk_case+ where+ mk_case fail = let alts = NE.toList $ fmap (mk_alt fail) match_alts in+ DCaseE (DVarE var) (alts ++ [DMatch DWildP fail])+ mk_alt fail (lit, body_fn)+ = DMatch (DLitP lit) (body_fn fail)++matchBangs :: DsMonad q => NonEmpty Name -> NonEmpty EquationInfo -> q MatchResult+matchBangs (var:|vars) eqns+ = do match_result <- simplCase (var:vars) $ NE.toList $+ fmap (decomposeFirstPat getBangPat) eqns+ return (mkEvalMatchResult var match_result)++decomposeFirstPat :: (DPat -> DPat) -> EquationInfo -> EquationInfo+decomposeFirstPat extractpat (EquationInfo (pat:|pats) body)+ = EquationInfo (extractpat pat :| pats) body++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 => NonEmpty Name -> NonEmpty EquationInfo -> q MatchResult+matchVariables (_:|vars) eqns = simplCase vars $ NE.toList $ shiftEqns eqns++shiftEqns :: NonEmpty EquationInfo -> NonEmpty EquationInfo+shiftEqns = fmap shift+ where+ shift (EquationInfo pats rhs) = EquationInfo (to_ne_pats (NE.tail pats)) rhs++ to_ne_pats :: [DPat] -> NonEmpty DPat+ to_ne_pats pats =+ case pats of+ p:ps -> p:|ps+ [] -> error "Internal error in th-desugar (shiftEqns.to_ne_pats)"++adjustMatchResult :: (DExp -> DExp) -> MatchResult -> MatchResult+adjustMatchResult wrap mr fail = wrap $ mr fail++-- 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"
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,1317 +1,1368 @@-{- 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/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++#if __GLASGOW_HASKELL__ >= 907+import qualified Language.Haskell.TH as LangExt (Extension(..))+#endif++-- | Like @reify@ from Template Haskell, but looks also in any not-yet-typechecked+-- declarations. To establish this list of not-yet-typechecked declarations,+-- use 'withLocalDeclarations'. Returns 'Nothing' if reification fails.+-- Note that no inferred type information is available from local declarations;+-- bottoms may be used if necessary.+reifyWithLocals_maybe :: DsMonad q => Name -> q (Maybe Info)+reifyWithLocals_maybe name = qRecover+ (return . reifyInDecs name =<< localDeclarations)+ (Just `fmap` qReify name)++-- | Like 'reifyWithLocals_maybe', but throws an exception upon failure,+-- warning the user about separating splices.+reifyWithLocals :: DsMonad q => Name -> q Info+reifyWithLocals name = do+ m_info <- reifyWithLocals_maybe name+ case m_info of+ Nothing -> reifyFail name+ Just i -> return i++-- | Reify a declaration, warning the user about splices if the reify fails.+-- The warning says that reification can fail if you try to reify a type in+-- the same splice as it is declared.+reifyWithWarning :: (Quasi q, Fail.MonadFail q) => Name -> q Info+reifyWithWarning name = qRecover (reifyFail name) (qReify name)++-- | Print out a warning about separating splices and fail.+reifyFail :: Fail.MonadFail m => Name -> m a+reifyFail name =+ Fail.fail $ "Looking up " ++ (show name) ++ " in the list of available " +++ "declarations failed.\nThis lookup fails if the declaration " +++ "referenced was made in the same Template\nHaskell splice as the use " +++ "of the declaration. If this is the case, put\nthe reference to " +++ "the declaration in a new splice."++---------------------------------+-- Utilities+---------------------------------++-- | Extract the 'DataFlavor', 'TyVarBndr's and constructors given the 'Name'+-- of a type.+getDataD :: DsMonad q+ => String -- ^ Print this out on failure+ -> Name -- ^ Name of the datatype (@data@ or @newtype@) of interest+ -> q (DataFlavor, [TyVarBndrVis], [Con])+getDataD err name = do+ info <- reifyWithLocals name+ dec <- case info of+ TyConI dec -> return dec+ _ -> badDeclaration+ case dec of+ DataD _cxt _name tvbs mk cons _derivings -> go Data tvbs mk cons+ NewtypeD _cxt _name tvbs mk con _derivings -> go Newtype tvbs mk [con]+#if __GLASGOW_HASKELL__ >= 906+ TypeDataD _name tvbs mk cons -> go Util.TypeData tvbs mk cons+#endif+ _ -> badDeclaration+ where+ go df tvbs mk cons = do+ let k = fromMaybe (ConT typeKindName) mk+ extra_tvbs <- mkExtraKindBinders k+ let all_tvbs = tvbs ++ extra_tvbs+ return (df, all_tvbs, cons)++ badDeclaration =+ fail $ "The name (" ++ (show name) ++ ") refers to something " +++ "other than a datatype. " ++ err++-- | Create new kind variable binder names corresponding to the return kind of+-- a data type. This is useful when you have a data type like:+--+-- @+-- data Foo :: forall k. k -> Type -> Type where ...+-- @+--+-- But you want to be able to refer to the type @Foo a b@.+-- 'mkExtraKindBinders' will take the kind @forall k. k -> Type -> Type@,+-- discover that is has two visible argument kinds, and return as a result+-- two new kind variable binders @[a :: k, b :: Type]@, where @a@ and @b@+-- are fresh type variable names.+--+-- This expands kind synonyms if necessary.+mkExtraKindBinders :: forall q. Quasi q => Kind -> q [TyVarBndrVis]+mkExtraKindBinders k = do+ k' <- runQ $ resolveTypeSynonyms k+ let (fun_args, _) = unravelType k'+ vis_fun_args = filterVisFunArgs fun_args+ mapM mk_tvb vis_fun_args+ where+ mk_tvb :: VisFunArg -> q TyVarBndrVis+ mk_tvb (VisFADep tvb) = return $ mapTVFlag (const BndrReq) tvb+ mk_tvb (VisFAAnon ki) = do+ name <- qNewName "a"+ pure $ kindedTVFlag name BndrReq ki++-- | From the name of a data constructor, retrive the datatype definition it+-- is a part of.+dataConNameToDataName :: DsMonad q => Name -> q Name+dataConNameToDataName con_name = do+ info <- reifyWithLocals con_name+ case info of+ DataConI _name _type parent_name -> return parent_name+ _ -> fail $ "The name " ++ show con_name ++ " does not appear to be " +++ "a data constructor."++-- | From the name of a data constructor, retrieve its definition as a @Con@+dataConNameToCon :: DsMonad q => Name -> q Con+dataConNameToCon con_name = do+ -- we need to get the field ordering from the constructor. We must reify+ -- the constructor to get the tycon, and then reify the tycon to get the `Con`s+ type_name <- dataConNameToDataName con_name+ (_, _, cons) <- getDataD "This seems to be an error in GHC." type_name+ let m_con = List.find (any (con_name ==) . get_con_name) cons+ case m_con of+ Just con -> return con+ Nothing -> impossible "Datatype does not contain one of its own constructors."++ where+ get_con_name (NormalC name _) = [name]+ get_con_name (RecC name _) = [name]+ get_con_name (InfixC _ name _) = [name]+ get_con_name (ForallC _ _ con) = get_con_name con+ get_con_name (GadtC names _ _) = names+ get_con_name (RecGadtC names _ _) = names++--------------------------------------------------+-- DsMonad+--------------------------------------------------++-- | A 'DsMonad' stores some list of declarations that should be considered+-- in scope. 'DsM' is the prototypical inhabitant of 'DsMonad'.+class (Quasi m, Fail.MonadFail m) => DsMonad m where+ -- | Produce a list of local declarations.+ localDeclarations :: m [Dec]++instance DsMonad Q where+ localDeclarations = return []+instance DsMonad IO where+ localDeclarations = return []++-- | A convenient implementation of the 'DsMonad' class. Use by calling+-- 'withLocalDeclarations'.+newtype DsM q a = DsM (ReaderT [Dec] q a)+ deriving ( Functor, Applicative, Monad, MonadTrans, 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 tyVarBndrVisToTypeArgWithSig tvbs) cons+ = Just info+reifyInDec n decs (NewtypeD _ ty_name tvbs _mk con _)+ | Just info <- maybeReifyCon n decs ty_name (map tyVarBndrVisToTypeArgWithSig 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 tyVarBndrVisToTypeArgWithSig 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.+ -> [TyVarBndrVis] -- ^ 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 = [applyType (ConT cls_name) (map tyVarBndrVisToTypeArg 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 :: TyVarBndrVis -> TyVarBndrVis+ ascribe_tf_tvb_kind tvb =+ elimTVFlag+ (\tvn flag -> kindedTVFlag tvn flag $ fromMaybe StarT $ Map.lookup tvn cls_tvb_kind_map)+ (\_ _ _ -> tvb)+ tvb++-- Data types have CUSKs when:+--+-- 1. All of their type variables have explicit kinds.+-- 2. All kind variables in the result kind are explicitly quantified.+datatype_kind :: [TyVarBndrVis] -> Maybe Kind -> Maybe Kind+datatype_kind tvbs m_ki =+ whenAlt (all tvb_is_kinded tvbs && ki_fvs_are_bound) $+ build_kind tvbs (default_res_ki m_ki)+ where+ ki_fvs_are_bound :: Bool+ ki_fvs_are_bound =+ let ki_fvs = Set.fromList $ foldMap freeVariables m_ki+ tvb_vars = Set.fromList $ freeVariables $ map tvbToTypeWithSig tvbs+ in ki_fvs `Set.isSubsetOf` tvb_vars++-- Classes have CUSKs when all of their type variables have explicit kinds.+class_kind :: [TyVarBndrVis] -> Maybe Kind+class_kind tvbs = whenAlt (all tvb_is_kinded tvbs) $+ build_kind tvbs ConstraintT++-- Open type families and data families always have CUSKs. Type variables+-- without explicit kinds default to Type, as does the return kind if it+-- is not specified.+open_ty_fam_kind :: [TyVarBndrVis] -> Maybe Kind -> Maybe Kind+open_ty_fam_kind tvbs m_ki =+ build_kind (map default_tvb tvbs) (default_res_ki m_ki)++-- Closed type families have CUSKs when:+--+-- 1. All of their type variables have explicit kinds.+-- 2. An explicit return kind is supplied.+closed_ty_fam_kind :: [TyVarBndrVis] -> Maybe Kind -> Maybe Kind+closed_ty_fam_kind tvbs m_ki =+ case m_ki of+ Just ki -> whenAlt (all tvb_is_kinded tvbs) $+ build_kind tvbs ki+ Nothing -> Nothing++-- Type synonyms have CUSKs when:+--+-- 1. All of their type variables have explicit kinds.+-- 2. The right-hand-side type is annotated with an explicit kind.+ty_syn_kind :: [TyVarBndrVis] -> Type -> Maybe Kind+ty_syn_kind tvbs rhs =+ case rhs of+ SigT _ ki -> whenAlt (all tvb_is_kinded tvbs) $+ build_kind tvbs ki+ _ -> Nothing++-- Attempt to construct the full kind of a type-level declaration from its+-- type variable binders and return kind. Do note that the result type of+-- this function is `Maybe Kind` because there are situations where even+-- this amount of information is not sufficient to determine the full kind.+-- See Note [The limitations of standalone kind signatures].+build_kind :: [TyVarBndrVis] -> Kind -> Maybe Kind+build_kind arg_kinds res_kind =+ fmap quantifyType $ fst $+ foldr go (Just res_kind, Set.fromList (freeVariables res_kind)) arg_kinds+ where+ go :: TyVarBndrVis -> (Maybe Kind, Set Name) -> (Maybe Kind, Set Name)+ go tvb (res, res_fvs) =+ elimTV (\n ->+ ( if n `Set.member` res_fvs+ then forall_ tvb res+ else Nothing -- We have a type variable binder without an+ -- explicit kind that is not used dependently, so+ -- we cannot build a kind from it. This is the+ -- only case where we return Nothing.+ , res_fvs+ ))+ (\n k ->+ ( if n `Set.member` res_fvs+ then forall_ tvb res+ else fmap (ArrowT `AppT` k `AppT`) res+ , Set.fromList (freeVariables k) `Set.union` res_fvs+ ))+ tvb++ forall_ :: TyVarBndrVis -> Maybe Kind -> Maybe Kind+#if __GLASGOW_HASKELL__ >= 809+ forall_ tvb m_ki = fmap forallT m_ki+ where+ bndrVis :: BndrVis+ bndrVis = elimTVFlag (\_ flag -> flag) (\_ flag _ -> flag) tvb+ forallT :: Kind -> Kind+ forallT = case bndrVis of+ BndrReq -> ForallVisT (changeTVFlags () [tvb])+ BndrInvis -> ForallT (changeTVFlags SpecifiedSpec [tvb]) []+ -- One downside of this approach is that we generate kinds like this:+ --+ -- forall a -> forall b -> forall c -> (a, b, c)+ --+ -- Instead of this more compact kind:+ --+ -- forall a b c -> (a, b, c)+ --+ -- Thankfully, the difference is only cosmetic.+#else+ forall_ _ _ = Nothing+#endif++tvb_is_kinded :: TyVarBndr_ flag -> Bool+tvb_is_kinded = isJust . 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 :: TyVarBndr_ flag -> TyVarBndr_ flag+default_tvb tvb = elimTVFlag (\n flag -> kindedTVFlag n flag StarT) (\_ _ _ -> tvb) tvb++default_res_ki :: Maybe Kind -> Kind+default_res_ki = fromMaybe StarT++res_sig_to_kind :: FamilyResultSig -> Maybe Kind+res_sig_to_kind NoSig = Nothing+res_sig_to_kind (KindSig k) = Just k+res_sig_to_kind (TyVarSig tvb) = 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+#if __GLASGOW_HASKELL__ >= 907+ FldName{} -> Nothing+#endif++ find_value_name (n, info) = do+ name_space <- lookupInfoNameSpace info+ case name_space of+ VarName -> pure $ Just n+ DataName -> pure $ Just n+ TcClsName -> pure Nothing+#if __GLASGOW_HASKELL__ >= 907+ FldName{} -> do+ fieldSels <- qIsExtEnabled LangExt.FieldSelectors+ pure $ if fieldSels then Just n else Nothing+#endif++-- | Like TH's @lookupValueName@, but if this name is not bound, then we assume+-- it is declared in the current module.+--+-- Unlike 'mkDataName', this also consults the local declarations in scope when+-- determining if the name is currently bound.+mkDataNameWithLocals :: DsMonad q => String -> q Name+mkDataNameWithLocals = mkNameWith lookupValueNameWithLocals mkNameG_d++-- | Like TH's @lookupTypeName@, but if this name is not bound, then we assume+-- it is declared in the current module.+--+-- Unlike 'mkTypeName', this also consults the local declarations in scope when+-- determining if the name is currently bound.+mkTypeNameWithLocals :: DsMonad q => String -> q Name+mkTypeNameWithLocals = mkNameWith lookupTypeNameWithLocals mkNameG_tc++-- | Determines a `Name`'s 'NameSpace'. If the 'NameSpace' is attached to+-- the 'Name' itself (i.e., it is unambiguous), then that 'NameSpace' is+-- immediately returned. Otherwise, reification is used to lookup up the+-- 'NameSpace' (consulting local declarations if necessary).+--+-- Note that if a 'Name' lives in two different 'NameSpaces' (which can+-- genuinely happen--for instance, @'mkName' \"==\"@, where @==@ is both+-- a function and a type family), then this function will simply return+-- whichever 'NameSpace' is discovered first via reification. If you wish+-- to find a 'Name' in a particular 'NameSpace', use the+-- 'lookupValueNameWithLocals' or 'lookupTypeNameWithLocals' functions.+reifyNameSpace :: DsMonad q => Name -> q (Maybe NameSpace)+reifyNameSpace n@(Name _ nf) =+ case nf of+ -- NameGs are simple, as they have a NameSpace attached.+ NameG ns _ _ -> pure $ Just ns++ -- For other names, we must use reification to determine what NameSpace+ -- it lives in (if any).+ _ -> do mb_info <- reifyWithLocals_maybe n+ traverse lookupInfoNameSpace mb_info++-- | Look up a name's 'NameSpace' from its 'Info'.+lookupInfoNameSpace :: DsMonad q => Info -> q NameSpace+lookupInfoNameSpace info =+ case info of+ ClassI{} -> pure TcClsName+ TyConI{} -> pure TcClsName+ FamilyI{} -> pure TcClsName+ PrimTyConI{} -> pure TcClsName+ TyVarI{} -> pure TcClsName++ ClassOpI{} -> pure VarName+#if __GLASGOW_HASKELL__ >= 907+ -- A VarI might correspond to a top-level value (i.e., a VarName) or a+ -- record field (i.e., a FldName). The only way to distinguish them is to+ -- check if the VarI's Name and Type correspond to a data type with a+ -- corresponding record field Name.+ VarI n ty _ -> do+ -- First, check to see if `ty` is of the form `D -> T`, where `D` is+ -- headed by a data type. We can safely ignore `forall`s here by using+ -- `filterVisFunArgs`, as we only care about the first visible argument.+ let (ty_args, _ty_res) = unravelType ty+ ty_vis_args = filterVisFunArgs ty_args+ case ty_vis_args of+ [VisFAAnon ty_anon_arg]+ | (ConT parent_name, _) <- unfoldType ty_anon_arg+ -> -- If we find the data type constructor `parent_name`, then check+ -- if one of the data constructors for `parent_name` contains a+ -- record field named `n`.+ do mb_parent_info <- reifyWithLocals_maybe parent_name+ pure $ case mb_parent_info of+ Just (TyConI (DataD _cxt _name _tvbs _mk cons _derivings))+ | isJust $ findRecSelector n cons+ -> FldName $ nameBase parent_name+ Just (TyConI (NewtypeD _cxt _name _tvbs _mk con _derivings))+ | isJust $ findRecSelector n [con]+ -> FldName $ nameBase parent_name+ _ -> VarName+ _ -> pure VarName+#else+ VarI{} -> pure VarName+#endif++ DataConI _dc_name _dc_ty parent_name -> do+ -- DataConI usually refers to a value-level Name, but it could also refer+ -- to a type-level 'Name' if the data constructor corresponds to a+ -- @type data@ declaration. In order to know for sure, we must perform+ -- some additional reification.+ mb_parent_info <- reifyWithLocals_maybe parent_name+ pure $ case mb_parent_info of+#if __GLASGOW_HASKELL__ >= 906+ Just (TyConI (TypeDataD {}))+ -> TcClsName+#endif+ _ -> DataName+#if __GLASGOW_HASKELL__ >= 801+ PatSynI{} -> pure DataName+#endif
Language/Haskell/TH/Desugar/Subst.hs view
@@ -1,145 +1,150 @@-{-# 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+ -- the following two cases wrong.+matchTy ign (DSigT ty _ki) arg = case ign of+ YesIgnore -> matchTy ign ty arg+ NoIgnore -> Nothing+matchTy ign (DAppKindT ty _ki) arg = case ign of+ YesIgnore -> matchTy ign ty arg+ NoIgnore -> Nothing+ -- but we can safely ignore kind signatures on the target,+ -- as in the following two cases.+matchTy ign pat (DSigT ty _ki) = matchTy ign pat ty+matchTy ign pat (DAppKindT ty _ki) = matchTy ign pat ty+matchTy _ (DForallT {}) _ =+ error "Cannot match a forall in a pattern"+matchTy _ _ (DForallT {}) =+ error "Cannot match a forall in a target"+matchTy ign (DAppT pat1 pat2) (DAppT arg1 arg2) =+ unionMaybeSubsts [matchTy ign pat1 arg1, matchTy ign pat2 arg2]+matchTy _ (DConT pat_con) (DConT arg_con)+ | pat_con == arg_con = Just M.empty+matchTy _ DArrowT DArrowT = Just M.empty+matchTy _ (DLitT pat_lit) (DLitT arg_lit)+ | pat_lit == arg_lit = Just M.empty+matchTy _ _ _ = Nothing++unionMaybeSubsts :: [Maybe DSubst] -> Maybe DSubst+unionMaybeSubsts = L.foldl' union_subst1 (Just M.empty)+ where+ union_subst1 :: Maybe DSubst -> Maybe DSubst -> Maybe DSubst+ union_subst1 ma mb = do+ a <- ma+ b <- mb+ unionSubsts a b
Language/Haskell/TH/Desugar/Sweeten.hs view
@@ -1,416 +1,425 @@-{- 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/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+#if __GLASGOW_HASKELL__ >= 907+expToTH (DTypedBracketE exp) = TypedBracketE (expToTH exp)+expToTH (DTypedSpliceE exp) = TypedSpliceE (expToTH exp)+#else+expToTH (DTypedBracketE {}) =+ error "Typed Template Haskell brackets supported only in GHC 9.8+"+expToTH (DTypedSpliceE {}) =+ error "Typed Template Haskell splices supported only in GHC 9.8+"+#endif++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,547 +1,653 @@-{- 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) +{- 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,+ nameMatches, thdOf3, liftFst, liftSnd, firstMatch, firstMatchM,+ tupleNameDegree_maybe,+ unboxedSumNameDegree_maybe, unboxedTupleNameDegree_maybe, splitTuple_maybe,+ topEverywhereM, isInfixDataCon,+ isTypeKindName, typeKindName,+ unSigType, unfoldType, ForallTelescope(..), FunArgs(..), VisFunArg(..),+ filterVisFunArgs, ravelType, unravelType,+ TypeArg(..), applyType, filterTANormals, probablyWrongUnTypeArg,+ tyVarBndrVisToTypeArg, tyVarBndrVisToTypeArgWithSig,+ bindIP,+ DataFlavor(..)+ ) 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 )++#if __GLASGOW_HASKELL__ >= 906+import GHC.Tuple ( Solo(MkSolo) )+#elif __GLASGOW_HASKELL__ >= 900+import GHC.Tuple ( Solo(Solo) )+#endif++#if __GLASGOW_HASKELL__ >= 908+import GHC.Tuple ( Tuple0, Unit )+import Text.Read ( readMaybe )+#endif++----------------------------------------+-- 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)++-- | Do two names name the same thing?+nameMatches :: Name -> Name -> Bool+nameMatches n1@(Name occ1 flav1) n2@(Name occ2 flav2)+ | NameS <- flav1 = occ1 == occ2+ | NameS <- flav2 = occ1 == occ2+ | NameQ mod1 <- flav1+ , NameQ mod2 <- flav2+ = mod1 == mod2 && occ1 == occ2+ | NameQ mod1 <- flav1+ , NameG _ _ mod2 <- flav2+ = mod1 == mod2 && occ1 == occ2+ | NameG _ _ mod1 <- flav1+ , NameQ mod2 <- flav2+ = mod1 == mod2 && occ1 == occ2+ | otherwise+ = n1 == n2++-- | Extract the degree of a tuple 'Name'.+--+-- In addition to recognizing tuple syntax (e.g., @''(,,)@), this also+-- recognizes the following:+--+-- * @''Unit@ (for 0-tuples)+--+-- * @''Solo@/@'MkSolo@ (for 1-tuples)+--+-- * @''Tuple<N>@ (for <N>-tuples)+--+-- In recent versions of GHC, @''()@ is a synonym for @''Unit@, @''(,)@ is a+-- synonym for @''Tuple2@, and so on. As a result, we must check for @''Unit@+-- and @''Tuple<N>@ in 'tupleDegree_maybe' to be thorough. (There is no special+-- tuple syntax for @''Solo@/@'MkSolo@, but we check them here as well for the+-- sake of completeness.)+tupleNameDegree_maybe :: Name -> Maybe Int+tupleNameDegree_maybe name+ -- First, check for Solo/MkSolo...+#if __GLASGOW_HASKELL__ >= 900+ | name == ''Solo = Just 1+#if __GLASGOW_HASKELL__ >= 906+ | name == 'MkSolo = Just 1+#else+ | name == 'Solo = Just 1+#endif+#endif+#if __GLASGOW_HASKELL__ >= 908+ -- ...then, check for Unit...+ | name == ''Unit = Just 0+ -- ...then, check for Tuple<N>. It is theoretically possible for the supplied+ -- Name to be a user-defined data type named Tuple<N>, rather than the actual+ -- tuple types defined in GHC.Tuple. As such, we check that the package and+ -- module for the supplied Name does in fact come from ghc-prim:GHC.Tuple as+ -- a sanity check.+ | -- We use Tuple0 here simply because it is a convenient identifier from+ -- GHC.Tuple. We could just as well use any other identifier from GHC.Tuple,+ -- however.+ namePackage name == namePackage ''Tuple0+ , nameModule name == nameModule ''Tuple0+ , 'T':'u':'p':'l':'e':n <- nameBase (name)+ -- This relies on the Read Int instance. This is more permissive than what+ -- we need, since there are valid Int strings (e.g., "-1") that do not have+ -- corresponding Tuple<N> names (e.g., "Tuple-1" is not a data type in+ -- GHC.Tuple). As such, we depend on the assumption that the input string+ -- does in fact come from GHC.Tuple, which we check above.+ = readMaybe n+#endif+ -- ...otherwise, fall back on tuple syntax.+ | otherwise+ = tuple_syntax_degree_maybe (nameBase name)+ where+ -- Extract the degree of a string using tuple syntax (e.g., @''(,,)@).+ tuple_syntax_degree_maybe :: String -> Maybe Int+ tuple_syntax_degree_maybe s = do+ '(' : s1 <- return s+ (commas, ")") <- return $ span (== ',') s1+ let degree+ | "" <- commas = 0+ | otherwise = length commas + 1+ return degree++-- | Extract the degree of an unboxed sum+unboxedSumDegree_maybe :: String -> Maybe Int+unboxedSumDegree_maybe = unboxedSumTupleDegree_maybe '|'++-- | Extract the degree of an unboxed sum 'Name'.+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)])+-- @+--+-- This process forgets about infix application, so both of these types:+--+-- @+-- Int :++: Int+-- (:++:) Int Int+-- @+--+-- will be unfolded to this:+--+-- @+-- ('ConT' ''(:+:), ['TANormal' ('ConT' ''Int), 'TANormal' ('ConT' ''Int)])+-- @+--+-- This function should only be used after all 'UInfixT' and 'PromotedUInfixT'+-- types have been resolved (e.g., via @th-abstraction@'s+-- @<https://hackage.haskell.org/package/th-abstraction-0.5.0.0/docs/Language-Haskell-TH-Datatype.html#v:resolveInfixT resolveInfixT>@+-- function).+unfoldType :: Type -> (Type, [TypeArg])+unfoldType = go []+ where+ go :: [TypeArg] -> Type -> (Type, [TypeArg])+ go acc (ForallT _ _ ty) = go acc ty+ go acc (AppT ty1 ty2) = go (TANormal ty2:acc) ty1+ go acc (SigT ty _) = go acc ty+ go acc (ParensT ty) = go acc ty+ go acc (InfixT ty1 n ty2) = go (TANormal ty1:TANormal ty2:acc) (ConT n)+#if __GLASGOW_HASKELL__ >= 807+ go acc (AppKindT ty ki) = go (TyArg ki:acc) ty+#endif+#if __GLASGOW_HASKELL__ >= 904+ go acc (PromotedInfixT ty1 n ty2) = go (TANormal ty1:TANormal ty2:acc) (PromotedT n)+#endif+ go acc ty = (ty, acc)++-- | An argument to a type, either a normal type ('TANormal') or a visible+-- kind application ('TyArg').+--+-- 'TypeArg' is useful when decomposing an application of a 'Type' to its+-- arguments (e.g., in 'unfoldType').+data TypeArg+ = TANormal Type+ | TyArg Kind+ deriving (Eq, Show, Data)++-- | Apply one 'Type' to a list of arguments.+applyType :: Type -> [TypeArg] -> Type+applyType = foldl apply+ where+ apply :: Type -> TypeArg -> Type+ apply f (TANormal x) = f `AppT` x+ apply f (TyArg _x) =+#if __GLASGOW_HASKELL__ >= 807+ f `AppKindT` _x+#else+ -- VKA isn't supported, so+ -- conservatively drop the argument+ f+#endif++-- | Filter the normal type arguments from a list of 'TypeArg's.+filterTANormals :: [TypeArg] -> [Type]+filterTANormals = mapMaybe getTANormal+ where+ getTANormal :: TypeArg -> Maybe Type+ getTANormal (TANormal t) = Just t+ getTANormal (TyArg {}) = Nothing++-- | Convert a 'TyVarBndrVis' to a 'TypeArg'. That is, convert a binder with a+-- 'BndrReq' visibility to a 'TANormal' and a binder with 'BndrInvis'+-- visibility to a 'TyArg'.+--+-- If given a 'KindedTV', the resulting 'TypeArg' will omit the kind signature.+-- Use 'tyVarBndrVisToTypeArgWithSig' if you want to preserve the kind+-- signature.+tyVarBndrVisToTypeArg :: TyVarBndrVis -> TypeArg+tyVarBndrVisToTypeArg bndr =+ case tvFlag bndr of+ BndrReq -> TANormal bndr_ty+ BndrInvis -> TyArg bndr_ty+ where+ bndr_ty = tvbToType bndr++-- | Convert a 'TyVarBndrVis' to a 'TypeArg'. That is, convert a binder with a+-- 'BndrReq' visibility to a 'TANormal' and a binder with 'BndrInvis'+-- visibility to a 'TyArg'.+--+-- If given a 'KindedTV', the resulting 'TypeArg' will preserve the kind+-- signature. Use 'tyVarBndrVisToTypeArg' if you want to omit the kind+-- signature.+tyVarBndrVisToTypeArgWithSig :: TyVarBndrVis -> TypeArg+tyVarBndrVisToTypeArgWithSig bndr =+ case tvFlag bndr of+ BndrReq -> TANormal bndr_ty+ BndrInvis -> TyArg bndr_ty+ where+ bndr_ty = tvbToTypeWithSig bndr++-- | Extract the underlying 'Type' or 'Kind' from a 'TypeArg'. This forgets+-- information about whether a type is a normal argument or not, so use with+-- caution.+probablyWrongUnTypeArg :: TypeArg -> Type+probablyWrongUnTypeArg (TANormal t) = t+probablyWrongUnTypeArg (TyArg k) = k++----------------------------------------+-- 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,146 @@-`th-desugar` Package -==================== - -[](http://hackage.haskell.org/package/th-desugar) -[](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+====================++[](http://hackage.haskell.org/package/th-desugar)+[](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+-----------------++## Desugaring depends on language extensions of use sites++Suppose you quote some Template Haskell declarations in module `A`:++```hs+{-# LANGUAGE ... #-}+module A where++decs :: Q [Dec]+decs = [d| ... |]+```++And later desugar the declarations with `th-desugar` in module `B`:++```hs+{-# LANGUAGE ... #-}+module B where++import A (decs)+import Language.Haskell.TH.Desugar (dsDecs)++$(do desugaredDecs <- dsDecs decs+ ...)+```++There are some situations where `th-desugar`'s desugaring depends on which+language extensions are enabled, such as:++* `MonadFailDesugaring` (for desugaring partial pattern matches in `do`+ notation)+* `NoFieldSelectors` (for determining if a record field can be reified as a+ field selector with `lookupValueNameWithLocals`)++Somewhat counterintuitively, `th-desugar` will consult the language extensions+in module `B` (the site where the `decs` are used) for this process, not module+`A` (where the `decs` were defined). This is really a Template Haskell+limitation, since Template Haskell does not offer any way to reify which+language extensions were enabled at the time the declarations were defined. As a+result, `th-desugar` can only check for language extensions at use sites.++## Limited support for kind inference++`th-desugar` sometimes has to construct types for certain Haskell entities.+For instance, `th-desugar` desugars all Haskell98-style constructors to use+GADT syntax, so the following:++```haskell+data T (a :: k) = MkT (Proxy a)+```++Will be desugared to something like this:++```haskell+data T (a :: k) where+ MkT :: forall k (a :: k). Proxy a -> T (a :: k)+```++Notice that `k` is explicitly quantified in the type of `MkT`. This is due to+an additional pass that `th-desugar` performs over the type variable binders+of `T` to extract all implicitly quantified variables and make them explicit.+This makes the desugared types forwards-compatible with a+[future version of GHC](https://github.com/goldfirere/ghc-proposals/blob/bbefbee6fc0cddb10bbacc85f79e66c2706ce13f/proposals/0000-no-kind-vars.rst)+that requires all kind variables in a top-level `forall` to be explicitly+quantified.++This process of extracting all implicitly quantified kind variables is not+perfect, however. There are some obscure programs that will cause `th-desugar`+to produce type variable binders that are ill scoped. Here is one example:++```haskell+data P k (a :: k)+data Foo (a :: Proxy j) (b :: k) c = MkFoo c (P k j)+```++If you squint hard at `MkFoo`, you'll notice that `j :: k`. However, this+relationship is not expressed _syntactically_, which means that `th-desugar`+will not be aware of it. Therefore, `th-desugar` will desugar `Foo` to:++```haskell+data Foo (a :: Proxy j) (b :: k) c where+ MkFoo :: forall j k (a :: Proxy j) (b :: k) c.+ c -> P k j -> Foo (a :: Proxy j) (b :: k) c+```++This is incorrect since `k` must come before `j` in order to be well scoped.+There is a workaround to this issue, however: add more explicit kind+information. If you had instead written this:++```haskell+data Foo (a :: Proxy (j :: k)) (b :: k) c = MkFoo c (P k j)+```++Then the fact that `j :: k` is expressed directly in the AST, so `th-desugar`+is able to pick up on it and pick `forall k j (a :: Proxy j) (b :: k) c. <...>`+as the telescope for the type of `MkFoo`.++The following constructs are known to be susceptible to this issue:++1. Desugared Haskell98-style constructors+2. Locally reified class methods+3. Locally reified record selectors+4. Locally reified data constructors+5. Locally reified type family instances (on GHC 8.8 and later, in which the+ Template Haskell AST supports explicit `foralls` in type family equations)++## Limited support for linear types++Currently, the `th-desugar` AST deliberately makes it impossible to represent+linear types, and desugaring a linear function arrow will simply turn into a+normal function arrow `(->)`. This choice is partly motivated by issues in the+way that linear types interact with Template Haskell, which sometimes make it+impossible to tell whether a reified function type is linear or not. See, for+instance, [GHC#18378](https://gitlab.haskell.org/ghc/ghc/-/issues/18378).
Setup.hs view
@@ -1,2 +1,2 @@-import Distribution.Simple -main = defaultMain +import Distribution.Simple+main = defaultMain
Test/Dec.hs view
@@ -1,54 +1,64 @@-{- 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 #-}+#if __GLASGOW_HASKELL__ >= 810+{-# LANGUAGE StandaloneKindSignatures #-}+#endif+#if __GLASGOW_HASKELL__ >= 907+{-# LANGUAGE TypeAbstractions #-}+#endif++{-# OPTIONS_GHC -Wno-orphans -Wno-name-shadowing+ -Wno-redundant-constraints #-}++module Dec where++import qualified Splices as S+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++#if __GLASGOW_HASKELL__ >= 907+$(S.dectest19)+#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,98 @@-{- 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,+ TypeApplications #-}+#if __GLASGOW_HASKELL__ >= 801+{-# LANGUAGE DerivingStrategies #-}+#endif+#if __GLASGOW_HASKELL__ >= 810+{-# LANGUAGE StandaloneKindSignatures #-}+#endif+#if __GLASGOW_HASKELL__ >= 907+{-# LANGUAGE TypeAbstractions #-}+#endif++{-# OPTIONS_GHC -Wno-orphans -Wno-incomplete-patterns+ -Wno-name-shadowing -Wno-redundant-constraints #-}++module DsDec where++import qualified Splices as S+import Splices ( dsDecSplice, unqualify )++import qualified Language.Haskell.TH.Datatype.TyVarBndr as THAbs+import Language.Haskell.TH.Desugar+import Language.Haskell.TH.Syntax ( qReport )++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++#if __GLASGOW_HASKELL__ >= 907+$(dsDecSplice S.dectest19)+#endif++$(do decs <- S.rec_sel_test+ withLocalDeclarations decs $ do+ [DDataD nd [] name [DPlainTV tvbName THAbs.BndrReq] k cons []] <- dsDecs decs+ recsels <- getRecordSelectors cons+ let num_sels = length recsels `div` 2 -- ignore type sigs+ when (num_sels /= S.rec_sel_test_num_sels) $+ qReport True $ "Wrong number of record selectors extracted.\n"+ ++ "Wanted " ++ show S.rec_sel_test_num_sels+ ++ ", Got " ++ show num_sels+ let unrecord c@(DCon _ _ _ (DNormalC {}) _) = c+ unrecord (DCon tvbs cxt con_name (DRecC fields) rty) =+ let (_names, stricts, types) = unzip3 fields+ fields' = zip stricts types+ in+ DCon tvbs cxt con_name (DNormalC False fields') rty+ plaindata = [DDataD nd [] name [DPlainTV tvbName THAbs.BndrReq] k (map unrecord cons) []]+ return (decsToTH plaindata ++ map letDecToTH recsels))
+ Test/FakeTuples.hs view
@@ -0,0 +1,13 @@+-- | Defines data types with names identical to those found in "GHC.Tuple".+-- This is used as part of a series of unit tests for the+-- @tupleNameDegree_maybe@ function, which should only return 'Just' when the+-- argument 'Name' is actually a tuple from "GHC.Tuple", not a user-defined+-- type.+module FakeTuples+ ( Tuple0, Tuple1, Tuple2, Tuple3+ ) where++data Tuple0+data Tuple1 a+data Tuple2 a b+data Tuple3 a b c
Test/ReifyTypeCUSKs.hs view
@@ -1,121 +1,121 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} -#if __GLASGOW_HASKELL__ < 806 -{-# LANGUAGE TypeInType #-} -#endif -#if __GLASGOW_HASKELL__ >= 809 -{-# LANGUAGE CUSKs #-} -#endif --- This is kept in a separate module from ReifyTypeSigs to isolate the use of --- the -XCUSKs language extension. -module ReifyTypeCUSKs where - -import Data.Kind (Type) -import GHC.Exts (Constraint) -import Language.Haskell.TH.Desugar -import Language.Haskell.TH.Syntax hiding (Type) -import Splices (eqTH) - -test_reify_type_cusks, test_reify_type_no_cusks :: [Bool] -(test_reify_type_cusks, test_reify_type_no_cusks) = - $(do cusk_decls <- - [d| data A1 (a :: Type) - type A2 (a :: Type) = (a :: Type) - type family A3 a - data family A4 a - type family A5 (a :: Type) :: Type where - A5 a = a - class A6 (a :: Type) where - type A7 a b - - data A8 (a :: k) :: k -> Type -#if __GLASGOW_HASKELL__ >= 804 - data A9 (a :: j) :: forall k. k -> Type -#endif -#if __GLASGOW_HASKELL__ >= 809 - data A10 (k :: Type) (a :: k) - data A11 :: forall k -> k -> Type -#endif - |] - - no_cusk_decls <- - [d| data B1 a - type B2 (a :: Type) = a - type B3 a = (a :: Type) - type family B4 (a :: Type) where - B4 a = a - type family B5 a :: Type where - B5 a = a - class B6 a where - type B7 (a :: Type) (b :: Type) :: Type - - data B8 :: k -> Type -#if __GLASGOW_HASKELL__ >= 804 - data B9 :: forall j. j -> k -> Type -#endif - |] - - let test_reify_kind :: DsMonad q - => String -> (Int, Maybe DKind) -> q Bool - test_reify_kind prefix (i, expected_kind) = do - actual_kind <- dsReifyType $ mkName $ prefix ++ show i - return $ expected_kind `eqTH` actual_kind - - typeKind :: DKind - typeKind = DConT typeKindName - - type_to_type :: DKind - type_to_type = DArrowT `DAppT` typeKind `DAppT` typeKind - - cusk_decl_bools <- - withLocalDeclarations cusk_decls $ - traverse (\(i, k) -> test_reify_kind "A" (i, Just k)) $ - [ (1, type_to_type) - , (2, type_to_type) - , (3, type_to_type) - , (4, type_to_type) - , (5, type_to_type) - , (6, DArrowT `DAppT` typeKind `DAppT` DConT ''Constraint) - , (7, DArrowT `DAppT` typeKind `DAppT` type_to_type) - ] - ++ - [ (8, let k = mkName "k" in - DForallT (DForallInvis [DPlainTV k SpecifiedSpec]) $ - DArrowT `DAppT` DVarT k `DAppT` - (DArrowT `DAppT` DVarT k `DAppT` typeKind)) - ] -#if __GLASGOW_HASKELL__ >= 804 - ++ - [ (9, let j = mkName "j" - k = mkName "k" in - DForallT (DForallInvis [DPlainTV j SpecifiedSpec]) $ - DArrowT `DAppT` DVarT j `DAppT` - (DForallT (DForallInvis [DPlainTV k SpecifiedSpec]) $ - DArrowT `DAppT` DVarT k `DAppT` typeKind)) - ] -#endif -#if __GLASGOW_HASKELL__ >= 809 - ++ - [ (10, let k = mkName "k" in - DForallT (DForallVis [DKindedTV k () typeKind]) $ - DArrowT `DAppT` DVarT k `DAppT` typeKind) - , (11, let k = mkName "k" in - DForallT (DForallVis [DPlainTV k ()]) $ - DArrowT `DAppT` DVarT k `DAppT` typeKind) - ] -#endif - - no_cusk_decl_bools <- - withLocalDeclarations no_cusk_decls $ - traverse (test_reify_kind "B") $ - map (, Nothing) $ - [1..7] - ++ [8] -#if __GLASGOW_HASKELL__ >= 804 - ++ [9] -#endif - lift (cusk_decl_bools, no_cusk_decl_bools)) +{-# 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,858 +1,945 @@-{- 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 +{- 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__ < 806+{-# LANGUAGE TypeInType #-}+#endif++#if __GLASGOW_HASKELL__ >= 809+{-# LANGUAGE StandaloneKindSignatures #-}+#endif++#if __GLASGOW_HASKELL__ >= 906+{-# LANGUAGE TypeData #-}+#endif++#if __GLASGOW_HASKELL__ >= 907+{-# LANGUAGE TypeAbstractions #-}+#endif++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 T183 ( t183 )+import qualified Language.Haskell.TH.Datatype.TyVarBndr as THAbs+import Language.Haskell.TH.Desugar+import qualified Language.Haskell.TH.Desugar.OSet as OS+import Language.Haskell.TH.Desugar.Expand ( expandUnsoundly )+import Language.Haskell.TH+import qualified Language.Haskell.TH.Syntax as Syn++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++#if __GLASGOW_HASKELL__ >= 906+import GHC.Tuple ( Solo(MkSolo) )+#elif __GLASGOW_HASKELL__ >= 900+import GHC.Tuple ( Solo(Solo) )+#endif++#if __GLASGOW_HASKELL__ >= 908+import qualified FakeTuples+import GHC.Tuple ( Tuple0, Tuple1, Tuple2, Tuple3, Unit )+#endif++-- |+-- 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+#if __GLASGOW_HASKELL__ >= 907+ , "typed_th_bracket" ~: $$($test57_typed_th_bracket) @=? $$($(dsSplice test57_typed_th_bracket))+ , "typed_th_splice" ~: $test58_typed_th_splice @=? $(dsSplice test58_typed_th_splice)+#endif+ ]++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 THAbs.BndrReq (DVarT k)]+ (DKindSig (DVarT k))+ Nothing)+ -- type instance F (x :: ()) = x+ , DTySynInstD+ (DTySynEqn Nothing+ (DConT fam_name `DAppT`+ DSigT (DVarT x) (DConT ''()))+ (DVarT x))+ ])+ (expandType orig_ty)+ orig_ty `eqTHSplice` exp_ty)++test_t85 :: Bool+test_t85 =+ $(do let orig_ty =+ (DConT ''Constant `DAppT` DConT ''Int `DAppT` DConT 'True)+ `DSigT` (DConT ''Constant `DAppT` DConT ''Char `DAppT` DConT ''Bool)+ expected_ty = DConT 'True `DSigT` DConT ''Bool+ expanded_ty <- expandType orig_ty+ expected_ty `eqTHSplice` expanded_ty)++test_t92 :: Bool+test_t92 =+ $(do a <- newName "a"+ f <- newName "f"+ let t = DForallT (DForallInvis [DPlainTV f SpecifiedSpec])+ (DVarT f `DAppT` DVarT a)+ toposortTyVarsOf [t] `eqTHSplice` [DPlainTV a ()])++test_t97 :: Bool+test_t97 =+ $(do a <- newName "a"+ k <- newName "k"+ let orig_ty = DForallT+ (DForallInvis+ [DKindedTV a SpecifiedSpec+ (DConT ''Constant `DAppT` DConT ''Int+ `DAppT` DVarT k)])+ (DVarT a)+ expected_ty = DForallT (DForallInvis+ [DKindedTV a SpecifiedSpec (DVarT k)])+ (DVarT a)+ expanded_ty <- expandType orig_ty+ expected_ty `eqTHSplice` expanded_ty)++test_getDataD_kind_sig :: Bool+test_getDataD_kind_sig =+ 3 == $(do data_name <- newName "TestData"+ a <- newName "a"+ let type_kind = DConT typeKindName+ data_kind_sig = DArrowT `DAppT` type_kind `DAppT`+ (DArrowT `DAppT` type_kind `DAppT` type_kind)+ (_, tvbs, _) <-+ withLocalDeclarations+ [decToTH (DDataD Data [] data_name [DPlainTV a THAbs.BndrReq]+ (Just data_kind_sig) [] [])]+ (getDataD "th-desugar: Impossible" data_name)+ [| $(Syn.lift (length tvbs)) |])++test_t100 :: Bool+test_t100 =+ $(do decs <- [d| data T b where+ MkT :: forall a. { unT :: a } -> T a |]+ info <- withLocalDeclarations decs (dsReify (mkName "unT"))+ let -- forall a. T a -> a+ exp_ty = DForallT (DForallInvis [DPlainTV (mkName "a") SpecifiedSpec]) $+ DArrowT `DAppT` (DConT (mkName "T") `DAppT` DVarT (mkName "a"))+ `DAppT` DVarT (mkName "a")+ case info of+ Just (DVarI _ actual_ty _) -> exp_ty `eqTHSplice` actual_ty+ _ -> [| False |])++test_t102 :: [Bool]+test_t102 =+ $(do decs1 <- [d| data Foo x where MkFoo :: forall a. { unFoo :: a } -> Foo a |]+ let b1 = withLocalDeclarations decs1 $ do+ [DDataD _ _ _ _ _ cons1 _] <- dsDecs decs1+ recs1 <- getRecordSelectors cons1+ (length recs1 `div` 2) `eqTHSplice` 1+ decs2 <- [d| data HList l where+ Nil :: HList '[]+ (:>) :: { hhead :: x, htail :: HList xs } -> HList (x ': xs) |]+ let b2 = withLocalDeclarations decs2 $ do+ [DDataD _ _ _ _ _ cons2 _] <- dsDecs decs2+ recs2 <- getRecordSelectors cons2+ (length recs2 `div` 2) `eqTHSplice` 2+ [| [$b1, $b2] |])++test_t103 :: Bool+test_t103 =+ $(do decs <- [d| data P (a :: k) = MkP |]+ [DDataD _ _ _ _ _ [DCon tvbs _ _ _ _] _] <- dsDecs decs+ case tvbs of+ [DPlainTV k SpecifiedSpec, DKindedTV a SpecifiedSpec (DVarT k')]+ | nameBase k == "k"+ , nameBase a == "a"+ , k == k'+ -> [| True |]+ | otherwise+ -> [| False |])++test_t112 :: [Bool]+test_t112 =+ $(do a <- newName "a"+ b <- newName "b"+ let aVar = DVarT a+ bVar = DVarT b+ aTvb = DPlainTV a ()+ bTvb = DPlainTV b ()++ fvsABExpected = [aTvb, bTvb]+ fvsABActual = toposortTyVarsOf [aVar, bVar]++ fvsBAExpected = [bTvb, aTvb]+ fvsBAActual = toposortTyVarsOf [bVar, aVar]++ eqAB = fvsABExpected `eqTH` fvsABActual+ eqBA = fvsBAExpected `eqTH` fvsBAActual+ [| [eqAB, eqBA] |])++test_t132 :: Bool+test_t132 =+ $(do let c = mkName "C"+ m = mkName "m"+ a = mkName "a"+ fixity = Fixity 5 InfixR+ -- Defines a class with a fixity declaration inside, i.e.,+ --+ -- class C a where+ -- infixr 5 `m`+ -- m :: a+ --+ -- We define this by hand to avoid GHC#17608 on pre-9.0 GHCs.+ decs = sweeten [ DClassD [] c [DPlainTV a THAbs.BndrReq] []+ [ DLetDec (DInfixD fixity m)+ , DLetDec (DSigD m (DVarT a))+ ]+ ]+ expected = Just fixity+ actual <- withLocalDeclarations decs (reifyFixityWithLocals m)+ expected `eqTHSplice` actual)++#if __GLASGOW_HASKELL__ >= 801+-- Test local reification of pattern synonym record selectors.+test_t137 :: [Bool]+test_t137 =+ $(do a <- newName "a"+ b <- newName "b"+ let aVarT = DVarT a+ aVarP = DVarP a+ bVarT = DVarT b+ bVarP = DVarP b+ aTvb = DPlainTV a SpecifiedSpec+ bTvb = DPlainTV b SpecifiedSpec++ p1 = mkName "P1"+ unP1a = mkName "unP1a"+ unP1b = mkName "unP1b"+ p2 = mkName "P2"+ unP2a = mkName "unP2a"+ unP2b = mkName "unP2b"+ p3 = mkName "P3"+ unP3a = mkName "unP3a"+ unP3b = mkName "unP3b"++ tupleTy = DConT (tupleTypeName 2) `DAppT` aVarT `DAppT` bVarT+ showCxt = [DConT ''Show `DAppT` aVarT]+ patSynSigDBodyTy =+ DArrowT `DAppT` aVarT `DAppT` (DArrowT `DAppT` bVarT `DAppT` tupleTy)++ -- pattern P{unPa, unPb} = (unPa, unPb)+ mkPatSynD :: Name -> Name -> Name -> DDec+ mkPatSynD p unPa unPb =+ DPatSynD+ p+ (RecordPatSyn [unPa, unPb])+ DImplBidir+ (DConP (tupleDataName 2) [] [aVarP, bVarP])++ decs :: [Dec]+ decs = sweeten+ [ -- pattern P1 :: a -> b -> (a, b)+ DPatSynSigD p1 patSynSigDBodyTy+ , mkPatSynD p1 unP1a unP1b++ -- pattern P2 :: Show a => a -> b -> (a, b)+ , DPatSynSigD p2 $ DConstrainedT showCxt patSynSigDBodyTy+ , mkPatSynD p2 unP2a unP2b++ -- pattern P3 :: forall b a. Show a => a -> b -> (a, b)+ , DPatSynSigD p3 $+ DForallT (DForallInvis [bTvb, aTvb]) $+ DConstrainedT showCxt patSynSigDBodyTy+ , mkPatSynD p3 unP3a unP3b+ ]++ -- Pair each pattern synonym record selector name with the type that+ -- local reification should produce.+ expecteds :: [(Name, DType)]+ expecteds =+ [ (unP1a, DForallT (DForallInvis [aTvb, bTvb]) $+ DArrowT `DAppT` tupleTy `DAppT` aVarT)+ , (unP1b, DForallT (DForallInvis [aTvb, bTvb]) $+ DArrowT `DAppT` tupleTy `DAppT` bVarT)++ -- The reified types below use (DForallInvis []) due to the way+ -- that ForallT is desugared.+ -- See Note [Desugaring and sweetening ForallT] in+ -- Language.Haskell.TH.Desugar.Core.+ , (unP2a, DForallT (DForallInvis []) $+ DConstrainedT showCxt $+ DArrowT `DAppT` tupleTy `DAppT` aVarT)+ , (unP2b, DForallT (DForallInvis []) $+ DConstrainedT showCxt $+ DArrowT `DAppT` tupleTy `DAppT` bVarT)++ , (unP3a, DForallT (DForallInvis [bTvb, aTvb]) $+ DConstrainedT showCxt $+ DArrowT `DAppT` tupleTy `DAppT` aVarT)+ , (unP3b, DForallT (DForallInvis [bTvb, aTvb]) $+ DConstrainedT showCxt $+ DArrowT `DAppT` tupleTy `DAppT` bVarT)+ ]++ expected_eq_actual :: (Name, DType) -> DsM Q Bool+ expected_eq_actual (sel_name, expected_ty) = do+ let expected_info = Just $ DVarI sel_name expected_ty Nothing+ actual_info <- dsReify sel_name+ pure $ expected_info `eqTH` actual_info++ bs <- withLocalDeclarations decs $ mapM expected_eq_actual expecteds+ Syn.lift bs)+#endif++test_t154 :: Bool+test_t154 =+ $(do decs <- [d| data T where+ (:$$:) :: Int -> Int -> T+ |]+ ddecs <- dsDecs decs+ let mb_is_infix = case ddecs of+ [DDataD _ _ _ _ _ [DCon _ _ _ (DNormalC is_infix _) _] _]+ -> Just is_infix+ _ -> Nothing+ mb_is_infix `eqTHSplice` Just False)++-- Regression test for #159 which ensures that non-exhaustive functions throw+-- a runtime error before forcing their arguments.+test_t159 :: Expectation+test_t159 = do+ -- NB: Catch ErrorCall here, not PatternMatchFail. This is because we desugar+ -- non-exhaustive patterns into a custom `error` expression.+ let testOne f = f (let x = x in x) `shouldThrow` \(_ :: ErrorCall) -> True+ testOne t159A+ testOne t159B++#if __GLASGOW_HASKELL__ >= 906+test_t170 :: [Bool]+test_t170 =+ $(do decs <- [d| type data TyData = MkTyData |]++ let test_TypeData_NameSpace nameStr =+ withLocalDeclarations decs $ do+ Just name <- lookupTypeNameWithLocals nameStr+ mbNS <- reifyNameSpace name+ mbNS `eqTHSplice` Just Syn.TcClsName++ let b1 = test_TypeData_NameSpace "TyData"+ let b2 = test_TypeData_NameSpace "MkTyData"+ [| [$b1, $b2] |])+#endif++test_t171 :: Bool+test_t171 =+ $(do a <- newName "a"+ b <- newName "b"+ c <- newName "c"+ x <- newName "x"+ y <- newName "y"++ let aVarT = DVarT a+ bVarT = DVarT b+ cVarT = DVarT c+ aTvb = DPlainTV a SpecifiedSpec+ bTvb = DPlainTV b SpecifiedSpec+ cTvb = DPlainTV c SpecifiedSpec+ t = mkName "T"+ mkT = mkName "mkT"+ getT1 = mkName "getT1"+ getT2 = mkName "getT2"++ dec = -- data T x y where+ -- MkT :: forall b a c. { getT1 :: b, getT2 :: c } -> T a b+ DDataD+ Data+ []+ t+ [DPlainTV x THAbs.BndrReq, DPlainTV y THAbs.BndrReq]+ Nothing+ [ DCon+ [bTvb, aTvb, cTvb]+ []+ mkT+ (DRecC [ ( getT1+ , Bang NoSourceUnpackedness NoSourceStrictness+ , bVarT+ )+ , ( getT2+ , Bang NoSourceUnpackedness NoSourceStrictness+ , cVarT+ )+ ])+ res_ty+ ]+ []+ res_ty = DConT t `DAppT` aVarT `DAppT` bVarT+ expected_ty = DForallT (DForallInvis [bTvb, aTvb]) $+ DArrowT `DAppT` res_ty `DAppT` bVarT++ withLocalDeclarations (sweeten [dec]) $ do+ Just (DVarI _ actual_ty _) <- dsReify getT1+ expected_ty `eqTHSplice` actual_ty)++-- Unit tests for tupleNameDegree_maybe. These also act as a regression test for+-- #187.+test_t187 :: [Bool]+test_t187 =+ map (\(s, expected) -> tupleNameDegree_maybe s == expected)+ [ (''(), Just 0)+ , (''(,), Just 2)+ , (''(,,), Just 3)+ , (''Maybe, Nothing)+#if __GLASGOW_HASKELL__ >= 900+ , (''Solo, Just 1)+#if __GLASGOW_HASKELL__ >= 906+ , ('MkSolo, Just 1)+#else+ , ('Solo, Just 1)+#endif+#endif+#if __GLASGOW_HASKELL__ >= 908+ , (''Unit, Just 0)+ , (''Tuple0, Just 0)+ , (''Tuple1, Just 1)+ , (''Tuple2, Just 2)+ , (''Tuple3, Just 3)+ , (''FakeTuples.Tuple0, Nothing)+ , (''FakeTuples.Tuple1, Nothing)+ , (''FakeTuples.Tuple2, Nothing)+ , (''FakeTuples.Tuple3, Nothing)+#endif+ ]++-- A regression test for #188, which ensures that it produces the correct answer+-- for an unusual telescope like:+--+-- ... forall (a1 :: a2). forall (a2 :: a1). ...+--+-- Here, a2 is free in the kind of a1 (the first `forall`), but then the second+-- `forall` binds another a2 that shadows what was already in scope. In this+-- example, `toposortKindVarsOfTvbs [(a1 :: a2), (a2 :: a1)]` should return+-- [a2].+test_t188 :: Bool+test_t188 =+ let a1 = mkName "a1"+ a2 = mkName "a2" in+ toposortKindVarsOfTvbs [DKindedTV a1 () (DVarT a2), DKindedTV a2 () (DVarT a1)]+ == [DPlainTV a2 ()]++-- 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+ -- Test `DSigT` with both `IgnoreKinds` options+ , matchTy NoIgnore (DVarT a `DSigT` DConT ''Bool) (DConT ''Int) == Nothing+ , matchTy YesIgnore (DVarT a `DSigT` DConT ''Bool) (DConT ''Int)+ == Just (M.singleton a (DConT ''Int))+ -- Test `DAppKindT` with both `IgnoreKinds` options+ , matchTy NoIgnore (DConT ''Proxy `DAppKindT` DConT ''Bool `DAppT` DVarT a)+ (DConT ''Proxy `DAppT` DConT ''Int)+ == Nothing+ , matchTy YesIgnore (DConT ''Proxy `DAppKindT` DConT ''Bool `DAppT` DVarT a)+ (DConT ''Proxy `DAppT` DConT ''Int)+ == Just (M.singleton a (DConT ''Int))+ ]+ where+ a = mkName "a"+ b = mkName "b"++-- Test that type synonym expansion is efficient+test_t123 :: ()+test_t123 =+ $(do _ <- expand (DConT ''T123A)+ [| () |])++main :: IO ()+main = hspec $ do+ describe "th-desugar library" $ do+ 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++ it "doesn't reify a field selector with lookupValueNameWithLocals when NoFieldSelectors is set" $+ t183 == Nothing++ zipWithM (\b n -> it ("recognizes tuple names with tupleDegree_maybe correctly " ++ show n) b)+ test_t187 [1..]++ it "computes free kind variables correctly in a telescope that uses shadowing" $ test_t188++ -- 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 nm -> it ("reifies local definition " ++ nameBase nm) $ a == b)+ local_reifications normal_reifications reifyDecsNames++ zipWithM (\b n -> it ("works on simplCase test " ++ show n) b) simplCase [1..]++ zipWithM (\b n -> it ("round-trip successfully on case " ++ show n) b) test_roundtrip [1..]++ zipWithM (\b n -> it ("lookups up local value and type names " ++ show n) b)+ test_lookup_value_type_names [1..]++ zipWithM (\b n -> it ("substitutes tyvar binder kinds " ++ show n) b)+ test_kind_substitution [1..]++ zipWithM (\b n -> it ("matches types " ++ show n) b)+ test_matchTy [1..]++ zipWithM (\b n -> it ("reifies kinds of declarations with CUSKs " ++ show n) b)+ test_reify_type_cusks [1..]++ zipWithM (\b n -> it ("reifies kinds of declarations without CUSKs " ++ show n) b)+ test_reify_type_no_cusks [1..]++ zipWithM (\b n -> it ("reifies the kinds of declarations with signatures " ++ show n) b)+ test_reify_kind_sigs [1..]++ fromHUnitTest tests
Test/Splices.hs view
@@ -1,791 +1,845 @@-{- 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 - ] +{- 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__ < 806+{-# LANGUAGE TypeInType #-}+#endif++#if __GLASGOW_HASKELL__ >= 807+{-# LANGUAGE ImplicitParams #-}+#endif++#if __GLASGOW_HASKELL__ >= 809+{-# LANGUAGE StandaloneKindSignatures #-}+#endif++#if __GLASGOW_HASKELL__ >= 900+{-# LANGUAGE QualifiedDo #-}+#endif++#if __GLASGOW_HASKELL__ >= 902+{-# LANGUAGE OverloadedRecordDot #-}+#endif++#if __GLASGOW_HASKELL__ >= 906+{-# LANGUAGE TypeData #-}+#endif++#if __GLASGOW_HASKELL__ >= 907+{-# LANGUAGE TypeAbstractions #-}+#endif++{-# OPTIONS_GHC -Wno-missing-signatures -Wno-type-defaults+ -Wno-name-shadowing #-}++module Splices where++import qualified Data.List as L+import qualified Data.List.NonEmpty as NE+import Data.List.NonEmpty (NonEmpty(..))+import Data.Char+import qualified Data.Kind as Kind (Type)+import GHC.Exts+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 (assume_spec_t . assume_vis_t . assume_unit_t)+ where+ assume_spec_t :: Typeable a => a -> a+#if __GLASGOW_HASKELL__ >= 900+ assume_spec_t = mkT assume_spec++ assume_spec :: TyVarBndrSpec -> TyVarBndrSpec+ assume_spec (PlainTV n spec) = KindedTV n spec StarT+ assume_spec (KindedTV n spec k) = KindedTV n spec (assumeStarT k)+#else+ assume_spec_t = id+#endif++ assume_vis_t :: Typeable a => a -> a+#if __GLASGOW_HASKELL__ >= 907+ assume_vis_t = mkT assume_vis++ assume_vis :: TyVarBndrVis -> TyVarBndrVis+ assume_vis (PlainTV n vis) = KindedTV n vis StarT+ assume_vis (KindedTV n vis k) = KindedTV n vis (assumeStarT k)+#else+ assume_vis_t = id+#endif++ assume_unit_t :: Typeable a => a -> a+ assume_unit_t = mkT assume_unit++ assume_unit :: TyVarBndrUnit -> TyVarBndrUnit+ assume_unit = elimTV (\n -> kindedTV n StarT)+ (\n k -> kindedTV n (assumeStarT k))++dropTrailing0s :: Data a => a -> a+dropTrailing0s = everywhere (mkT (mkName . frob . nameBase))+ where+ frob str =+ case str of+ 'r':_ -> str+ 'R':_ -> str+ _ -> L.dropWhileEnd isDigit str++-- Because th-desugar does not support linear types, we must pretend like+-- MulArrowT does not exist for testing purposes.+-- See Note [Gracefully handling linear types] in L.H.TH.Desugar.Core.+delinearize :: Data a => a -> a+delinearize = everywhere (mkT no_mul)+ where+ no_mul :: Type -> Type+#if __GLASGOW_HASKELL__ >= 900+ no_mul (MulArrowT `AppT` _) = ArrowT+#endif+ no_mul t = t++eqTH :: (Data a, Show a) => a -> a -> Bool+eqTH a b = show (unqualify a) == show (unqualify b)++eqTHSplice :: (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 = fmap (\r -> r { field2 = 18 }) r1+ r3 = (NE.head r2) { field1 = True } in+ fmap (\case MkRecord1 { field2 = some_int, field1 = some_bool } -> show some_int ++ show some_bool+ MkRecord2 { field2 = some_int, field3 = some_char } -> show some_int ++ show some_char) (NE.cons r3 r2) |]++test15_litp = [| map (\case { 5 -> True ; _ -> False }) [5,6] |]+test16_tupp = [| map (\(x,y,z) -> x + y + z) [(1,2,3),(4,5,6)] |]++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 :: [[Int]] -> [[Int]]+ f = map (map (+1)) in+ map f [ [[1]], [[2]] ] |]+test30_promoted = [| let f :: Proxy '() -> Proxy '[Int, Bool] -> ()+ f _ _ = () in+ f Proxy Proxy |]+test31_constraint = [| let f :: Proxy (c :: 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++#if __GLASGOW_HASKELL__ >= 907+test57_typed_th_bracket =+ typedBracketE [| 'x' |]++test58_typed_th_splice =+ typedSpliceE (typedBracketE [| 'y' |])+#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++#if __GLASGOW_HASKELL__ >= 907+dectest19 = [d| type Dec19 :: forall k. k -> Kind.Type+ data Dec19 @k (a :: k) = MkDec19 k (Proxy 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++ -- A regression test for #184+ data family x ^^^ y+ data instance x ^^^ y = R40 x y++ -- A regression test for #188+ data R41 a (x :: Maybe a) = R42+ |]++reifyDecsNames :: [Name]+reifyDecsNames = map mkName+ [ "r1"+ , "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+ , "R40"+ , "R41", "R42"+ ]++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+#if __GLASGOW_HASKELL__ >= 907+ , test57_typed_th_bracket+ , test58_typed_th_splice+#endif+ ]
Test/T158Exp.hs view
@@ -1,15 +1,15 @@-{-# LANGUAGE MagicHash #-} -{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -Wno-incomplete-patterns #-} - --- | A regression test for #158 which ensures that lambda expressions --- containing patterns with unlifted types desugar as expected. We define this --- test in its own module, without UnboxedTuples enabled, to ensure that users --- do not have to enable the extension themselves. -module T158Exp where - -import Language.Haskell.TH.Desugar - -t158 :: () -t158 = - $([| (\27# 42# -> ()) 27# 42# |] >>= dsExp >>= return . expToTH) +{-# 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 ()+ |])
+ Test/T183.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}++#if __GLASGOW_HASKELL__ >= 907+{-# LANGUAGE NoFieldSelectors #-}+#endif++-- | A regression test for #T183 which ensures that 'lookupValueNameWithLocals'+-- does not reify a field selector when the @NoFieldSelectors@ language+-- extension is set on GHC 9.8 or later. We define this test in its own module+-- to avoid having to enable @NoFieldSelectors@ in other parts of the test+-- suite.+module T183 (t183) where++import Language.Haskell.TH (Name)+#if __GLASGOW_HASKELL__ >= 907+import Language.Haskell.TH.Desugar+#endif++t183 :: Maybe Name+#if __GLASGOW_HASKELL__ >= 907+-- This should return 'Nothing', as the 'unT' record should not be made into a+-- top-level field selector due to @NoFieldSelectors@.+t183 =+ $(do decs <- [d| data T = MkT { unT :: Int } |]+ mbName <- withLocalDeclarations decs (lookupValueNameWithLocals "unT")+ [| mbName |])+#else+-- Lacking @NoFieldSelectors@ on older versions of GHC, we simply hard-code the+-- result to 'Nothing'.+t183 = Nothing+#endif
th-desugar.cabal view
@@ -1,102 +1,106 @@-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 +name: th-desugar+version: 1.16+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.7+ , GHC == 9.4.7+ , GHC == 9.6.2+ , GHC == 9.8.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.22,+ containers >= 0.5,+ mtl >= 2.1 && < 2.4,+ ordered-containers >= 0.2.2,+ syb >= 0.4,+ th-abstraction >= 0.6 && < 0.7,+ 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+ FakeTuples+ ReifyTypeCUSKs+ ReifyTypeSigs+ Splices+ T158Exp+ T159Decs+ T183++ build-depends:+ base >= 4 && < 5,+ ghc-prim,+ template-haskell,+ containers >= 0.5,+ mtl >= 2.1,+ syb >= 0.4,+ HUnit >= 1.2,+ hspec >= 1.3,+ th-abstraction,+ th-desugar,+ th-orphans >= 0.13.9