diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -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 ` when the argument is `''Tuple` + 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 ` for a custom data type named `Tuple`, even + if the custom data type has no relation to the `Tuple` 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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. diff --git a/Language/Haskell/TH/Desugar.hs b/Language/Haskell/TH/Desugar.hs --- a/Language/Haskell/TH/Desugar.hs +++ b/Language/Haskell/TH/Desugar.hs @@ -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. +-} diff --git a/Language/Haskell/TH/Desugar/AST.hs b/Language/Haskell/TH/Desugar/AST.hs --- a/Language/Haskell/TH/Desugar/AST.hs +++ b/Language/Haskell/TH/Desugar/AST.hs @@ -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) diff --git a/Language/Haskell/TH/Desugar/Core.hs b/Language/Haskell/TH/Desugar/Core.hs --- a/Language/Haskell/TH/Desugar/Core.hs +++ b/Language/Haskell/TH/Desugar/Core.hs @@ -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. +-} diff --git a/Language/Haskell/TH/Desugar/Expand.hs b/Language/Haskell/TH/Desugar/Expand.hs --- a/Language/Haskell/TH/Desugar/Expand.hs +++ b/Language/Haskell/TH/Desugar/Expand.hs @@ -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 [] 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 [] 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)) diff --git a/Language/Haskell/TH/Desugar/FV.hs b/Language/Haskell/TH/Desugar/FV.hs --- a/Language/Haskell/TH/Desugar/FV.hs +++ b/Language/Haskell/TH/Desugar/FV.hs @@ -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 diff --git a/Language/Haskell/TH/Desugar/Lift.hs b/Language/Haskell/TH/Desugar/Lift.hs --- a/Language/Haskell/TH/Desugar/Lift.hs +++ b/Language/Haskell/TH/Desugar/Lift.hs @@ -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 () diff --git a/Language/Haskell/TH/Desugar/Match.hs b/Language/Haskell/TH/Desugar/Match.hs --- a/Language/Haskell/TH/Desugar/Match.hs +++ b/Language/Haskell/TH/Desugar/Match.hs @@ -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" diff --git a/Language/Haskell/TH/Desugar/OMap.hs b/Language/Haskell/TH/Desugar/OMap.hs --- a/Language/Haskell/TH/Desugar/OMap.hs +++ b/Language/Haskell/TH/Desugar/OMap.hs @@ -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) diff --git a/Language/Haskell/TH/Desugar/OMap/Strict.hs b/Language/Haskell/TH/Desugar/OMap/Strict.hs --- a/Language/Haskell/TH/Desugar/OMap/Strict.hs +++ b/Language/Haskell/TH/Desugar/OMap/Strict.hs @@ -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) diff --git a/Language/Haskell/TH/Desugar/OSet.hs b/Language/Haskell/TH/Desugar/OSet.hs --- a/Language/Haskell/TH/Desugar/OSet.hs +++ b/Language/Haskell/TH/Desugar/OSet.hs @@ -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) diff --git a/Language/Haskell/TH/Desugar/Reify.hs b/Language/Haskell/TH/Desugar/Reify.hs --- a/Language/Haskell/TH/Desugar/Reify.hs +++ b/Language/Haskell/TH/Desugar/Reify.hs @@ -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_cxt => --- forall . 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_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_cxt => +-- forall . 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_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 diff --git a/Language/Haskell/TH/Desugar/Subst.hs b/Language/Haskell/TH/Desugar/Subst.hs --- a/Language/Haskell/TH/Desugar/Subst.hs +++ b/Language/Haskell/TH/Desugar/Subst.hs @@ -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 diff --git a/Language/Haskell/TH/Desugar/Sweeten.hs b/Language/Haskell/TH/Desugar/Sweeten.hs --- a/Language/Haskell/TH/Desugar/Sweeten.hs +++ b/Language/Haskell/TH/Desugar/Sweeten.hs @@ -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) diff --git a/Language/Haskell/TH/Desugar/Util.hs b/Language/Haskell/TH/Desugar/Util.hs --- a/Language/Haskell/TH/Desugar/Util.hs +++ b/Language/Haskell/TH/Desugar/Util.hs @@ -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@ (for -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@ 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. It is theoretically possible for the supplied + -- Name to be a user-defined data type named Tuple, 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 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 +-- @@ +-- 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) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,106 +1,146 @@ -`th-desugar` Package -==================== - -[![Hackage](https://img.shields.io/hackage/v/th-desugar.svg)](http://hackage.haskell.org/package/th-desugar) -[![Build Status](https://github.com/goldfirere/th-desugar/workflows/Haskell-CI/badge.svg)](https://github.com/goldfirere/th-desugar/actions?query=workflow%3AHaskell-CI) - -This package provides the `Language.Haskell.TH.Desugar` module, which desugars -Template Haskell's rich encoding of Haskell syntax into a simpler encoding. -This desugaring discards surface syntax information (such as the use of infix -operators) but retains the original meaning of the TH code. The intended use -of this package is as a preprocessor for more advanced code manipulation -tools. Note that the input to any of the `ds...` functions should be produced -from a TH quote, using the syntax `[| ... |]`. If the input to these functions -is a hand-coded TH syntax tree, the results may be unpredictable. In -particular, it is likely that promoted datatypes will not work as expected. - -One explicit goal of this package is to reduce the burden of supporting multiple -GHC / TH versions. Thus, the desugared language is the same across all GHC versions, -and any inconsistencies are handled internally. - -The package was designed for use with the `singletons` package, so some design -decisions are based on that use case, when more than one design choice was -possible. - -I will try to keep this package up-to-date with respect to changes in GHC. -The minimum supported version of GHC is 8.0, which was chosen to avoid various -Template Haskell bugs in older GHC versions that affect how this library -desugars code. If this choice negatively impacts you, please submit a bug -report. - -Known limitations ------------------ - -## Limited support for kind inference - -`th-desugar` sometimes has to construct types for certain Haskell entities. -For instance, `th-desugar` desugars all Haskell98-style constructors to use -GADT syntax, so the following: - -```haskell -data T (a :: k) = MkT (Proxy a) -``` - -Will be desugared to something like this: - -```haskell -data T (a :: k) where - MkT :: forall k (a :: k). Proxy a -> T (a :: k) -``` - -Notice that `k` is explicitly quantified in the type of `MkT`. This is due to -an additional pass that `th-desugar` performs over the type variable binders -of `T` to extract all implicitly quantified variables and make them explicit. -This makes the desugared types forwards-compatible with a -[future version of GHC](https://github.com/goldfirere/ghc-proposals/blob/bbefbee6fc0cddb10bbacc85f79e66c2706ce13f/proposals/0000-no-kind-vars.rst) -that requires all kind variables in a top-level `forall` to be explicitly -quantified. - -This process of extracting all implicitly quantified kind variables is not -perfect, however. There are some obscure programs that will cause `th-desugar` -to produce type variable binders that are ill scoped. Here is one example: - -```haskell -data P k (a :: k) -data Foo (a :: Proxy j) (b :: k) c = MkFoo c (P k j) -``` - -If you squint hard at `MkFoo`, you'll notice that `j :: k`. However, this -relationship is not expressed _syntactically_, which means that `th-desugar` -will not be aware of it. Therefore, `th-desugar` will desugar `Foo` to: - -```haskell -data Foo (a :: Proxy j) (b :: k) c where - MkFoo :: forall j k (a :: Proxy j) (b :: k) c. - c -> P k j -> Foo (a :: Proxy j) (b :: k) c -``` - -This is incorrect since `k` must come before `j` in order to be well scoped. -There is a workaround to this issue, however: add more explicit kind -information. If you had instead written this: - -```haskell -data Foo (a :: Proxy (j :: k)) (b :: k) c = MkFoo c (P k j) -``` - -Then the fact that `j :: k` is expressed directly in the AST, so `th-desugar` -is able to pick up on it and pick `forall k j (a :: Proxy j) (b :: k) c. <...>` -as the telescope for the type of `MkFoo`. - -The following constructs are known to be susceptible to this issue: - -1. Desugared Haskell98-style constructors -2. Locally reified class methods -3. Locally reified record selectors -4. Locally reified data constructors -5. Locally reified type family instances (on GHC 8.8 and later, in which the - Template Haskell AST supports explicit `foralls` in type family equations) - -## Limited support for linear types - -Currently, the `th-desugar` AST deliberately makes it impossible to represent -linear types, and desugaring a linear function arrow will simply turn into a -normal function arrow `(->)`. This choice is partly motivated by issues in the -way that linear types interact with Template Haskell, which sometimes make it -impossible to tell whether a reified function type is linear or not. See, for -instance, [GHC#18378](https://gitlab.haskell.org/ghc/ghc/-/issues/18378). +`th-desugar` Package +==================== + +[![Hackage](https://img.shields.io/hackage/v/th-desugar.svg)](http://hackage.haskell.org/package/th-desugar) +[![Build Status](https://github.com/goldfirere/th-desugar/workflows/Haskell-CI/badge.svg)](https://github.com/goldfirere/th-desugar/actions?query=workflow%3AHaskell-CI) + +This package provides the `Language.Haskell.TH.Desugar` module, which desugars +Template Haskell's rich encoding of Haskell syntax into a simpler encoding. +This desugaring discards surface syntax information (such as the use of infix +operators) but retains the original meaning of the TH code. The intended use +of this package is as a preprocessor for more advanced code manipulation +tools. Note that the input to any of the `ds...` functions should be produced +from a TH quote, using the syntax `[| ... |]`. If the input to these functions +is a hand-coded TH syntax tree, the results may be unpredictable. In +particular, it is likely that promoted datatypes will not work as expected. + +One explicit goal of this package is to reduce the burden of supporting multiple +GHC / TH versions. Thus, the desugared language is the same across all GHC versions, +and any inconsistencies are handled internally. + +The package was designed for use with the `singletons` package, so some design +decisions are based on that use case, when more than one design choice was +possible. + +I will try to keep this package up-to-date with respect to changes in GHC. +The minimum supported version of GHC is 8.0, which was chosen to avoid various +Template Haskell bugs in older GHC versions that affect how this library +desugars code. If this choice negatively impacts you, please submit a bug +report. + +Known limitations +----------------- + +## 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). diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple -main = defaultMain +import Distribution.Simple +main = defaultMain diff --git a/Test/Dec.hs b/Test/Dec.hs --- a/Test/Dec.hs +++ b/Test/Dec.hs @@ -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) diff --git a/Test/DsDec.hs b/Test/DsDec.hs --- a/Test/DsDec.hs +++ b/Test/DsDec.hs @@ -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)) diff --git a/Test/FakeTuples.hs b/Test/FakeTuples.hs new file mode 100644 --- /dev/null +++ b/Test/FakeTuples.hs @@ -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 diff --git a/Test/ReifyTypeCUSKs.hs b/Test/ReifyTypeCUSKs.hs --- a/Test/ReifyTypeCUSKs.hs +++ b/Test/ReifyTypeCUSKs.hs @@ -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)) diff --git a/Test/ReifyTypeSigs.hs b/Test/ReifyTypeSigs.hs --- a/Test/ReifyTypeSigs.hs +++ b/Test/ReifyTypeSigs.hs @@ -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) diff --git a/Test/Run.hs b/Test/Run.hs --- a/Test/Run.hs +++ b/Test/Run.hs @@ -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 "" (mapM_ go xs) - TestCase e -> it "" 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 "" (mapM_ go xs) + TestCase e -> it "" 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 diff --git a/Test/Splices.hs b/Test/Splices.hs --- a/Test/Splices.hs +++ b/Test/Splices.hs @@ -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 + ] diff --git a/Test/T158Exp.hs b/Test/T158Exp.hs --- a/Test/T158Exp.hs +++ b/Test/T158Exp.hs @@ -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) diff --git a/Test/T159Decs.hs b/Test/T159Decs.hs --- a/Test/T159Decs.hs +++ b/Test/T159Decs.hs @@ -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 () + |]) diff --git a/Test/T183.hs b/Test/T183.hs new file mode 100644 --- /dev/null +++ b/Test/T183.hs @@ -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 diff --git a/th-desugar.cabal b/th-desugar.cabal --- a/th-desugar.cabal +++ b/th-desugar.cabal @@ -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 -maintainer: Ryan Scott -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 +maintainer: Ryan Scott +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