diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,6 +1,661 @@ `th-desugar` release notes ========================== +Version 1.19 [2026.01.10] +------------------------- +* Support GHC 9.14. +* Support specialising expressions in `SPECIALISE` pragmas. As part of these + changes, a `DSpecialiseEP` data constructor has been added to `DPragma`, and + the existing `DSpecialiseP` data constructor has been converted to a pattern + synonym defined in terms of `DSpecialiseEP`. +* Add `mkTupleDType :: [DType] -> DType`, which offers functionality similar to + the existing `mkTupleD{Exp,Pat}` functions, but for types instead of + expressions or patterns. + +Version 1.18 [2024.12.11] +------------------------- +* Support GHC 9.12. +* Add further support for embedded types in terms. The `DExp` type now has a + `DForallE` data constructor (mirroring `ForallE` and `ForallVisE` in + `template-haskell`) and a `DConstrainedE` data constructor (mirroring + `ConstrainedE` in `template-haskell`). +* The `DLamE` and `DCaseE` data constructors (as well as the related + `mkDLamEFromDPats` function) are now deprecated in favor of the new + `DLamCasesE` data constructor. `DLamE`, `DCaseE`, and `mkDLamEFromDPats` will + be removed in a future release of `th-desugar`, so users are encouraged to + migrate. For more details on how to migrate your code, see [this + document](https://github.com/goldfirere/th-desugar/blob/master/docs/LambdaCaseMigration.md). +* The type of the `dsMatches` function has changed: + + ```diff + -dsMatches :: DsMonad q => Name -> [Match] -> q [DMatch] + +dsMatches :: DsMonad q => MatchContext -> [Match] -> q [DMatch] + ``` + + In particular: + + * `dsMatches` function no longer includes a `Name` argument for the + variable being scrutinized, as the new approach that `th-desugar` uses to + desugar `Match`es no longer requires this. + * `dsMatches` now requires a `MatchContext` argument, which + determines what kind of "`Non-exhaustive patterns in ...`" error it raises + when reaching a fallthrough case for non-exhaustive matches. +* Add a `maybeDCasesE :: MatchContext -> [DExp] -> [DClause] -> DExp` function. + `maybeDCasesE` is similar to `maybeDCaseE` except that it matches on multiple + expressions (using `\\cases`) instead of matching on a single expression. +* Add support for desugaring higher-order uses of embedded type patterns (e.g., + `\(type a) (x :: a) -> x :: a`) and invisible type patterns (e.g., + `\ @a (x :: a) -> x :: a`). +* Add a `Quote` instance for `DsM`. +* Add `mapDTVName` and `mapDTVKind` functions, which allow mapping over the + `Name` and `DKind` of a `DTyVarBndr`, respectively. +* Export `substTyVarBndr` from `Language.Haskell.TH.Desugar.Subst`. +* Add a `Language.Haskell.TH.Desugar.Subst.Capturing` module. This exposes + mostly the same API as `Language.Haskell.TH.Desugar.Subst`, except that the + substitution functions in `Language.Haskell.TH.Desugar.Subst.Capturing` do + not avoid capture when subtituting into a @forall@ type. As a result, these + substitution functions are pure rather than monadic. +* Add `dMatchUpSAKWithDecl`, a function that matches up type variable binders + from a standalone kind signature to the corresponding type variable binders + in the type-level declaration's header: + + * The type signature for `dMatchUpSAKWithDecl` returns + `[DTyVarBndr ForAllTyFlag]`, where `ForAllTyFlag` is a new data type that + generalizes both `Specificity` and `BndrVis`. + * Add `dtvbForAllTyFlagsToSpecs` and `dtvbForAllTyFlagsToBndrVis` functions, + which allow converting the results of calling `dMatchUpSAKWithDecl` to + `[DTyVarBndrSpec]` or `[DTyVarBndrVis]`, respectively. + * Also add `matchUpSAKWithDecl`, `tvbForAllTyFlagsToSpecs`, and + `tvbForAllTyFlagsToBndrVis` functions, which work over `TyVarBndr` instead + of `DTyVarBndr`. +* Locally reifying the type of a data constructor or class method now yields + type signatures with more precise type variable information, as `th-desugar` + now incorporates information from the standalone kind signature (if any) for + the parent data type or class, respectively. For instance, consider the + following data type declaration: + + ```hs + type P :: forall {k}. k -> Type + data P (a :: k) = MkP + ``` + + In previous versions of `th-desugar`, locally reifying `MkP` would yield the + following type: + + ```hs + MkP :: forall k (a :: k). P a + ``` + + This was subtly wrong, as `k` is marked as specified (i.e., eligible for + visible type application), not inferred. In `th-desugar-1.18`, however, the + locally reified type will mark `k` as inferred, as expected: + + ```hs + MkP :: forall {k} (a :: k). P a + ``` + + Similarly, desugaring `MkP` from Template Haskell to `th-desugar` results + in a data constructor with the expected type above. + * As a result of these changes, the type of `dsCon` has changed slightly: + + ```diff + -dsCon :: DsMonad q => [DTyVarBndrUnit] -> DType -> Con -> q [DCon] + +dsCon :: DsMonad q => [DTyVarBndrSpec] -> DType -> Con -> q [DCon] + ``` + +Version 1.17 [2024.05.12] +------------------------- +* Support GHC 9.10. +* Add support namespace identifiers in fixity declarations. As part of these + changes, the `DInfixD` data constructor now has a `NamespaceSpecifier` field. +* Add support for `SCC` declarations via the new `DSCCP` data constructor for + the `DPragma` data type. +* Add partial support for embedded types in expressions (via the new `DTypeE` + data constructor) and in patterns (via the new `DTypeP` data constructor). + This is only partial support because the use of `DTypeP` is supported in the + clauses of function declarations, but not in lambda expressions, `\case` + expressions, or `\cases` expressions. See the "Known limitations" section of + the `th-desugar` `README` for full details. +* Add partial support for invisible type patterns via the new `DInvisP` data + constructor. Just like with `DTypeP`, `th-desugar` only supports the use of + `DInvisP` in the clauses of function declarations. See the "Known limitations" + section of the `th-desugar` `README` for full details. +* `extractBoundNamesDPat` no longer extracts type variables from constructor + patterns. That this function ever did extract type variables was a mistake, + and the new behavior of `extractBoundNamesDPat` brings it in line with the + behavior `extractBoundNamesPat`. +* The `unboxedTupleNameDegree_maybe` function now returns: + * `Just 0` when the argument is `''Unit#` + * `Just 1` when the argument is `''Solo#` + * `Just ` when the argument is `''Tuple#` + This is primarily motivated by the fact that with GHC 9.10 or later, `''(##)` + is syntactic sugar for `''Unit#`, `''(#,#)` is syntactic sugar for `Tuple2#`, + and so on. +* The `unboxedSumNameDegree_maybe` function now returns `Just n` when the + argument is `Sum#`. This is primarily motivated by the fact that with GHC + 9.10 or later, `''(#|#)` is syntactic sugar for `Sum2#`, `''(#||#)` is + syntactic sugar for `Sum3#`, and so on. +* Add `Foldable` and `Traversable` instances for `DTyVarBndrSpec`. + +Version 1.16 [2023.10.13] +------------------------- +* Support GHC 9.8. +* Require `th-abstraction-0.6` or later. +* Add support for invisible binders in type-level declarations. As part of this + change: + + * `Language.Haskell.TH.Desugar` now exports a `DTyVarBndrVis` type synonym, + which is the `th-desugar` counterpart to `TyVarBndrVis`. It also exports a + `dsTvbVis` function, which is the `DTyVarBndrVis` counterpart to `dsTvbSpec` + and `dsTvbUnit`. + * `Language.Haskell.TH.Desugar` now re-exports `BndrVis` from + `template-haskell`. + * The `DDataD`, `DTySynD`, `DClassD`, `DDataFamilyD`, and `DTypeFamilyHead` + parts of the `th-desugar` AST now use `DTyVarBndrVis` instead of + `DTyVarBndrUnit`. + * The `mkExtraDKindBinders`, `dsCon`, and `dsDataDec` functions now use + `DTyVarBndrVis` instead of `DTyVarBndrUnit`. + * The `getDataD` function now uses `TyVarBndrVis` instead of `TyVarBndrUnit`. + + It is possible that you will need to convert between `TyVarBndrUnit` and + `TyVarBndrVis` to adapt your existing `th-desugar` code. (Note that `TyVarBndr + flag` is an instance of `Functor`, so this can be accomplished with `fmap`.) +* `Language.Haskell.TH.Desugar` now exports a family of functions for converting + type variable binders into type arguments while preserving their visibility: + + * The `tyVarBndrVisToTypeArg` and `tyVarBndrVisToTypeArgWithSig` functions + convert a `TyVarBndrVis` to a `TypeArg`. `tyVarBndrVisToTypeArg` omits kind + signatures when converting `KindedTV`s, while `tyVarBndrVisToTypeArgWithSig` + preserves kind signatures. + * The `dTyVarBndrVisToDTypeArg` and `dTyVarBndrVisToDTypeArgWithSig` functions + convert a `DTyVarBndrVis` to a `DTypeArg`. `dTyVarBndrVisToDTypeArg` omits + kind signatures when converting `DKindedTV`s, while + `dTyVarBndrVisToDTypeArgWithSig` preserves kind signatures. +* `th-desugar` now supports generating typed Template Haskell quotes and splices + via the new `DTypedBracketE` and `DTypedSpliceE` constructors of `DExp`, + respectively. +* The `lookupValueNameWithLocals` function will no longer reify field selectors + when the `NoFieldSelectors` language extension is set, mirroring the behavior + of the `lookupValueName` function in `template-haskell`. Note that this will + only happen when using GHC 9.8 or later, as previous versions of GHC do not + equip Template Haskell with enough information to conclude whether a value is + a record field or not. +* The `tupleNameDegree_maybe` function now returns: + * `Just 0` when the argument is `''Unit` + * `Just 1` when the argument is `''Solo` or `'MkSolo` + * `Just ` 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. 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,36 +1,49 @@ {- Language/Haskell/TH/Desugar.hs (c) Richard Eisenberg 2013 -eir@cis.upenn.edu +rae@cs.brynmawr.edu -} {-# LANGUAGE CPP, MultiParamTypeClasses, FunctionalDependencies, - TypeSynonymInstances, FlexibleInstances #-} + TypeSynonymInstances, FlexibleInstances, LambdaCase, + ScopedTypeVariables, PatternSynonyms #-} ----------------------------------------------------------------------------- -- | -- Module : Language.Haskell.TH.Desugar -- Copyright : (C) 2014 Richard Eisenberg -- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (eir@cis.upenn.edu) +-- Maintainer : Ryan Scott -- Stability : experimental -- Portability : non-portable -- -- Desugars full Template Haskell syntax into a smaller core syntax for further --- processing. The desugared types and constructors are prefixed with a D. +-- processing. -- ---------------------------------------------------------------------------- module Language.Haskell.TH.Desugar ( -- * Desugared data types - DExp(..), DLetDec(..), DPat(..), DType(..), DKind, DCxt, DPred(..), - DTyVarBndr(..), DMatch(..), DClause(..), DDec(..), - Overlap(..), NewOrData(..), + DExp(..), pattern DLamE, pattern DCaseE, + DLetDec(..), NamespaceSpecifier(..), DPat(..), + DType(..), DForallTelescope(..), DKind, DCxt, DPred, + DTyVarBndr(..), DTyVarBndrSpec, DTyVarBndrUnit, Specificity(..), + DTyVarBndrVis, +#if __GLASGOW_HASKELL__ >= 907 + BndrVis(..), +#else + BndrVis, + pattern BndrReq, + pattern BndrInvis, +#endif + DMatch(..), DClause(..), DDec(..), + DDerivClause(..), DDerivStrategy(..), DPatSynDir(..), DPatSynType, + Overlap(..), PatSynArgs(..), DataFlavor(..), DTypeFamilyHead(..), DFamilyResultSig(..), InjectivityAnn(..), - DCon(..), DConFields(..), DBangType, DVarBangType, + DCon(..), DConFields(..), DDeclaredInfix, DBangType, DVarBangType, Bang(..), SourceUnpackedness(..), SourceStrictness(..), DForeign(..), - DPragma(..), DRuleBndr(..), DTySynEqn(..), DInfo(..), DInstanceDec, + DPragma(DSpecialiseP, ..), DRuleBndr(..), DTySynEqn(..), DInfo(..), DInstanceDec, Role(..), AnnTarget(..), -- * The 'Desugar' class @@ -39,16 +52,20 @@ -- * Main desugaring functions dsExp, dsDecs, dsType, dsInfo, dsPatOverExp, dsPatsOverExp, dsPatX, - dsLetDecs, dsTvb, dsCxt, + dsLetDecs, dsTvb, dsTvbSpec, dsTvbUnit, dsTvbVis, dsCxt, dsCon, dsForeign, dsPragma, dsRuleBndr, -- ** Secondary desugaring functions - PatM, dsPred, dsPat, dsDec, dsLetDec, + PatM, dsPred, dsPat, dsDec, dsDataDec, dsDataInstDec, + DerivingClause, dsDerivClause, dsLetDec, + MatchContext(..), LamCaseVariant(..), dsMatches, dsBody, dsGuards, dsDoStmts, dsComp, dsClauses, dsBangType, dsVarBangType, -#if __GLASGOW_HASKELL__ > 710 dsTypeFamilyHead, dsFamilyResultSig, +#if __GLASGOW_HASKELL__ >= 801 + dsPatSynDir, #endif + dsTypeArg, -- * Converting desugared AST back to TH AST module Language.Haskell.TH.Desugar.Sweeten, @@ -59,48 +76,97 @@ -- * Reification reifyWithWarning, - -- | The following definitions allow you to register a list of - -- @Dec@s to be used in reification queries. - withLocalDeclarations, dsReify, reifyWithLocals_maybe, reifyWithLocals, + -- ** Local reification + -- $localReification + withLocalDeclarations, dsReify, dsReifyType, + reifyWithLocals_maybe, reifyWithLocals, reifyFixityWithLocals, + reifyTypeWithLocals_maybe, reifyTypeWithLocals, + lookupValueNameWithLocals, lookupTypeNameWithLocals, + mkDataNameWithLocals, mkTypeNameWithLocals, + reifyNameSpace, DsMonad(..), DsM, -- * Nested pattern flattening scExp, scLetDec, + -- * Capture-avoiding substitution and utilities + module Language.Haskell.TH.Desugar.Subst, + + -- * Free variable calculation + module Language.Haskell.TH.Desugar.FV, + -- * Utility functions - applyDExp, applyDType, + applyDExp, dPatToDExp, removeWilds, getDataD, dataConNameToDataName, dataConNameToCon, nameOccursIn, allNamesIn, flattenDValD, getRecordSelectors, mkTypeName, mkDataName, newUniqueName, - mkTupleDExp, mkTupleDPat, maybeDLetE, maybeDCaseE, - substTy, - tupleDegree_maybe, tupleNameDegree_maybe, - unboxedTupleDegree_maybe, unboxedTupleNameDegree_maybe, - strictToBang, + mkTupleDExp, mkTupleDPat, mkTupleDType, + maybeDLetE, maybeDCaseE, maybeDCasesE, + dCaseE, dCasesE, dLamE, dLamCaseE, mkDLamEFromDPats, + tupleNameDegree_maybe, + unboxedSumNameDegree_maybe, unboxedTupleNameDegree_maybe, + isTypeKindName, typeKindName, bindIP, + mkExtraDKindBinders, dTyVarBndrToDType, changeDTVFlags, + mapDTVName, mapDTVKind, + toposortTyVarsOf, toposortKindVarsOfTvbs, + ForAllTyFlag(..), + tvbForAllTyFlagsToSpecs, tvbForAllTyFlagsToBndrVis, matchUpSAKWithDecl, + dtvbForAllTyFlagsToSpecs, dtvbForAllTyFlagsToBndrVis, dMatchUpSAKWithDecl, + -- ** 'FunArgs' and 'VisFunArg' + FunArgs(..), ForallTelescope(..), VisFunArg(..), + filterVisFunArgs, ravelType, unravelType, + + -- ** 'DFunArgs' and 'DVisFunArg' + DFunArgs(..), DVisFunArg(..), + filterDVisFunArgs, ravelDType, unravelDType, + + -- ** 'TypeArg' + TypeArg(..), applyType, filterTANormals, + tyVarBndrVisToTypeArg, tyVarBndrVisToTypeArgWithSig, + unfoldType, + + -- ** 'DTypeArg' + DTypeArg(..), applyDType, filterDTANormals, + dTyVarBndrVisToDTypeArg, dTyVarBndrVisToDTypeArgWithSig, + unfoldDType, + -- ** Extracting bound names extractBoundNamesStmt, extractBoundNamesDec, extractBoundNamesPat ) where +import Language.Haskell.TH.Datatype.TyVarBndr +import Language.Haskell.TH.Desugar.AST import Language.Haskell.TH.Desugar.Core -import Language.Haskell.TH.Desugar.Util -import Language.Haskell.TH.Desugar.Sweeten -import Language.Haskell.TH.Syntax -import Language.Haskell.TH.Desugar.Reify import Language.Haskell.TH.Desugar.Expand +import Language.Haskell.TH.Desugar.FV import Language.Haskell.TH.Desugar.Match +import Language.Haskell.TH.Desugar.Reify +import Language.Haskell.TH.Desugar.Subst +import Language.Haskell.TH.Desugar.Sweeten +import Language.Haskell.TH.Desugar.Util +import Language.Haskell.TH.Syntax +import Control.Monad +import qualified Data.Foldable as F +import Data.Function +import qualified Data.Map as M import qualified Data.Set as S -#if __GLASGOW_HASKELL__ < 709 -import Data.Foldable ( foldMap ) -#endif import Prelude hiding ( exp ) -- | This class relates a TH type with its th-desugar type and allows -- conversions back and forth. The functional dependency goes only one --- way because `Type` and `Kind` are type synonyms, but they desugar --- to different types. +-- way because we define the following instances on old versions of GHC: +-- +-- @ +-- instance 'Desugar' 'TyVarBndrSpec' 'DTyVarBndrSpec' +-- instance 'Desugar' 'TyVarBndrUnit' 'DTyVarBndrUnit' +-- @ +-- +-- Prior to GHC 9.0, 'TyVarBndrSpec' and 'TyVarBndrUnit' are simply type +-- synonyms for 'TyVarBndr', so making the functional dependencies +-- bidirectional would cause these instances to be rejected. class Desugar th ds | ds -> th where desugar :: DsMonad q => th -> q ds sweeten :: ds -> th @@ -117,17 +183,44 @@ desugar = dsCxt sweeten = cxtToTH -instance Desugar TyVarBndr DTyVarBndr where +#if __GLASGOW_HASKELL__ >= 900 +-- | This instance is only @flag@-polymorphic on GHC 9.0 or later, since +-- previous versions of GHC do not equip 'TyVarBndr' with a @flag@ type +-- parameter. As a result, we define two separate instances for 'DTyVarBndr' +-- on older GHCs: +-- +-- @ +-- instance 'Desugar' 'TyVarBndrSpec' 'DTyVarBndrSpec' +-- instance 'Desugar' 'TyVarBndrUnit' 'DTyVarBndrUnit' +-- @ +instance Desugar (TyVarBndr flag) (DTyVarBndr flag) where desugar = dsTvb sweeten = tvbToTH +#else +-- | This instance monomorphizes the @flag@ parameter of 'DTyVarBndr' since +-- pre-9.0 versions of GHC do not equip 'TyVarBndr' with a @flag@ type +-- parameter. There is also a corresponding instance for +-- 'TyVarBndrUnit'/'DTyVarBndrUnit'. +instance Desugar TyVarBndrSpec DTyVarBndrSpec where + desugar = dsTvbSpec + sweeten = tvbToTH +-- | This instance monomorphizes the @flag@ parameter of 'DTyVarBndr' since +-- pre-9.0 versions of GHC do not equip 'TyVarBndr' with a @flag@ type +-- parameter. There is also a corresponding instance for +-- 'TyVarBndrSpec'/'DTyVarBndrSpec'. +instance Desugar TyVarBndrUnit DTyVarBndrUnit where + desugar = dsTvbUnit + sweeten = tvbToTH +#endif + instance Desugar [Dec] [DDec] where desugar = dsDecs sweeten = decsToTH -instance Desugar [Con] [DCon] where - desugar = concatMapM dsCon - sweeten = map conToTH +instance Desugar TypeArg DTypeArg where + desugar = dsTypeArg + sweeten = typeArgToTH -- | If the declaration passed in is a 'DValD', creates new, equivalent -- declarations such that the 'DPat' in all 'DValD's is just a plain @@ -136,11 +229,11 @@ -- less efficient than those that come in: they have many more pattern -- matches. flattenDValD :: Quasi q => DLetDec -> q [DLetDec] -flattenDValD dec@(DValD (DVarPa _) _) = return [dec] +flattenDValD dec@(DValD (DVarP _) _) = return [dec] flattenDValD (DValD pat exp) = do x <- newUniqueName "x" -- must use newUniqueName here because we might be top-level - let top_val_d = DValD (DVarPa x) exp - bound_names = S.elems $ extractBoundNamesDPat pat + let top_val_d = DValD (DVarP x) exp + bound_names = F.toList $ extractBoundNamesDPat pat other_val_ds <- mapM (mk_val_d x) bound_names return $ top_val_d : other_val_ds where @@ -148,72 +241,225 @@ y <- newUniqueName "y" let pat' = wildify name y pat match = DMatch pat' (DVarE y) - cas = DCaseE (DVarE x) [match] - return $ DValD (DVarPa name) cas + cas = dCaseE (DVarE x) [match] + return $ DValD (DVarP name) cas wildify name y p = case p of - DLitPa lit -> DLitPa lit - DVarPa n - | n == name -> DVarPa y - | otherwise -> DWildPa - DConPa con ps -> DConPa con (map (wildify name y) ps) - DTildePa pa -> DTildePa (wildify name y pa) - DBangPa pa -> DBangPa (wildify name y pa) - DWildPa -> DWildPa + DLitP lit -> DLitP lit + DVarP n + | n == name -> DVarP y + | otherwise -> DWildP + DConP con ts ps -> DConP con ts (map (wildify name y) ps) + DTildeP pa -> DTildeP (wildify name y pa) + DBangP pa -> DBangP (wildify name y pa) + DSigP pa ty -> DSigP (wildify name y pa) ty + DWildP -> DWildP + DTypeP ty -> DTypeP ty + DInvisP ty -> DInvisP ty flattenDValD other_dec = return [other_dec] -extractBoundNamesDPat :: DPat -> S.Set Name -extractBoundNamesDPat (DLitPa _) = S.empty -extractBoundNamesDPat (DVarPa n) = S.singleton n -extractBoundNamesDPat (DConPa _ pats) = foldMap extractBoundNamesDPat pats -extractBoundNamesDPat (DTildePa pat) = extractBoundNamesDPat pat -extractBoundNamesDPat (DBangPa pat) = extractBoundNamesDPat pat -extractBoundNamesDPat DWildPa = S.empty - -fvDType :: DType -> S.Set Name -fvDType = go +-- | Produces 'DLetDec's representing the record selector functions from +-- the provided 'DCon's. +-- +-- Note that if the same record selector appears in multiple constructors, +-- 'getRecordSelectors' will return only one binding for that selector. +-- For example, if you had: +-- +-- @ +-- data X = X1 {y :: Symbol} | X2 {y :: Symbol} +-- @ +-- +-- Then calling 'getRecordSelectors' on @[X1, X2]@ will return: +-- +-- @ +-- [ DSigD y (DAppT (DAppT DArrowT (DConT X)) (DConT Symbol)) +-- , DFunD y [ DClause [DConP X1 [DVarP field]] (DVarE field) +-- , DClause [DConP X2 [DVarP field]] (DVarE field) ] ] +-- @ +-- +-- instead of returning one binding for @X1@ and another binding for @X2@. +-- +-- 'getRecordSelectors' does not attempt to filter out \"naughty\" record +-- selectors—that is, records whose field types mention existentially +-- quantified type variables that do not appear in the constructor's return +-- type. Here is an example of a naughty record selector: +-- +-- @ +-- data Some :: (Type -> Type) -> Type where +-- MkSome :: { getSome :: f a } -> Some f +-- @ +-- +-- GHC itself will not allow the use of @getSome@ as a top-level function due +-- to its type @f a@ mentioning the existential variable @a@, but +-- 'getRecordSelectors' will return it nonetheless. Ultimately, this design +-- choice is a practical one, as detecting which type variables are existential +-- in Template Haskell is difficult in the general case. +getRecordSelectors :: DsMonad q => [DCon] -> q [DLetDec] +getRecordSelectors cons = merge_let_decs `fmap` concatMapM get_record_sels cons where - go (DForallT tvbs _cxt ty) = go ty `S.difference` (foldMap dtvbName tvbs) - go (DAppT ty1 ty2) = go ty1 `S.union` go ty2 - go (DSigT ty ki) = go ty `S.union` fvDType ki - go (DVarT n) = S.singleton n - go (DConT _) = S.empty - go DArrowT = S.empty - go (DLitT {}) = S.empty - go DWildCardT = S.empty - go DStarT = S.empty + get_record_sels (DCon con_tvbs _ con_name con_fields con_ret_ty) = + case con_fields of + DRecC fields -> go fields + DNormalC{} -> return [] + where + go fields = do + varName <- qNewName "field" + return $ concat + [ [ DSigD name $ DForallT (DForallInvis con_tvbs) + $ DArrowT `DAppT` con_ret_ty `DAppT` field_ty + , DFunD name [DClause [DConP con_name [] + (mk_field_pats n (length fields) varName)] + (DVarE varName)] ] + | ((name, _strict, field_ty), n) <- zip fields [0..] + ] -dtvbName :: DTyVarBndr -> S.Set Name -dtvbName (DPlainTV n) = S.singleton n -dtvbName (DKindedTV n _) = S.singleton n + mk_field_pats :: Int -> Int -> Name -> [DPat] + mk_field_pats 0 total name = DVarP name : (replicate (total-1) DWildP) + mk_field_pats n total name = DWildP : mk_field_pats (n-1) (total-1) name --- | Produces 'DLetDec's representing the record selector functions from --- the provided 'DCon'. -getRecordSelectors :: Quasi q - => DType -- ^ the type of the argument - -> DCon - -> q [DLetDec] -getRecordSelectors arg_ty (DCon _ _ con_name con _) = case con of - DRecC fields -> go fields - _ -> return [] + merge_let_decs :: [DLetDec] -> [DLetDec] + merge_let_decs decs = + let (name_clause_map, decs') = gather_decs M.empty S.empty decs + in augment_clauses name_clause_map decs' + -- First, for each record selector-related declarations, do the following: + -- + -- 1. If it's a DFunD... + -- a. If we haven't encountered it before, add a mapping from its Name + -- to its associated DClauses, and continue. + -- b. If we have encountered it before, augment the existing Name's + -- mapping with the new clauses. Then remove the DFunD from the list + -- and continue. + -- 2. If it's a DSigD... + -- a. If we haven't encountered it before, remember its Name and continue. + -- b. If we have encountered it before, remove the DSigD from the list + -- and continue. + -- 3. Otherwise, continue. + -- + -- After this, scan over the resulting list once more with the mapping + -- that we accumulated. For every DFunD, replace its DClauses with the + -- ones corresponding to its Name in the mapping. + -- + -- Note that this algorithm combines all of the DClauses for each unique + -- Name, while preserving the order in which the DFunDs were originally + -- found. Moreover, it removes duplicate DSigD entries. Using Maps and + -- Sets avoid quadratic blowup for data types with many record selectors. + where + gather_decs :: M.Map Name [DClause] -> S.Set Name -> [DLetDec] + -> (M.Map Name [DClause], [DLetDec]) + gather_decs name_clause_map _ [] = (name_clause_map, []) + gather_decs name_clause_map type_sig_names (x:xs) + -- 1. + | DFunD n clauses <- x + = let name_clause_map' = M.insertWith (\new old -> old ++ new) + n clauses name_clause_map + in if n `M.member` name_clause_map + then gather_decs name_clause_map' type_sig_names xs + else let (map', decs') = gather_decs name_clause_map' + type_sig_names xs + in (map', x:decs') + + -- 2. + | DSigD n _ <- x + = if n `S.member` type_sig_names + then gather_decs name_clause_map type_sig_names xs + else let (map', decs') = gather_decs name_clause_map + (n `S.insert` type_sig_names) xs + in (map', x:decs') + + -- 3. + | otherwise = + let (map', decs') = gather_decs name_clause_map type_sig_names xs + in (map', x:decs') + + augment_clauses :: M.Map Name [DClause] -> [DLetDec] -> [DLetDec] + augment_clauses _ [] = [] + augment_clauses name_clause_map (x:xs) + | DFunD n _ <- x, Just merged_clauses <- n `M.lookup` name_clause_map + = DFunD n merged_clauses:augment_clauses name_clause_map xs + | otherwise = x:augment_clauses name_clause_map xs + +-- | Create new kind variable binder names corresponding to the return kind of +-- a data type. This is useful when you have a data type like: +-- +-- @ +-- data Foo :: forall k. k -> Type -> Type where ... +-- @ +-- +-- But you want to be able to refer to the type @Foo a b@. +-- 'mkExtraDKindBinders' will take the kind @forall k. k -> Type -> Type@, +-- discover that is has two visible argument kinds, and return as a result +-- two new kind variable binders @[a :: k, b :: Type]@, where @a@ and @b@ +-- are fresh type variable names. +-- +-- This expands kind synonyms if necessary. +mkExtraDKindBinders :: forall q. DsMonad q => DKind -> q [DTyVarBndrVis] +mkExtraDKindBinders k = do + k' <- expandType k + let (fun_args, _) = unravelDType k' + vis_fun_args = filterDVisFunArgs fun_args + mapM mk_tvb vis_fun_args where - go fields = do - varName <- qNewName "field" - let tvbs = fvDType arg_ty - maybe_forall - | S.null tvbs = id - | otherwise = DForallT (map DPlainTV $ S.toList tvbs) [] - num_pats = length fields - return $ concat - [ [ DSigD name (maybe_forall $ DArrowT `DAppT` arg_ty `DAppT` res_ty) - , DFunD name [DClause [DConPa con_name (mk_field_pats n num_pats varName)] - (DVarE varName)] ] - | ((name, _strict, res_ty), n) <- zip fields [0..] - , fvDType res_ty `S.isSubsetOf` tvbs -- exclude "naughty" selectors - ] + mk_tvb :: DVisFunArg -> q (DTyVarBndrVis) + mk_tvb (DVisFADep tvb) = return (BndrReq <$ tvb) + mk_tvb (DVisFAAnon ki) = do + name <- qNewName "a" + pure $ DKindedTV name BndrReq ki - mk_field_pats :: Int -> Int -> Name -> [DPat] - mk_field_pats 0 total name = DVarPa name : (replicate (total-1) DWildPa) - mk_field_pats n total name = DWildPa : mk_field_pats (n-1) (total-1) name +{- $localReification + +@template-haskell@ reification functions like 'reify' and 'qReify', as well as +@th-desugar@'s 'reifyWithWarning', only look through declarations that either +(1) have already been typechecked in the current module, or (2) are in scope +because of imports. We refer to this as /global/ reification. Sometimes, +however, you may wish to reify declarations that have been quoted but not +yet been typechecked, such as in the following example: + +@ +example :: IO () +example = putStrLn + $(do decs <- [d| data Foo = MkFoo |] + info <- 'reify' (mkName \"Foo\") + stringE $ pprint info) +@ + +Because @Foo@ only exists in a TH quote, it is not available globally. As a +result, the call to @'reify' (mkName \"Foo\")@ will fail. + +To make this sort of example possible, @th-desugar@ extends global reification +with /local/ reification. A function that performs local reification (such +as 'dsReify', 'reifyWithLocals', or similar functions that have a 'DsMonad' +context) looks through both typechecked (or imported) declarations /and/ quoted +declarations that are currently in scope. One can add quoted declarations in +the current scope by using the 'withLocalDeclarations' function. Here is an +example of how to repair the example above using 'withLocalDeclarations': + +@ +example2 :: IO () +example2 = putStrLn + $(do decs <- [d| data Foo = MkFoo |] + info <- 'withLocalDeclarations' decs $ + 'reifyWithLocals' (mkName \"Foo\") + stringE $ pprint info) +@ + +Note that 'withLocalDeclarations' should only be used to add quoted +declarations with names that are not duplicates of existing global or local +declarations. Adding duplicate declarations through 'withLocalDeclarations' +is undefined behavior and should be avoided. This is unlikely to happen if +you are only using 'withLocalDeclarations' in conjunction with TH quotes, +however. For instance, this is /not/ an example of duplicate declarations: + +@ +data T = MkT1 + +$(do decs <- [d| data T = MkT2 |] + info <- 'withLocalDeclarations' decs ... + ...) +@ + +The quoted @data T = MkT2@ does not conflict with the top-level @data T = Mk1@ +since declaring a data type within TH quotes gives it a fresh, unique name that +distinguishes it from any other data types already in scope. +-} diff --git a/Language/Haskell/TH/Desugar/AST.hs b/Language/Haskell/TH/Desugar/AST.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/TH/Desugar/AST.hs @@ -0,0 +1,494 @@ +{- Language/Haskell/TH/Desugar/AST.hs + +(c) Ryan Scott 2018 + +Defines the desugared Template Haskell AST. The desugared types and +constructors are prefixed with a D. +-} + +{-# LANGUAGE CPP, DeriveDataTypeable, DeriveTraversable, DeriveGeneric, DeriveLift, PatternSynonyms, ViewPatterns #-} + +module Language.Haskell.TH.Desugar.AST where + +import Data.Data hiding (Fixity) +import GHC.Generics hiding (Fixity) +import Language.Haskell.TH +import Language.Haskell.TH.Instances () +import Language.Haskell.TH.Syntax (Lift) +#if __GLASGOW_HASKELL__ < 900 +import Language.Haskell.TH.Datatype.TyVarBndr (Specificity(..)) +#endif +#if __GLASGOW_HASKELL__ < 907 +import Language.Haskell.TH.Datatype.TyVarBndr (BndrVis) +#endif + +import Language.Haskell.TH.Desugar.Util (DataFlavor) + +-- | Corresponds to TH's @Exp@ type. Note that @DLamE@ takes names, not patterns. +data DExp = DVarE Name + | DConE Name + | DLitE Lit + | DAppE DExp DExp + | DAppTypeE DExp DType + -- | A @\\cases@ expression. In the spirit of making 'DExp' minimal, + -- @th-desugar@ will desugar lambda expressions, @case@ expressions, + -- @\\case@ expressions, and @\\cases@ expressions to 'DLamCasesE'. + -- (See also the 'dLamE', 'dCaseE', and 'dLamCaseE' functions for + -- constructing these expressions in terms of 'DLamCasesE'.) + -- + -- A 'DLamCasesE' value should obey the following invariants: + -- + -- * Each 'DClause' should have exactly the same number of visible + -- arguments in its list of 'DPat's. + -- + -- * If the list of 'DClause's is empty, then the overall expression + -- should have exactly one argument. Note that this is a + -- difference in behavior from how @\\cases@ expressions work, as + -- @\\cases@ is required to have at least one clause. For this + -- reason, @th-desugar@ will sweeten @DLamCasesE []@ to + -- @\\case{}@. + | DLamCasesE [DClause] + | DLetE [DLetDec] DExp + | DSigE DExp DType + | DStaticE DExp + | DTypedBracketE DExp + | DTypedSpliceE DExp + | DTypeE DType + | DForallE DForallTelescope DExp + | DConstrainedE [DExp] DExp + deriving (Eq, Show, Data, Generic, Lift) + +-- | A 'DLamCasesE' value with exactly one 'DClause' where all 'DPat's are +-- 'DVarP's. This pattern synonym is provided for backwards compatibility with +-- older versions of @th-desugar@ in which 'DLamE' was a data constructor of +-- 'DExp'. This pattern synonym is deprecated and will be removed in a future +-- release of @th-desugar@. +pattern DLamE :: [Name] -> DExp -> DExp +pattern DLamE vars rhs <- (dLamE_maybe -> Just (vars, rhs)) + where + DLamE vars rhs = DLamCasesE [DClause (map DVarP vars) rhs] +{-# DEPRECATED DLamE "Use `dLamE` or `DLamCasesE` instead." #-} + +-- | Return @'Just' (pats, rhs)@ if the supplied 'DExp' is a 'DLamCasesE' value +-- with exactly one 'DClause' where all 'DPat's are 'DVarP's, where @pats@ is +-- the list of 'DVarP' 'Name's and @rhs@ is the expression on the right-hand +-- side of the 'DClause'. Otherwise, return 'Nothing'. +dLamE_maybe :: DExp -> Maybe ([Name], DExp) +dLamE_maybe (DLamCasesE [DClause pats rhs]) = do + vars <- traverse dVarP_maybe pats + Just (vars, rhs) +dLamE_maybe _ = Nothing + +-- | Return @'Just' var@ if the supplied 'DPat' is a 'DVarP' value, where @var@ +-- is the 'DVarP' 'Name'. Otherwise, return 'Nothing'. +dVarP_maybe :: DPat -> Maybe Name +dVarP_maybe (DVarP n) = Just n +dVarP_maybe _ = Nothing + +-- | An application of a 'DLamCasesE' to some argument, where each 'DClause' in +-- the 'DLamCasesE' value has exactly one 'DPat'. This pattern synonym is +-- provided for backwards compatibility with older versions of @th-desugar@ in +-- which 'DCaseE' was a data constructor of 'DExp'. This pattern synonym is +-- deprecated and will be removed in a future release of @th-desugar@. +pattern DCaseE :: DExp -> [DMatch] -> DExp +pattern DCaseE scrut matches <- (dCaseE_maybe -> Just (scrut, matches)) + where + DCaseE scrut matches = DAppE (dLamCaseE matches) scrut +{-# DEPRECATED DCaseE "Use `dCaseE` or `DLamCasesE` instead." #-} + +-- | Return @'Just' (scrut, matches)@ if the supplied 'DExp' is a 'DLamCasesE' +-- value applied to some argument, where each 'DClause' in the 'DLamCasesE' +-- value has exactly one 'DPat'. Otherwise, return 'Nothing'. +dCaseE_maybe :: DExp -> Maybe (DExp, [DMatch]) +dCaseE_maybe (DAppE (DLamCasesE clauses) scrut) = do + matches <- traverse dMatch_maybe clauses + Just (scrut, matches) +dCaseE_maybe _ = Nothing + +-- | Construct a 'DExp' value that is equivalent to writing a @case@ expression. +-- Under the hood, this uses @\\cases@ ('DLamCasesE'). For instance, given this +-- code: +-- +-- @ +-- case scrut of +-- pat_1 -> rhs_1 +-- ... +-- pat_n -> rhs_n +-- @ +-- +-- The following @\\cases@ expression will be created under the hood: +-- +-- @ +-- (\\cases +-- pat_1 -> rhs_1 +-- ... +-- pat_n -> rhs_n) scrut +-- @ +dCaseE :: DExp -> [DMatch] -> DExp +dCaseE scrut matches = DAppE (dLamCaseE matches) scrut + +-- | Construct a 'DExp' value that is equivalent to writing a lambda expression. +-- Under the hood, this uses @\\cases@ ('DLamCasesE'). For instance, given this +-- code: +-- +-- @ +-- \\var_1 ... var_n -> rhs +-- @ +-- +-- The following @\\cases@ expression will be created under the hood: +-- +-- @ +-- \\cases var_1 ... var_n -> rhs +-- @ +dLamE :: [DPat] -> DExp -> DExp +dLamE pats rhs = DLamCasesE [DClause pats rhs] + +-- | Construct a 'DExp' value that is equivalent to writing a @\\case@ +-- expression. Under the hood, this uses @\\cases@ ('DLamCasesE'). For instance, +-- given this code: +-- +-- @ +-- \\case +-- pat_1 -> rhs_1 +-- ... +-- pat_n -> rhs_n +-- @ +-- +-- The following @\\cases@ expression will be created under the hood: +-- +-- @ +-- \\cases +-- pat_1 -> rhs_1 +-- ... +-- pat_n -> rhs_n +-- @ +dLamCaseE :: [DMatch] -> DExp +dLamCaseE = DLamCasesE . map dMatchToDClause + +-- | Corresponds to TH's @Pat@ type. +data DPat = DLitP Lit + | DVarP Name + | DConP Name [DType] [DPat] + | DTildeP DPat + | DBangP DPat + | DSigP DPat DType + | DWildP + | DTypeP DType + | DInvisP DType + deriving (Eq, Show, Data, Generic, Lift) + +-- | Corresponds to TH's @Type@ type, used to represent +-- types and kinds. +data DType = DForallT DForallTelescope DType + | DConstrainedT DCxt DType + | DAppT DType DType + | DAppKindT DType DKind + | DSigT DType DKind + | DVarT Name + | DConT Name + | DArrowT + | DLitT TyLit + | DWildCardT + deriving (Eq, Show, Data, Generic, Lift) + +-- | The type variable binders in a @forall@. +data DForallTelescope + = DForallVis [DTyVarBndrUnit] + -- ^ A visible @forall@ (e.g., @forall a -> {...}@). + -- These do not have any notion of specificity, so we use + -- '()' as a placeholder value in the 'DTyVarBndr's. + | DForallInvis [DTyVarBndrSpec] + -- ^ An invisible @forall@ (e.g., @forall a {b} c -> {...}@), + -- where each binder has a 'Specificity'. + deriving (Eq, Show, Data, Generic, Lift) + +-- | Kinds are types. Corresponds to TH's @Kind@ +type DKind = DType + +-- | Predicates are types. Corresponds to TH's @Pred@ +type DPred = DType + +-- | Corresponds to TH's @Cxt@ +type DCxt = [DPred] + +-- | Corresponds to TH's @TyVarBndr@ +data DTyVarBndr flag + = DPlainTV Name flag + | DKindedTV Name flag DKind + deriving (Eq, Show, Data, Generic, Functor, Foldable, Traversable, Lift) + +-- | Corresponds to TH's @TyVarBndrSpec@ +type DTyVarBndrSpec = DTyVarBndr Specificity + +-- | Corresponds to TH's @TyVarBndrUnit@ +type DTyVarBndrUnit = DTyVarBndr () + +-- | Corresponds to TH's @TyVarBndrVis@ +type DTyVarBndrVis = DTyVarBndr BndrVis + +-- | Corresponds to TH's @Match@ type. +-- +-- Note that while @Match@ appears in the TH AST, 'DMatch' does not appear +-- directly in the @th-desugar@ AST. This is because TH's 'Match' is used in +-- lambda (@LamE@) and @case@ (@CaseE@) expressions, but @th-desugar@ does not +-- have counterparts to @LamE@ and @CaseE@ in the 'DExp' data type. Instead, +-- 'DExp' only has a @\\cases@ ('DLamCasesE') construct, which uses 'DClause' +-- instead of 'DMatch'. +-- +-- As such, 'DMatch' only plays a \"vestigial\" role in @th-desugar@ for +-- constructing 'DLamCasesE' values that look like lambda or @case@ expressions. +-- For example, 'DMatch' appears in the type signatures for 'dLamE' and +-- 'dCaseE', which convert the supplied 'DMatch'es to 'DClause's under the hood. +data DMatch = DMatch DPat DExp + deriving (Eq, Show, Data, Generic, Lift) + +-- | Corresponds to TH's @Clause@ type. +data DClause = DClause [DPat] DExp + deriving (Eq, Show, Data, Generic, Lift) + +-- | Convert a 'DMatch' to a 'DClause', where the 'DClause' contains a single +-- pattern taken from the 'DMatch'. +dMatchToDClause :: DMatch -> DClause +dMatchToDClause (DMatch pat rhs) = DClause [pat] rhs + +-- | Return @'Just' match@ if the supplied 'DClause' has exactly one 'DPat', +-- where @match@ matches on that 'DPat'. Otherwise, return 'Nothing'. +dMatch_maybe :: DClause -> Maybe DMatch +dMatch_maybe (DClause pats rhs) = + case pats of + [pat] -> Just (DMatch pat rhs) + _ -> Nothing + +-- | Declarations as used in a @let@ statement. +data DLetDec = DFunD Name [DClause] + | DValD DPat DExp + | DSigD Name DType + | DInfixD Fixity NamespaceSpecifier Name + | DPragmaD DPragma + deriving (Eq, Show, Data, Generic, Lift) + +#if __GLASGOW_HASKELL__ < 909 +-- | Same as @NamespaceSpecifier@ from TH; defined here for backwards +-- compatibility. +data NamespaceSpecifier + = NoNamespaceSpecifier -- ^ Name may be everything; If there are two + -- names in different namespaces, then consider both + | TypeNamespaceSpecifier -- ^ Name should be a type-level entity, such as a + -- data type, type alias, type family, type class, + -- or type variable + | DataNamespaceSpecifier -- ^ Name should be a term-level entity, such as a + -- function, data constructor, or pattern synonym + deriving (Eq, Ord, Show, Data, Generic, Lift) +#endif + +-- | Corresponds to TH's @Dec@ type. +data DDec = DLetDec DLetDec + -- | An ordinary (i.e., non-data family) data type declaration. Note + -- that desugaring upholds the following properties regarding the + -- 'DataFlavor' field: + -- + -- * If the 'DataFlavor' is 'NewType', then there will be exactly + -- one 'DCon'. + -- + -- * If the 'DataFlavor' is 'TypeData', then there will be no + -- 'DDerivClause's, the 'DCxt' will be empty, and the 'DConFields' + -- in each 'DCon' will be a 'NormalC' where each 'Bang' is equal + -- to @Bang 'NoSourceUnpackedness' 'NoSourceStrictness'@. + | DDataD DataFlavor DCxt Name [DTyVarBndrVis] (Maybe DKind) [DCon] [DDerivClause] + | DTySynD Name [DTyVarBndrVis] DType + | DClassD DCxt Name [DTyVarBndrVis] [FunDep] [DDec] + -- | Note that the @Maybe [DTyVarBndrUnit]@ field is dropped + -- entirely when sweetened, so it is only useful for functions + -- that directly consume @DDec@s. + | DInstanceD (Maybe Overlap) (Maybe [DTyVarBndrUnit]) DCxt DType [DDec] + | DForeignD DForeign + | DOpenTypeFamilyD DTypeFamilyHead + | DClosedTypeFamilyD DTypeFamilyHead [DTySynEqn] + | DDataFamilyD Name [DTyVarBndrVis] (Maybe DKind) + -- | A data family instance declaration. Note that desugaring + -- upholds the following properties regarding the 'DataFlavor' + -- field: + -- + -- * If the 'DataFlavor' is 'NewType', then there will be exactly + -- one 'DCon'. + -- + -- * The 'DataFlavor' will never be 'TypeData', as GHC does not + -- permit combining data families with @type data@. + | DDataInstD DataFlavor DCxt (Maybe [DTyVarBndrUnit]) DType (Maybe DKind) + [DCon] [DDerivClause] + | DTySynInstD DTySynEqn + | DRoleAnnotD Name [Role] + -- | Note that the @Maybe [DTyVarBndrUnit]@ field is dropped + -- entirely when sweetened, so it is only useful for functions + -- that directly consume @DDec@s. + | DStandaloneDerivD (Maybe DDerivStrategy) (Maybe [DTyVarBndrUnit]) DCxt DType + | DDefaultSigD Name DType + | DPatSynD Name PatSynArgs DPatSynDir DPat + | DPatSynSigD Name DPatSynType + | DKiSigD Name DKind + -- DKiSigD is part of DDec, not DLetDec, because standalone kind + -- signatures can only appear on the top level. + | DDefaultD [DType] + deriving (Eq, Show, Data, Generic, Lift) + +-- | Corresponds to TH's 'PatSynDir' type +data DPatSynDir = DUnidir -- ^ @pattern P x {<-} p@ + | DImplBidir -- ^ @pattern P x {=} p@ + | DExplBidir [DClause] -- ^ @pattern P x {<-} p where P x = e@ + deriving (Eq, Show, Data, Generic, Lift) + +-- | Corresponds to TH's 'PatSynType' type +type DPatSynType = DType + +#if __GLASGOW_HASKELL__ < 801 +-- | Same as @PatSynArgs@ from TH; defined here for backwards compatibility. +data PatSynArgs + = PrefixPatSyn [Name] -- ^ @pattern P {x y z} = p@ + | InfixPatSyn Name Name -- ^ @pattern {x P y} = p@ + | RecordPatSyn [Name] -- ^ @pattern P { {x,y,z} } = p@ + deriving (Eq, Show, Data, Generic, Lift) +#endif + +-- | Corresponds to TH's 'TypeFamilyHead' type +data DTypeFamilyHead = DTypeFamilyHead Name [DTyVarBndrVis] DFamilyResultSig + (Maybe InjectivityAnn) + deriving (Eq, Show, Data, Generic, Lift) + +-- | Corresponds to TH's 'FamilyResultSig' type +data DFamilyResultSig = DNoSig + | DKindSig DKind + | DTyVarSig DTyVarBndrUnit + deriving (Eq, Show, Data, Generic, Lift) + +-- | Corresponds to TH's 'Con' type. Unlike 'Con', all 'DCon's reflect GADT +-- syntax. This is beneficial for @th-desugar@'s since it means +-- that all data type declarations can support explicit return kinds, so +-- one does not need to represent them with something like @'Maybe' 'DKind'@, +-- since Haskell98-style data declaration syntax isn't used. Accordingly, +-- there are some differences between 'DCon' and 'Con' to keep in mind: +-- +-- * Unlike 'ForallC', where the meaning of the 'TyVarBndr's changes depending +-- on whether it's followed by 'GadtC'/'RecGadtC' or not, the meaning of the +-- 'DTyVarBndr's in a 'DCon' is always the same: it is the list of +-- universally /and/ existentially quantified type variables. Note that it is +-- not guaranteed that one set of type variables will appear before the +-- other. +-- +-- * A 'DCon' always has an explicit return type. +data DCon = DCon [DTyVarBndrSpec] DCxt Name DConFields + DType -- ^ The GADT result type + deriving (Eq, Show, Data, Generic, Lift) + +-- | A list of fields either for a standard data constructor or a record +-- data constructor. +data DConFields = DNormalC DDeclaredInfix [DBangType] + | DRecC [DVarBangType] + deriving (Eq, Show, Data, Generic, Lift) + +-- | 'True' if a constructor is declared infix. For normal ADTs, this means +-- that is was written in infix style. For example, both of the constructors +-- below are declared infix. +-- +-- @ +-- data Infix = Int `Infix` Int | Int :*: Int +-- @ +-- +-- Whereas neither of these constructors are declared infix: +-- +-- @ +-- data Prefix = Prefix Int Int | (:+:) Int Int +-- @ +-- +-- For GADTs, detecting whether a constructor is declared infix is a bit +-- trickier, as one cannot write a GADT constructor "infix-style" like one +-- can for normal ADT constructors. GHC considers a GADT constructor to be +-- declared infix if it meets the following three criteria: +-- +-- 1. Its name uses operator syntax (e.g., @(:*:)@). +-- 2. It has exactly two fields (without record syntax). +-- 3. It has a programmer-specified fixity declaration. +-- +-- For example, in the following GADT: +-- +-- @ +-- infixl 5 :**:, :&&:, :^^:, `ActuallyPrefix` +-- data InfixGADT a where +-- (:**:) :: Int -> b -> InfixGADT (Maybe b) -- Only this one is infix +-- ActuallyPrefix :: Char -> Bool -> InfixGADT Double +-- (:&&:) :: { infixGADT1 :: b, infixGADT2 :: Int } -> InfixGADT [b] +-- (:^^:) :: Int -> Int -> Int -> InfixGADT Int +-- (:!!:) :: Char -> Char -> InfixGADT Char +-- @ +-- +-- Only the @(:**:)@ constructor is declared infix. The other constructors +-- are not declared infix, because: +-- +-- * @ActuallyPrefix@ does not use operator syntax (criterion 1). +-- * @(:&&:)@ uses record syntax (criterion 2). +-- * @(:^^:)@ does not have exactly two fields (criterion 2). +-- * @(:!!:)@ does not have a programmer-specified fixity declaration (criterion 3). +type DDeclaredInfix = Bool + +-- | Corresponds to TH's @BangType@ type. +type DBangType = (Bang, DType) + +-- | Corresponds to TH's @VarBangType@ type. +type DVarBangType = (Name, Bang, DType) + +-- | Corresponds to TH's @Foreign@ type. +data DForeign = DImportF Callconv Safety String Name DType + | DExportF Callconv String Name DType + deriving (Eq, Show, Data, Generic, Lift) + +-- | Corresponds to TH's @Pragma@ type. +data DPragma = DInlineP Name Inline RuleMatch Phases + | DSpecialiseEP (Maybe [DTyVarBndr ()]) [DRuleBndr] DExp (Maybe Inline) Phases + | DSpecialiseInstP DType + | DRuleP String (Maybe [DTyVarBndrUnit]) [DRuleBndr] DExp DExp Phases + | DAnnP AnnTarget DExp + | DLineP Int String + | DCompleteP [Name] (Maybe Name) + | DOpaqueP Name + | DSCCP Name (Maybe String) + deriving (Eq, Show, Data, Generic, Lift) + +-- | Old-form specialise pragma @{ {\-\# SPECIALISE [INLINE] [phases] (var :: ty) #-} }@. +-- +-- Subsumed by the more general 'DSpecialiseEP' constructor. +pattern DSpecialiseP :: Name -> DType -> Maybe Inline -> Phases -> DPragma +pattern DSpecialiseP nm ty inl phases = DSpecialiseEP Nothing [] (DSigE (DVarE nm) ty) inl phases + +-- | Corresponds to TH's @RuleBndr@ type. +data DRuleBndr = DRuleVar Name + | DTypedRuleVar Name DType + deriving (Eq, Show, Data, Generic, Lift) + +-- | Corresponds to TH's @TySynEqn@ type (to store type family equations). +data DTySynEqn = DTySynEqn (Maybe [DTyVarBndrUnit]) DType DType + deriving (Eq, Show, Data, Generic, Lift) + +-- | Corresponds to TH's @Info@ type. +data DInfo = DTyConI DDec (Maybe [DInstanceDec]) + | DVarI Name DType (Maybe Name) + -- ^ The @Maybe Name@ stores the name of the enclosing definition + -- (datatype, for a data constructor; class, for a method), + -- if any + | DTyVarI Name DKind + | DPrimTyConI Name Int Bool + -- ^ The @Int@ is the arity; the @Bool@ is whether this tycon + -- is unlifted. + | DPatSynI Name DPatSynType + deriving (Eq, Show, Data, Generic, Lift) + +type DInstanceDec = DDec -- ^ Guaranteed to be an instance declaration + +-- | Corresponds to TH's @DerivClause@ type. +data DDerivClause = DDerivClause (Maybe DDerivStrategy) DCxt + deriving (Eq, Show, Data, Generic, Lift) + +-- | Corresponds to TH's @DerivStrategy@ type. +data DDerivStrategy = DStockStrategy -- ^ A \"standard\" derived instance + | DAnyclassStrategy -- ^ @-XDeriveAnyClass@ + | DNewtypeStrategy -- ^ @-XGeneralizedNewtypeDeriving@ + | DViaStrategy DType -- ^ @-XDerivingVia@ + deriving (Eq, Show, Data, Generic, Lift) 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,1173 +1,2451 @@ {- Language/Haskell/TH/Desugar/Core.hs (c) Richard Eisenberg 2013 -eir@cis.upenn.edu - -Desugars full Template Haskell syntax into a smaller core syntax for further -processing. The desugared types and constructors are prefixed with a D. --} - -{-# LANGUAGE TemplateHaskell, LambdaCase, CPP, DeriveDataTypeable, - DeriveGeneric, TupleSections #-} - -module Language.Haskell.TH.Desugar.Core where - -import Prelude hiding (mapM, foldl, foldr, all, elem, exp, concatMap, and) - -import Language.Haskell.TH hiding (match, clause, cxt) -import Language.Haskell.TH.Syntax hiding (lift) -import Language.Haskell.TH.ExpandSyns ( expandSyns ) - -#if __GLASGOW_HASKELL__ < 709 -import Control.Applicative -#endif -import Control.Monad hiding (mapM) -import Control.Monad.Zip -import Control.Monad.Writer hiding (mapM) -import Data.Foldable hiding (notElem) -import Data.Traversable -import Data.Data hiding (Fixity) -import GHC.Generics hiding (Fixity) - -import qualified Data.Set as S -import GHC.Exts - -import Language.Haskell.TH.Desugar.Util -import Language.Haskell.TH.Desugar.Reify - --- | Corresponds to TH's @Exp@ type. Note that @DLamE@ takes names, not patterns. -data DExp = DVarE Name - | DConE Name - | DLitE Lit - | DAppE DExp DExp - | DLamE [Name] DExp - | DCaseE DExp [DMatch] - | DLetE [DLetDec] DExp - | DSigE DExp DType - | DStaticE DExp - deriving (Show, Typeable, Data, Generic) - - --- | Corresponds to TH's @Pat@ type. -data DPat = DLitPa Lit - | DVarPa Name - | DConPa Name [DPat] - | DTildePa DPat - | DBangPa DPat - | DWildPa - deriving (Show, Typeable, Data, Generic) - --- | Corresponds to TH's @Type@ type, used to represent --- types and kinds. -data DType = DForallT [DTyVarBndr] DCxt DType - | DAppT DType DType - | DSigT DType DKind - | DVarT Name - | DConT Name - | DArrowT - | DLitT TyLit - | DWildCardT - | DStarT - deriving (Show, Typeable, Data, Generic) - --- | Kinds are types. -type DKind = DType - --- | Corresponds to TH's @Cxt@ -type DCxt = [DPred] - --- | Corresponds to TH's @Pred@ -data DPred = DAppPr DPred DType - | DSigPr DPred DKind - | DVarPr Name - | DConPr Name - | DWildCardPr - deriving (Show, Typeable, Data, Generic) - --- | Corresponds to TH's @TyVarBndr@ -data DTyVarBndr = DPlainTV Name - | DKindedTV Name DKind - deriving (Show, Typeable, Data, Generic) - --- | Corresponds to TH's @Match@ type. -data DMatch = DMatch DPat DExp - deriving (Show, Typeable, Data, Generic) - --- | Corresponds to TH's @Clause@ type. -data DClause = DClause [DPat] DExp - deriving (Show, Typeable, Data, Generic) - --- | Declarations as used in a @let@ statement. -data DLetDec = DFunD Name [DClause] - | DValD DPat DExp - | DSigD Name DType - | DInfixD Fixity Name - deriving (Show, Typeable, Data, Generic) - --- | Is it a @newtype@ or a @data@ type? -data NewOrData = Newtype - | Data - deriving (Eq, Show, Typeable, Data, Generic) - --- | Corresponds to TH's @Dec@ type. -data DDec = DLetDec DLetDec - | DDataD NewOrData DCxt Name [DTyVarBndr] [DCon] [DPred] - | DTySynD Name [DTyVarBndr] DType - | DClassD DCxt Name [DTyVarBndr] [FunDep] [DDec] - | DInstanceD (Maybe Overlap) DCxt DType [DDec] - | DForeignD DForeign - | DPragmaD DPragma - | DOpenTypeFamilyD DTypeFamilyHead - | DClosedTypeFamilyD DTypeFamilyHead [DTySynEqn] - | DDataFamilyD Name [DTyVarBndr] - | DDataInstD NewOrData DCxt Name [DType] [DCon] [DPred] - | DTySynInstD Name DTySynEqn - | DRoleAnnotD Name [Role] - | DStandaloneDerivD DCxt DType - | DDefaultSigD Name DType - deriving (Show, Typeable, Data, Generic) - -#if __GLASGOW_HASKELL__ < 711 -data Overlap = Overlappable | Overlapping | Overlaps | Incoherent - deriving (Eq, Ord, Show, Typeable, Data, Generic) -#endif - --- | Corresponds to TH's 'TypeFamilyHead' type -data DTypeFamilyHead = DTypeFamilyHead Name [DTyVarBndr] DFamilyResultSig - (Maybe InjectivityAnn) - deriving (Show, Typeable, Data, Generic) - --- | Corresponds to TH's 'FamilyResultSig' type -data DFamilyResultSig = DNoSig - | DKindSig DKind - | DTyVarSig DTyVarBndr - deriving (Show, Typeable, Data, Generic) - -#if __GLASGOW_HASKELL__ <= 710 -data InjectivityAnn = InjectivityAnn Name [Name] - deriving (Eq, Ord, Show, Typeable, Data, Generic) -#endif - --- | Corresponds to TH's @Con@ type. -data DCon = DCon [DTyVarBndr] DCxt Name DConFields - (Maybe DType) -- ^ A GADT result type, if there is one - deriving (Show, Typeable, Data, Generic) - --- | A list of fields either for a standard data constructor or a record --- data constructor. -data DConFields = DNormalC [DBangType] - | DRecC [DVarBangType] - deriving (Show, Typeable, Data, Generic) - --- | Corresponds to TH's @BangType@ type. -type DBangType = (Bang, DType) - --- | Corresponds to TH's @VarBangType@ type. -type DVarBangType = (Name, Bang, DType) - -#if __GLASGOW_HASKELL__ <= 710 --- | Corresponds to TH's definition -data SourceUnpackedness = NoSourceUnpackedness - | SourceNoUnpack - | SourceUnpack - deriving (Eq, Ord, Show, Typeable, Data, Generic) - --- | Corresponds to TH's definition -data SourceStrictness = NoSourceStrictness - | SourceLazy - | SourceStrict - deriving (Eq, Ord, Show, Typeable, Data, Generic) - --- | Corresponds to TH's definition -data Bang = Bang SourceUnpackedness SourceStrictness - deriving (Eq, Ord, Show, Typeable, Data, Generic) -#endif - --- | Corresponds to TH's @Foreign@ type. -data DForeign = DImportF Callconv Safety String Name DType - | DExportF Callconv String Name DType - deriving (Show, Typeable, Data, Generic) - --- | Corresponds to TH's @Pragma@ type. -data DPragma = DInlineP Name Inline RuleMatch Phases - | DSpecialiseP Name DType (Maybe Inline) Phases - | DSpecialiseInstP DType - | DRuleP String [DRuleBndr] DExp DExp Phases - | DAnnP AnnTarget DExp - | DLineP Int String - deriving (Show, Typeable, Data, Generic) - --- | Corresponds to TH's @RuleBndr@ type. -data DRuleBndr = DRuleVar Name - | DTypedRuleVar Name DType - deriving (Show, Typeable, Data, Generic) - --- | Corresponds to TH's @TySynEqn@ type (to store type family equations). -data DTySynEqn = DTySynEqn [DType] DType - deriving (Show, Typeable, Data, Generic) - -#if __GLASGOW_HASKELL__ < 707 --- | Same as @Role@ from TH; defined here for GHC 7.6.3 compatibility. -data Role = NominalR | RepresentationalR | PhantomR | InferR - deriving (Show, Typeable, Data, Generic) - --- | Same as @AnnTarget@ from TH; defined here for GHC 7.6.3 compatibility. -data AnnTarget = ModuleAnnotation - | TypeAnnotation Name - | ValueAnnotation Name - deriving (Show, Typeable, Data, Generic) -#endif - --- | Corresponds to TH's @Info@ type. -data DInfo = DTyConI DDec (Maybe [DInstanceDec]) - | DVarI Name DType (Maybe Name) - -- ^ The @Maybe Name@ stores the name of the enclosing definition - -- (datatype, for a data constructor; class, for a method), - -- if any - | DTyVarI Name DKind - | DPrimTyConI Name Int Bool - -- ^ The @Int@ is the arity; the @Bool@ is whether this tycon - -- is unlifted. - deriving (Show, Typeable, Data, Generic) - -type DInstanceDec = DDec -- ^ Guaranteed to be an instance declaration - --- | Desugar an expression -dsExp :: DsMonad q => Exp -> q DExp -dsExp (VarE n) = return $ DVarE n -dsExp (ConE n) = return $ DConE n -dsExp (LitE lit) = return $ DLitE lit -dsExp (AppE e1 e2) = DAppE <$> dsExp e1 <*> dsExp e2 -dsExp (InfixE Nothing op Nothing) = dsExp op -dsExp (InfixE (Just lhs) op Nothing) = DAppE <$> (dsExp op) <*> (dsExp lhs) -dsExp (InfixE Nothing op (Just rhs)) = do - lhsName <- newUniqueName "lhs" - op' <- dsExp op - rhs' <- dsExp rhs - return $ DLamE [lhsName] (foldl DAppE op' [DVarE lhsName, rhs']) -dsExp (InfixE (Just lhs) op (Just rhs)) = - DAppE <$> (DAppE <$> dsExp op <*> dsExp lhs) <*> dsExp rhs -dsExp (UInfixE _ _ _) = - fail "Cannot desugar unresolved infix operators." -dsExp (ParensE exp) = dsExp exp -dsExp (LamE pats exp) = dsLam pats =<< dsExp exp -dsExp (LamCaseE matches) = do - x <- newUniqueName "x" - matches' <- dsMatches x matches - return $ DLamE [x] (DCaseE (DVarE x) matches') -dsExp (TupE exps) = do - exps' <- mapM dsExp exps - return $ foldl DAppE (DConE $ tupleDataName (length exps)) exps' -dsExp (UnboxedTupE exps) = - foldl DAppE (DConE $ unboxedTupleDataName (length exps)) <$> mapM dsExp exps -dsExp (CondE e1 e2 e3) = - dsExp (CaseE e1 [ Match (ConP 'True []) (NormalB e2) [] - , Match (ConP 'False []) (NormalB e3) [] ]) -dsExp (MultiIfE guarded_exps) = - let failure = DAppE (DVarE 'error) (DLitE (StringL "Non-exhaustive guards in multi-way if")) in - dsGuards guarded_exps failure -dsExp (LetE decs exp) = DLetE <$> dsLetDecs decs <*> dsExp exp - -- the following special case avoids creating a new "let" when it's not - -- necessary. See #34. -dsExp (CaseE (VarE scrutinee) matches) = do - matches' <- dsMatches scrutinee matches - return $ DCaseE (DVarE scrutinee) matches' -dsExp (CaseE exp matches) = do - scrutinee <- newUniqueName "scrutinee" - exp' <- dsExp exp - matches' <- dsMatches scrutinee matches - return $ DLetE [DValD (DVarPa scrutinee) exp'] $ - DCaseE (DVarE scrutinee) matches' -dsExp (DoE stmts) = dsDoStmts stmts -dsExp (CompE stmts) = dsComp stmts -dsExp (ArithSeqE (FromR exp)) = DAppE (DVarE 'enumFrom) <$> dsExp exp -dsExp (ArithSeqE (FromThenR exp1 exp2)) = - DAppE <$> (DAppE (DVarE 'enumFromThen) <$> dsExp exp1) <*> dsExp exp2 -dsExp (ArithSeqE (FromToR exp1 exp2)) = - DAppE <$> (DAppE (DVarE 'enumFromTo) <$> dsExp exp1) <*> dsExp exp2 -dsExp (ArithSeqE (FromThenToR e1 e2 e3)) = - DAppE <$> (DAppE <$> (DAppE (DVarE 'enumFromThenTo) <$> dsExp e1) <*> - dsExp e2) <*> - dsExp e3 -dsExp (ListE exps) = go exps - where go [] = return $ DConE '[] - go (h : t) = DAppE <$> (DAppE (DConE '(:)) <$> dsExp h) <*> go t -dsExp (SigE exp ty) = DSigE <$> dsExp exp <*> dsType ty -dsExp (RecConE con_name field_exps) = do - con <- dataConNameToCon con_name - reordered <- case con of - RecC _name fields -> reorderFields fields field_exps - (repeat $ DVarE 'undefined) - _ -> impossible $ "Record syntax used with non-record constructor " - ++ (show con_name) ++ "." - return $ foldl DAppE (DConE con_name) reordered -dsExp (RecUpdE exp field_exps) = do - -- here, we need to use one of the field names to find the tycon, somewhat dodgily - first_name <- case field_exps of - ((name, _) : _) -> return name - _ -> impossible "Record update with no fields listed." - info <- reifyWithLocals first_name - applied_type <- case info of -#if __GLASGOW_HASKELL__ > 710 - VarI _name ty _m_dec -> extract_first_arg ty -#else - VarI _name ty _m_dec _fixity -> extract_first_arg ty -#endif - _ -> impossible "Record update with an invalid field name." - type_name <- extract_type_name applied_type - (_, cons) <- getDataD "This seems to be an error in GHC." type_name - let filtered_cons = filter_cons_with_names cons (map fst field_exps) - exp' <- dsExp exp - matches <- mapM con_to_dmatch filtered_cons - let all_matches - | length filtered_cons == length cons = matches - | otherwise = matches ++ [error_match] - return $ DCaseE exp' all_matches - where - extract_first_arg :: DsMonad q => Type -> q Type - extract_first_arg (AppT (AppT ArrowT arg) _) = return arg - extract_first_arg (ForallT _ _ t) = extract_first_arg t - extract_first_arg (SigT t _) = extract_first_arg t - extract_first_arg _ = impossible "Record selector not a function." - - extract_type_name :: DsMonad q => Type -> q Name - extract_type_name (AppT t1 _) = extract_type_name t1 - extract_type_name (SigT t _) = extract_type_name t - extract_type_name (ConT n) = return n - extract_type_name _ = impossible "Record selector domain not a datatype." - - filter_cons_with_names cons field_names = - filter has_names cons - where - has_names (RecC _con_name args) = - let con_field_names = map fst_of_3 args in - all (`elem` con_field_names) field_names - has_names (ForallC _ _ c) = has_names c - has_names _ = False - - con_to_dmatch :: DsMonad q => Con -> q DMatch - con_to_dmatch (RecC con_name args) = do - let con_field_names = map fst_of_3 args - field_var_names <- mapM (newUniqueName . nameBase) con_field_names - DMatch (DConPa con_name (map DVarPa field_var_names)) <$> - (foldl DAppE (DConE con_name) <$> - (reorderFields args field_exps (map DVarE field_var_names))) - con_to_dmatch (ForallC _ _ c) = con_to_dmatch c - con_to_dmatch _ = impossible "Internal error within th-desugar." - - error_match = DMatch DWildPa (DAppE (DVarE 'error) - (DLitE (StringL "Non-exhaustive patterns in record update"))) - - fst_of_3 (x, _, _) = x -#if __GLASGOW_HASKELL__ >= 709 -dsExp (StaticE exp) = DStaticE <$> dsExp exp -#endif -#if __GLASGOW_HASKELL__ > 710 -dsExp (UnboundVarE n) = return (DVarE n) -#endif - --- | Desugar a lambda expression, where the body has already been desugared -dsLam :: DsMonad q => [Pat] -> DExp -> q DExp -dsLam pats exp - | Just names <- mapM stripVarP_maybe pats - = return $ DLamE names exp - | otherwise - = do arg_names <- replicateM (length pats) (newUniqueName "arg") - let scrutinee = mkTupleDExp (map DVarE arg_names) - (pats', exp') <- dsPatsOverExp pats exp - let match = DMatch (mkTupleDPat pats') exp' - return $ DLamE arg_names (DCaseE scrutinee [match]) - --- | Desugar a list of matches for a @case@ statement -dsMatches :: DsMonad q - => Name -- ^ Name of the scrutinee, which must be a bare var - -> [Match] -- ^ Matches of the @case@ statement - -> q [DMatch] -dsMatches scr = go - where - go :: DsMonad q => [Match] -> q [DMatch] - go [] = return [] - go (Match pat body where_decs : rest) = do - rest' <- go rest - let failure = DCaseE (DVarE scr) rest' -- this might be an empty case. - exp' <- dsBody body where_decs failure - (pat', exp'') <- dsPatOverExp pat exp' - uni_pattern <- isUniversalPattern pat' -- incomplete attempt at #6 - if uni_pattern - then return [DMatch pat' exp''] - else return (DMatch pat' exp'' : rest') - --- | Desugar a @Body@ -dsBody :: DsMonad q - => Body -- ^ body to desugar - -> [Dec] -- ^ "where" declarations - -> DExp -- ^ what to do if the guards don't match - -> q DExp -dsBody (NormalB exp) decs _ = - maybeDLetE <$> dsLetDecs decs <*> dsExp exp -dsBody (GuardedB guarded_exps) decs failure = - maybeDLetE <$> dsLetDecs decs <*> dsGuards guarded_exps failure - --- | If decs is non-empty, delcare them in a let: -maybeDLetE :: [DLetDec] -> DExp -> DExp -maybeDLetE [] exp = exp -maybeDLetE decs exp = DLetE decs exp - --- | If matches is non-empty, make a case statement; otherwise make an error statement -maybeDCaseE :: String -> DExp -> [DMatch] -> DExp -maybeDCaseE err _ [] = DAppE (DVarE 'error) (DLitE (StringL err)) -maybeDCaseE _ scrut matches = DCaseE scrut matches - --- | Desugar guarded expressions -dsGuards :: DsMonad q - => [(Guard, Exp)] -- ^ Guarded expressions - -> DExp -- ^ What to do if none of the guards match - -> q DExp -dsGuards [] thing_inside = return thing_inside -dsGuards ((NormalG gd, exp) : rest) thing_inside = - dsGuards ((PatG [NoBindS gd], exp) : rest) thing_inside -dsGuards ((PatG stmts, exp) : rest) thing_inside = do - success <- dsExp exp - failure <- dsGuards rest thing_inside - dsGuardStmts stmts success failure - --- | Desugar the @Stmt@s in a guard -dsGuardStmts :: DsMonad q - => [Stmt] -- ^ The @Stmt@s to desugar - -> DExp -- ^ What to do if the @Stmt@s yield success - -> DExp -- ^ What to do if the @Stmt@s yield failure - -> q DExp -dsGuardStmts [] success _failure = return success -dsGuardStmts (BindS pat exp : rest) success failure = do - success' <- dsGuardStmts rest success failure - (pat', success'') <- dsPatOverExp pat success' - exp' <- dsExp exp - return $ DCaseE exp' [DMatch pat' success'', DMatch DWildPa failure] -dsGuardStmts (LetS decs : rest) success failure = do - decs' <- dsLetDecs decs - success' <- dsGuardStmts rest success failure - return $ DLetE decs' success' - -- special-case a final pattern containing "otherwise" or "True" - -- note that GHC does this special-casing, too, in DsGRHSs.isTrueLHsExpr -dsGuardStmts [NoBindS exp] success _failure - | VarE name <- exp - , name == 'otherwise - = return success - - | ConE name <- exp - , name == 'True - = return success -dsGuardStmts (NoBindS exp : rest) success failure = do - exp' <- dsExp exp - success' <- dsGuardStmts rest success failure - return $ DCaseE exp' [ DMatch (DConPa 'True []) success' - , DMatch (DConPa 'False []) failure ] -dsGuardStmts (ParS _ : _) _ _ = impossible "Parallel comprehension in a pattern guard." - --- | Desugar the @Stmt@s in a @do@ expression -dsDoStmts :: DsMonad q => [Stmt] -> q DExp -dsDoStmts [] = impossible "do-expression ended with something other than bare statement." -dsDoStmts [NoBindS exp] = dsExp exp -dsDoStmts (BindS pat exp : rest) = do - exp' <- dsExp exp - rest' <- dsDoStmts rest - DAppE (DAppE (DVarE '(>>=)) exp') <$> dsLam [pat] rest' -dsDoStmts (LetS decs : rest) = DLetE <$> dsLetDecs decs <*> dsDoStmts rest -dsDoStmts (NoBindS exp : rest) = do - exp' <- dsExp exp - rest' <- dsDoStmts rest - return $ DAppE (DAppE (DVarE '(>>)) exp') rest' -dsDoStmts (ParS _ : _) = impossible "Parallel comprehension in a do-statement." - --- | Desugar the @Stmt@s in a list or monad comprehension -dsComp :: DsMonad q => [Stmt] -> q DExp -dsComp [] = impossible "List/monad comprehension ended with something other than a bare statement." -dsComp [NoBindS exp] = DAppE (DVarE 'return) <$> dsExp exp -dsComp (BindS pat exp : rest) = do - exp' <- dsExp exp - rest' <- dsComp rest - DAppE (DAppE (DVarE '(>>=)) exp') <$> dsLam [pat] rest' -dsComp (LetS decs : rest) = DLetE <$> dsLetDecs decs <*> dsComp rest -dsComp (NoBindS exp : rest) = do - exp' <- dsExp exp - rest' <- dsComp rest - return $ DAppE (DAppE (DVarE '(>>)) (DAppE (DVarE 'guard) exp')) rest' -dsComp (ParS stmtss : rest) = do - (pat, exp) <- dsParComp stmtss - rest' <- dsComp rest - DAppE (DAppE (DVarE '(>>=)) exp) <$> dsLam [pat] rest' - --- | Desugar the contents of a parallel comprehension. --- Returns a @Pat@ containing a tuple of all bound variables and an expression --- to produce the values for those variables -dsParComp :: DsMonad q => [[Stmt]] -> q (Pat, DExp) -dsParComp [] = impossible "Empty list of parallel comprehension statements." -dsParComp [r] = do - let rv = foldMap extractBoundNamesStmt r - dsR <- dsComp (r ++ [mk_tuple_stmt rv]) - return (mk_tuple_pat rv, dsR) -dsParComp (q : rest) = do - let qv = foldMap extractBoundNamesStmt q - (rest_pat, rest_exp) <- dsParComp rest - dsQ <- dsComp (q ++ [mk_tuple_stmt qv]) - let zipped = DAppE (DAppE (DVarE 'mzip) dsQ) rest_exp - return (ConP (tupleDataName 2) [mk_tuple_pat qv, rest_pat], zipped) - --- helper function for dsParComp -mk_tuple_stmt :: S.Set Name -> Stmt -mk_tuple_stmt name_set = - NoBindS (mkTupleExp (S.foldr ((:) . VarE) [] name_set)) - --- helper function for dsParComp -mk_tuple_pat :: S.Set Name -> Pat -mk_tuple_pat name_set = - mkTuplePat (S.foldr ((:) . VarP) [] name_set) - --- | Desugar a pattern, along with processing a (desugared) expression that --- is the entire scope of the variables bound in the pattern. -dsPatOverExp :: DsMonad q => Pat -> DExp -> q (DPat, DExp) -dsPatOverExp pat exp = do - (pat', vars) <- runWriterT $ dsPat pat - let name_decs = uncurry (zipWith (DValD . DVarPa)) $ unzip vars - return (pat', maybeDLetE name_decs exp) - --- | Desugar multiple patterns. Like 'dsPatOverExp'. -dsPatsOverExp :: DsMonad q => [Pat] -> DExp -> q ([DPat], DExp) -dsPatsOverExp pats exp = do - (pats', vars) <- runWriterT $ mapM dsPat pats - let name_decs = uncurry (zipWith (DValD . DVarPa)) $ unzip vars - return (pats', maybeDLetE name_decs exp) - --- | Desugar a pattern, returning a list of (Name, DExp) pairs of extra --- variables that must be bound within the scope of the pattern -dsPatX :: DsMonad q => Pat -> q (DPat, [(Name, DExp)]) -dsPatX = runWriterT . dsPat - --- | Desugaring a pattern also returns the list of variables bound in as-patterns --- and the values they should be bound to. This variables must be brought into --- scope in the "body" of the pattern. -type PatM q = WriterT [(Name, DExp)] q - --- | Desugar a pattern. -dsPat :: DsMonad q => Pat -> PatM q DPat -dsPat (LitP lit) = return $ DLitPa lit -dsPat (VarP n) = return $ DVarPa n -dsPat (TupP pats) = DConPa (tupleDataName (length pats)) <$> mapM dsPat pats -dsPat (UnboxedTupP pats) = DConPa (unboxedTupleDataName (length pats)) <$> - mapM dsPat pats -dsPat (ConP name pats) = DConPa name <$> mapM dsPat pats -dsPat (InfixP p1 name p2) = DConPa name <$> mapM dsPat [p1, p2] -dsPat (UInfixP _ _ _) = - fail "Cannot desugar unresolved infix operators." -dsPat (ParensP pat) = dsPat pat -dsPat (TildeP pat) = DTildePa <$> dsPat pat -dsPat (BangP pat) = DBangPa <$> dsPat pat -dsPat (AsP name pat) = do - pat' <- dsPat pat - pat'' <- lift $ removeWilds pat' - tell [(name, dPatToDExp pat'')] - return pat'' -dsPat WildP = return DWildPa -dsPat (RecP con_name field_pats) = do - con <- lift $ dataConNameToCon con_name - reordered <- case con of - RecC _name fields -> reorderFieldsPat fields field_pats - _ -> lift $ impossible $ "Record syntax used with non-record constructor " - ++ (show con_name) ++ "." - return $ DConPa con_name reordered -dsPat (ListP pats) = go pats - where go [] = return $ DConPa '[] [] - go (h : t) = do - h' <- dsPat h - t' <- go t - return $ DConPa '(:) [h', t'] -dsPat (SigP _ _) = - lift $ impossible - ("At last check (Aug 2013), type patterns in signatures are not\n" ++ - "supported in GHC. They are not supported in th-desugar either.") -dsPat (ViewP _ _) = - fail "View patterns are not supported in th-desugar. Use pattern guards instead." - --- | Convert a 'DPat' to a 'DExp'. Fails on 'DWildP'. -dPatToDExp :: DPat -> DExp -dPatToDExp (DLitPa lit) = DLitE lit -dPatToDExp (DVarPa name) = DVarE name -dPatToDExp (DConPa name pats) = foldl DAppE (DConE name) (map dPatToDExp pats) -dPatToDExp (DTildePa pat) = dPatToDExp pat -dPatToDExp (DBangPa pat) = dPatToDExp pat -dPatToDExp DWildPa = error "Internal error in th-desugar: wildcard in rhs of as-pattern" - --- | Remove all wildcards from a pattern, replacing any wildcard with a fresh --- variable -removeWilds :: DsMonad q => DPat -> q DPat -removeWilds p@(DLitPa _) = return p -removeWilds p@(DVarPa _) = return p -removeWilds (DConPa con_name pats) = DConPa con_name <$> mapM removeWilds pats -removeWilds (DTildePa pat) = DTildePa <$> removeWilds pat -removeWilds (DBangPa pat) = DBangPa <$> removeWilds pat -removeWilds DWildPa = DVarPa <$> newUniqueName "wild" - --- | Desugar @Info@ -dsInfo :: DsMonad q => Info -> q DInfo -dsInfo (ClassI dec instances) = do - [ddec] <- dsDec dec - dinstances <- dsDecs instances - return $ DTyConI ddec (Just dinstances) -#if __GLASGOW_HASKELL__ > 710 -dsInfo (ClassOpI name ty parent) = -#else -dsInfo (ClassOpI name ty parent _fixity) = -#endif - DVarI name <$> dsType ty <*> pure (Just parent) -dsInfo (TyConI dec) = do - [ddec] <- dsDec dec - return $ DTyConI ddec Nothing -dsInfo (FamilyI dec instances) = do - [ddec] <- dsDec dec - dinstances <- dsDecs instances - (ddec', num_args) <- fixBug8884ForFamilies ddec - let dinstances' = map (fixBug8884ForInstances num_args) dinstances - return $ DTyConI ddec' (Just dinstances') -dsInfo (PrimTyConI name arity unlifted) = - return $ DPrimTyConI name arity unlifted -#if __GLASGOW_HASKELL__ > 710 -dsInfo (DataConI name ty parent) = - DVarI name <$> dsType ty <*> pure (Just parent) -dsInfo (VarI name ty Nothing) = - DVarI name <$> dsType ty <*> pure Nothing -dsInfo (VarI name _ (Just _)) = - impossible $ "Declaration supplied with variable: " ++ show name -#else -dsInfo (DataConI name ty parent _fixity) = - DVarI name <$> dsType ty <*> pure (Just parent) -dsInfo (VarI name ty Nothing _fixity) = - DVarI name <$> dsType ty <*> pure Nothing -dsInfo (VarI name _ (Just _) _) = - impossible $ "Declaration supplied with variable: " ++ show name -#endif -dsInfo (TyVarI name ty) = DTyVarI name <$> dsType ty - -fixBug8884ForFamilies :: DsMonad q => DDec -> q (DDec, Int) -#if __GLASGOW_HASKELL__ < 708 -fixBug8884ForFamilies (DOpenTypeFamilyD (DTypeFamilyHead name tvbs frs ann)) = do - let num_args = length tvbs - frs' <- remove_arrows num_args frs - return (DOpenTypeFamilyD (DTypeFamilyHead name tvbs frs' ann),num_args) -fixBug8884ForFamilies (DClosedTypeFamilyD (DTypeFamilyHead name tvbs frs ann) eqns) = do - let num_args = length tvbs - eqns' = map (fixBug8884ForEqn num_args) eqns - frs' <- remove_arrows num_args frs - return (DClosedTypeFamilyD (DTypeFamilyHead name tvbs frs' ann) eqns', num_args) -fixBug8884ForFamilies dec@(DDataFamilyD _ _) - = return (dec, 0) -- the num_args is ignored for data families -fixBug8884ForFamilies dec = - impossible $ "Reifying yielded a FamilyI with a non-family Dec: " ++ show dec - -remove_arrows :: DsMonad q => Int -> DFamilyResultSig -> q DFamilyResultSig -remove_arrows n (DKindSig k) = DKindSig <$> remove_arrows_kind n k -remove_arrows n (DTyVarSig (DKindedTV nm k)) = - DTyVarSig <$> (DKindedTV nm <$> remove_arrows_kind n k) -remove_arrows _ frs = return frs - -remove_arrows_kind :: DsMonad q => Int -> DKind -> q DKind -remove_arrows_kind 0 k = return k -remove_arrows_kind n (DAppT (DAppT DArrowT _) k) = remove_arrows_kind (n-1) k -remove_arrows_kind _ _ = - impossible "Internal error: Fix for bug 8884 ran out of arrows." - -#else -fixBug8884ForFamilies dec = return (dec, 0) -- return value ignored -#endif - -fixBug8884ForInstances :: Int -> DDec -> DDec -fixBug8884ForInstances num_args (DTySynInstD name eqn) = - DTySynInstD name (fixBug8884ForEqn num_args eqn) -fixBug8884ForInstances _ dec = dec - -fixBug8884ForEqn :: Int -> DTySynEqn -> DTySynEqn -#if __GLASGOW_HASKELL__ < 708 -fixBug8884ForEqn num_args (DTySynEqn lhs rhs) = - let lhs' = drop (length lhs - num_args) lhs in - DTySynEqn lhs' rhs -#else -fixBug8884ForEqn _ = id -#endif - --- | Desugar arbitrary @Dec@s -dsDecs :: DsMonad q => [Dec] -> q [DDec] -dsDecs = concatMapM dsDec - --- | Desugar a single @Dec@, perhaps producing multiple 'DDec's -dsDec :: DsMonad q => Dec -> q [DDec] -dsDec d@(FunD {}) = (fmap . map) DLetDec $ dsLetDec d -dsDec d@(ValD {}) = (fmap . map) DLetDec $ dsLetDec d -#if __GLASGOW_HASKELL__ > 710 -dsDec (DataD cxt n tvbs mk cons derivings) = do - extra_tvbs <- mkExtraTvbs tvbs mk - (:[]) <$> (DDataD Data <$> dsCxt cxt <*> pure n - <*> ((++ extra_tvbs) <$> mapM dsTvb tvbs) - <*> concatMapM dsCon cons - <*> dsCxt derivings) -dsDec (NewtypeD cxt n tvbs mk con derivings) = do - extra_tvbs <- mkExtraTvbs tvbs mk - (:[]) <$> (DDataD Newtype <$> dsCxt cxt <*> pure n - <*> ((++ extra_tvbs) <$> mapM dsTvb tvbs) - <*> dsCon con <*> dsCxt derivings) -#else -dsDec (DataD cxt n tvbs cons derivings) = - (:[]) <$> (DDataD Data <$> dsCxt cxt <*> pure n - <*> mapM dsTvb tvbs <*> concatMapM dsCon cons - <*> pure (map DConPr derivings)) -dsDec (NewtypeD cxt n tvbs con derivings) = - (:[]) <$> (DDataD Newtype <$> dsCxt cxt <*> pure n - <*> mapM dsTvb tvbs <*> dsCon con - <*> pure (map DConPr derivings)) -#endif -dsDec (TySynD n tvbs ty) = - (:[]) <$> (DTySynD n <$> mapM dsTvb tvbs <*> dsType ty) -dsDec (ClassD cxt n tvbs fds decs) = - (:[]) <$> (DClassD <$> dsCxt cxt <*> pure n <*> mapM dsTvb tvbs - <*> pure fds <*> dsDecs decs) -#if __GLASGOW_HASKELL__ >= 711 -dsDec (InstanceD over cxt ty decs) = - (:[]) <$> (DInstanceD <$> pure over <*> dsCxt cxt <*> dsType ty <*> dsDecs decs) -#else -dsDec (InstanceD cxt ty decs) = - (:[]) <$> (DInstanceD <$> pure Nothing <*> dsCxt cxt <*> dsType ty <*> dsDecs decs) -#endif -dsDec d@(SigD {}) = (fmap . map) DLetDec $ dsLetDec d -dsDec (ForeignD f) = (:[]) <$> (DForeignD <$> dsForeign f) -dsDec d@(InfixD {}) = (fmap . map) DLetDec $ dsLetDec d -dsDec (PragmaD prag) = (:[]) <$> (DPragmaD <$> dsPragma prag) -#if __GLASGOW_HASKELL__ > 710 -dsDec (OpenTypeFamilyD tfHead) = - (:[]) <$> (DOpenTypeFamilyD <$> dsTypeFamilyHead tfHead) -dsDec (DataFamilyD n tvbs m_k) = do - extra_tvbs <- mkExtraTvbs tvbs m_k - (:[]) <$> (DDataFamilyD n <$> ((++ extra_tvbs) <$> mapM dsTvb tvbs)) -#else -dsDec (FamilyD TypeFam n tvbs m_k) = do - (:[]) <$> (DOpenTypeFamilyD <$> dsTypeFamilyHead n tvbs m_k) -dsDec (FamilyD DataFam n tvbs m_k) = do - extra_tvbs <- mkExtraTvbs tvbs m_k - (:[]) <$> (DDataFamilyD n <$> ((++ extra_tvbs) <$> mapM dsTvb tvbs)) -#endif -#if __GLASGOW_HASKELL__ > 710 -dsDec (DataInstD cxt n tys mk cons derivings) = do - extra_tvbs <- map dTyVarBndrToDType <$> mkExtraTvbs [] mk - (:[]) <$> (DDataInstD Data <$> dsCxt cxt <*> pure n - <*> ((++ extra_tvbs) <$> mapM dsType tys) - <*> concatMapM dsCon cons - <*> dsCxt derivings) -dsDec (NewtypeInstD cxt n tys mk con derivings) = do - extra_tvbs <- map dTyVarBndrToDType <$> mkExtraTvbs [] mk - (:[]) <$> (DDataInstD Newtype <$> dsCxt cxt <*> pure n - <*> ((++ extra_tvbs) <$> mapM dsType tys) - <*> dsCon con - <*> dsCxt derivings) -#else -dsDec (DataInstD cxt n tys cons derivings) = do - (:[]) <$> (DDataInstD Data <$> dsCxt cxt <*> pure n <*> mapM dsType tys - <*> concatMapM dsCon cons - <*> pure (map DConPr derivings)) -dsDec (NewtypeInstD cxt n tys con derivings) = do - (:[]) <$> (DDataInstD Newtype <$> dsCxt cxt <*> pure n <*> mapM dsType tys - <*> dsCon con <*> pure (map DConPr derivings)) -#endif -#if __GLASGOW_HASKELL__ < 707 -dsDec (TySynInstD n lhs rhs) = (:[]) <$> (DTySynInstD n <$> - (DTySynEqn <$> mapM dsType lhs - <*> dsType rhs)) -#else -dsDec (TySynInstD n eqn) = (:[]) <$> (DTySynInstD n <$> dsTySynEqn eqn) -#if __GLASGOW_HASKELL__ > 710 -dsDec (ClosedTypeFamilyD tfHead eqns) = - (:[]) <$> (DClosedTypeFamilyD <$> dsTypeFamilyHead tfHead - <*> mapM dsTySynEqn eqns) -#else -dsDec (ClosedTypeFamilyD n tvbs m_k eqns) = do - (:[]) <$> (DClosedTypeFamilyD <$> dsTypeFamilyHead n tvbs m_k - <*> mapM dsTySynEqn eqns) -#endif -dsDec (RoleAnnotD n roles) = return [DRoleAnnotD n roles] -#endif -#if __GLASGOW_HASKELL__ >= 709 -dsDec (StandaloneDerivD cxt ty) = (:[]) <$> (DStandaloneDerivD <$> dsCxt cxt - <*> dsType ty) -dsDec (DefaultSigD n ty) = (:[]) <$> (DDefaultSigD n <$> dsType ty) -#endif - -mkExtraTvbs :: DsMonad q => [TyVarBndr] -> Maybe Kind -> q [DTyVarBndr] -mkExtraTvbs _ Nothing = return [] -mkExtraTvbs orig_tvbs (Just k) = do - k' <- runQ (expandSyns k) -- just in case - dk <- dsType k' - let args = split_funs [] dk - -- christiaanb: I have no idea how GHC normally picks fresh - -- tyvars, this looks like something GHC might do. Though probably in a - -- nicer/safer way. - -- - -- RAE: It's actually not terribly far off from what GHC does. This is - -- terrible. But I don't see another way to do this. - -- - -- All of this is needed so that "dec test 9" passes. - orig_names = map (nameBase . tvbName) orig_tvbs - all_names = -#if __GLASGOW_HASKELL__ <= 708 - map ('$':) $ -#endif - take (length args + length orig_tvbs) - (map (:[]) ['a' .. 'z'] ++ - concatMap (zipWith (:) ['a' .. 'z'] . repeat . show) - [(0::Int)..]) - new_names = filter (`notElem` orig_names) all_names - names <- zipWithM (\n _ -> qNewName n) new_names args - return (zipWith DKindedTV names args) - where - split_funs args (DAppT (DAppT DArrowT arg) res) = split_funs (arg:args) res - split_funs args _other = reverse args - -#if __GLASGOW_HASKELL__ > 710 --- | Desugar a @FamilyResultSig@ -dsFamilyResultSig :: DsMonad q => FamilyResultSig -> q DFamilyResultSig -dsFamilyResultSig NoSig = return DNoSig -dsFamilyResultSig (KindSig k) = DKindSig <$> dsType k -dsFamilyResultSig (TyVarSig tvb) = DTyVarSig <$> dsTvb tvb - --- | Desugar a @TypeFamilyHead@ -dsTypeFamilyHead :: DsMonad q => TypeFamilyHead -> q DTypeFamilyHead -dsTypeFamilyHead (TypeFamilyHead n tvbs result inj) - = DTypeFamilyHead n <$> mapM dsTvb tvbs - <*> dsFamilyResultSig result - <*> pure inj -#else --- | Desugar bits and pieces into a 'DTypeFamilyHead' -dsTypeFamilyHead :: DsMonad q - => Name -> [TyVarBndr] -> Maybe Kind -> q DTypeFamilyHead -dsTypeFamilyHead n tvbs m_kind = do - result_sig <- case m_kind of - Nothing -> return DNoSig - Just k -> DKindSig <$> dsType k - DTypeFamilyHead n <$> mapM dsTvb tvbs - <*> pure result_sig - <*> pure Nothing -#endif - --- | Desugar @Dec@s that can appear in a let expression -dsLetDecs :: DsMonad q => [Dec] -> q [DLetDec] -dsLetDecs = concatMapM dsLetDec - --- | Desugar a single @Dec@, perhaps producing multiple 'DLetDec's -dsLetDec :: DsMonad q => Dec -> q [DLetDec] -dsLetDec (FunD name clauses) = do - clauses' <- dsClauses name clauses - return [DFunD name clauses'] -dsLetDec (ValD pat body where_decs) = do - (pat', vars) <- dsPatX pat - body' <- dsBody body where_decs error_exp - let extras = uncurry (zipWith (DValD . DVarPa)) $ unzip vars - return $ DValD pat' body' : extras - where - error_exp = DAppE (DVarE 'error) (DLitE - (StringL $ "Non-exhaustive patterns for " ++ pprint pat)) -dsLetDec (SigD name ty) = do - ty' <- dsType ty - return [DSigD name ty'] -dsLetDec (InfixD fixity name) = return [DInfixD fixity name] -dsLetDec _dec = impossible "Illegal declaration in let expression." - --- | Desugar a single @Con@. -dsCon :: DsMonad q - => Con -> q [DCon] -dsCon (NormalC n stys) = - (:[]) <$> (DCon [] [] n <$> (DNormalC <$> mapM dsBangType stys) <*> pure Nothing) -dsCon (RecC n vstys) = - (:[]) <$> (DCon [] [] n <$> (DRecC <$> mapM dsVarBangType vstys) <*> pure Nothing) -dsCon (InfixC sty1 n sty2) = do - dty1 <- dsBangType sty1 - dty2 <- dsBangType sty2 - return $ [DCon [] [] n (DNormalC [dty1, dty2]) Nothing] -dsCon (ForallC tvbs cxt con) = do - dtvbs <- mapM dsTvb tvbs - dcxt <- dsCxt cxt - dcons <- dsCon con - return $ flip map dcons $ \(DCon dtvbs' dcxt' n fields m_kind) -> - DCon (dtvbs ++ dtvbs') (dcxt ++ dcxt') n fields m_kind -#if __GLASGOW_HASKELL__ > 710 -dsCon (GadtC nms btys rty) = do - dbtys <- mapM dsBangType btys - drty <- dsType rty - return $ flip map nms $ \nm -> - DCon [] [] nm (DNormalC dbtys) (Just drty) -dsCon (RecGadtC nms vbtys rty) = do - dvbtys <- mapM dsVarBangType vbtys - drty <- dsType rty - return $ flip map nms $ \nm -> - DCon [] [] nm (DRecC dvbtys) (Just drty) -#endif - -#if __GLASGOW_HASKELL__ > 710 --- | Desugar a @BangType@ (or a @StrictType@, if you're old-fashioned) -dsBangType :: DsMonad q => BangType -> q DBangType -dsBangType (b, ty) = (b, ) <$> dsType ty - --- | Desugar a @VarBangType@ (or a @VarStrictType@, if you're old-fashioned) -dsVarBangType :: DsMonad q => VarBangType -> q DVarBangType -dsVarBangType (n, b, ty) = (n, b, ) <$> dsType ty -#else --- | Desugar a @BangType@ (or a @StrictType@, if you're old-fashioned) -dsBangType :: DsMonad q => StrictType -> q DBangType -dsBangType (b, ty) = (strictToBang b, ) <$> dsType ty - --- | Desugar a @VarBangType@ (or a @VarStrictType@, if you're old-fashioned) -dsVarBangType :: DsMonad q => VarStrictType -> q DVarBangType -dsVarBangType (n, b, ty) = (n, strictToBang b, ) <$> dsType ty -#endif - --- | Desugar a @Foreign@. -dsForeign :: DsMonad q => Foreign -> q DForeign -dsForeign (ImportF cc safety str n ty) = DImportF cc safety str n <$> dsType ty -dsForeign (ExportF cc str n ty) = DExportF cc str n <$> dsType ty - --- | Desugar a @Pragma@. -dsPragma :: DsMonad q => Pragma -> q DPragma -dsPragma (InlineP n inl rm phases) = return $ DInlineP n inl rm phases -dsPragma (SpecialiseP n ty m_inl phases) = DSpecialiseP n <$> dsType ty - <*> pure m_inl - <*> pure phases -dsPragma (SpecialiseInstP ty) = DSpecialiseInstP <$> dsType ty -dsPragma (RuleP str rbs lhs rhs phases) = DRuleP str <$> mapM dsRuleBndr rbs - <*> dsExp lhs - <*> dsExp rhs - <*> pure phases -#if __GLASGOW_HASKELL__ >= 707 -dsPragma (AnnP target exp) = DAnnP target <$> dsExp exp -#endif -#if __GLASGOW_HASKELL__ >= 709 -dsPragma (LineP n str) = return $ DLineP n str -#endif - --- | Desugar a @RuleBndr@. -dsRuleBndr :: DsMonad q => RuleBndr -> q DRuleBndr -dsRuleBndr (RuleVar n) = return $ DRuleVar n -dsRuleBndr (TypedRuleVar n ty) = DTypedRuleVar n <$> dsType ty - -#if __GLASGOW_HASKELL__ >= 707 --- | Desugar a @TySynEqn@. (Available only with GHC 7.8+) -dsTySynEqn :: DsMonad q => TySynEqn -> q DTySynEqn -dsTySynEqn (TySynEqn lhs rhs) = DTySynEqn <$> mapM dsType lhs <*> dsType rhs -#endif - --- | Desugar clauses to a function definition -dsClauses :: DsMonad q - => Name -- ^ Name of the function - -> [Clause] -- ^ Clauses to desugar - -> q [DClause] -dsClauses _ [] = return [] -dsClauses n (Clause pats (NormalB exp) where_decs : rest) = do - -- this case is necessary to maintain the roundtrip property. - rest' <- dsClauses n rest - exp' <- dsExp exp - where_decs' <- dsLetDecs where_decs - let exp_with_wheres = maybeDLetE where_decs' exp' - (pats', exp'') <- dsPatsOverExp pats exp_with_wheres - return $ DClause pats' exp'' : rest' -dsClauses n clauses@(Clause outer_pats _ _ : _) = do - arg_names <- replicateM (length outer_pats) (newUniqueName "arg") - let scrutinee = mkTupleDExp (map DVarE arg_names) - clause <- DClause (map DVarPa arg_names) <$> - (DCaseE scrutinee <$> foldrM (clause_to_dmatch scrutinee) [] clauses) - return [clause] - where - clause_to_dmatch :: DsMonad q => DExp -> Clause -> [DMatch] -> q [DMatch] - clause_to_dmatch scrutinee (Clause pats body where_decs) failure_matches = do - let failure_exp = maybeDCaseE ("Non-exhaustive patterns in " ++ (show n)) - scrutinee failure_matches - exp <- dsBody body where_decs failure_exp - (pats', exp') <- dsPatsOverExp pats exp - uni_pats <- fmap getAll $ concatMapM (fmap All . isUniversalPattern) pats' - let match = DMatch (mkTupleDPat pats') exp' - if uni_pats - then return [match] - else return (match : failure_matches) - --- | Desugar a type -dsType :: DsMonad q => Type -> q DType -dsType (ForallT tvbs preds ty) = DForallT <$> mapM dsTvb tvbs <*> dsCxt preds <*> dsType ty -dsType (AppT t1 t2) = DAppT <$> dsType t1 <*> dsType t2 -dsType (SigT ty ki) = DSigT <$> dsType ty <*> dsType ki -dsType (VarT name) = return $ DVarT name -dsType (ConT name) = return $ DConT name - -- the only difference between ConT and PromotedT is the name lookup. Here, we assume - -- that the TH quote mechanism figured out the right name. Note that lookupDataName name - -- does not necessarily work, because `name` has its original module attached, which - -- may not be in scope. -dsType (PromotedT name) = return $ DConT name -dsType (TupleT n) = return $ DConT (tupleTypeName n) -dsType (UnboxedTupleT n) = return $ DConT (unboxedTupleTypeName n) -dsType ArrowT = return DArrowT -dsType ListT = return $ DConT ''[] -dsType (PromotedTupleT n) = return $ DConT (tupleDataName n) -dsType PromotedNilT = return $ DConT '[] -dsType PromotedConsT = return $ DConT '(:) -dsType StarT = return DStarT -dsType ConstraintT = return $ DConT ''Constraint -dsType (LitT lit) = return $ DLitT lit -#if __GLASGOW_HASKELL__ >= 709 -dsType EqualityT = return $ DConT ''(~) -#endif -#if __GLASGOW_HASKELL__ > 710 -dsType (InfixT t1 n t2) = DAppT <$> (DAppT (DConT n) <$> dsType t1) <*> dsType t2 -dsType (UInfixT _ _ _) = fail "Cannot desugar unresolved infix operators." -dsType (ParensT t) = dsType t -dsType WildCardT = return DWildCardT -#endif - --- | Desugar a @TyVarBndr@ -dsTvb :: DsMonad q => TyVarBndr -> q DTyVarBndr -dsTvb (PlainTV n) = return $ DPlainTV n -dsTvb (KindedTV n k) = DKindedTV n <$> dsType k - --- | Desugar a @Cxt@ -dsCxt :: DsMonad q => Cxt -> q DCxt -dsCxt = concatMapM dsPred - --- | Desugar a @Pred@, flattening any internal tuples -dsPred :: DsMonad q => Pred -> q DCxt -#if __GLASGOW_HASKELL__ < 709 -dsPred (ClassP n tys) = do - ts' <- mapM dsType tys - return [foldl DAppPr (DConPr n) ts'] -dsPred (EqualP t1 t2) = do - ts' <- mapM dsType [t1, t2] - return [foldl DAppPr (DConPr ''(~)) ts'] -#else -dsPred t - | Just ts <- splitTuple_maybe t - = concatMapM dsPred ts -dsPred t@(ForallT _ _ _) = impossible $ "Forall seen in constraint: " ++ show t -dsPred (AppT t1 t2) = do - [p1] <- dsPred t1 -- tuples can't be applied! - (:[]) <$> DAppPr p1 <$> dsType t2 -dsPred (SigT ty ki) = do - preds <- dsPred ty - case preds of - [p] -> (:[]) <$> DSigPr p <$> dsType ki - other -> return other -- just drop the kind signature on a tuple. -dsPred (VarT n) = return [DVarPr n] -dsPred (ConT n) = return [DConPr n] -dsPred t@(PromotedT _) = - impossible $ "Promoted type seen as head of constraint: " ++ show t -dsPred (TupleT 0) = return [DConPr (tupleTypeName 0)] -dsPred (TupleT _) = - impossible "Internal error in th-desugar in detecting tuple constraints." -dsPred t@(UnboxedTupleT _) = - impossible $ "Unboxed tuple seen as head of constraint: " ++ show t -dsPred ArrowT = impossible "Arrow seen as head of constraint." -dsPred ListT = impossible "List seen as head of constraint." -dsPred (PromotedTupleT _) = - impossible "Promoted tuple seen as head of constraint." -dsPred PromotedNilT = impossible "Promoted nil seen as head of constraint." -dsPred PromotedConsT = impossible "Promoted cons seen as head of constraint." -dsPred StarT = impossible "* seen as head of constraint." -dsPred ConstraintT = - impossible "The kind `Constraint' seen as head of constraint." -dsPred t@(LitT _) = - impossible $ "Type literal seen as head of constraint: " ++ show t -dsPred EqualityT = return [DConPr ''(~)] -#if __GLASGOW_HASKELL__ > 710 -dsPred (InfixT t1 n t2) = (:[]) <$> (DAppPr <$> (DAppPr (DConPr n) <$> dsType t1) <*> dsType t2) -dsPred (UInfixT _ _ _) = fail "Cannot desugar unresolved infix operators." -dsPred (ParensT t) = dsPred t -dsPred WildCardT = return [DWildCardPr] -#endif -#endif - --- | Like 'reify', but safer and desugared. Uses local declarations where --- available. -dsReify :: DsMonad q => Name -> q (Maybe DInfo) -dsReify = traverse dsInfo <=< reifyWithLocals_maybe - --- create a list of expressions in the same order as the fields in the first argument --- but with the values as given in the second argument --- if a field is missing from the second argument, use the corresponding expression --- from the third argument -reorderFields :: DsMonad q => [VarStrictType] -> [FieldExp] -> [DExp] -> q [DExp] -reorderFields = reorderFields' dsExp - -reorderFieldsPat :: DsMonad q => [VarStrictType] -> [FieldPat] -> PatM q [DPat] -reorderFieldsPat field_decs field_pats = - reorderFields' dsPat field_decs field_pats (repeat DWildPa) - -reorderFields' :: (Applicative m, Monad m) - => (a -> m da) - -> [VarStrictType] -> [(Name, a)] - -> [da] -> m [da] -reorderFields' _ [] _ _ = return [] -reorderFields' ds_thing ((field_name, _, _) : rest) - field_things (deflt : rest_deflt) = do - rest' <- reorderFields' ds_thing rest field_things rest_deflt - case find (\(thing_name, _) -> thing_name == field_name) field_things of - Just (_, thing) -> (: rest') <$> ds_thing thing - Nothing -> return $ deflt : rest' -reorderFields' _ (_ : _) _ [] = error "Internal error in th-desugar." - --- | Make a tuple 'DExp' from a list of 'DExp's. Avoids using a 1-tuple. -mkTupleDExp :: [DExp] -> DExp -mkTupleDExp [exp] = exp -mkTupleDExp exps = foldl DAppE (DConE $ tupleDataName (length exps)) exps - --- | Make a tuple 'Exp' from a list of 'Exp's. Avoids using a 1-tuple. -mkTupleExp :: [Exp] -> Exp -mkTupleExp [exp] = exp -mkTupleExp exps = foldl AppE (ConE $ tupleDataName (length exps)) exps - --- | Make a tuple 'DPat' from a list of 'DPat's. Avoids using a 1-tuple. -mkTupleDPat :: [DPat] -> DPat -mkTupleDPat [pat] = pat -mkTupleDPat pats = DConPa (tupleDataName (length pats)) pats - --- | Make a tuple 'Pat' from a list of 'Pat's. Avoids using a 1-tuple. -mkTuplePat :: [Pat] -> Pat -mkTuplePat [pat] = pat -mkTuplePat pats = ConP (tupleDataName (length pats)) pats - --- | Is this pattern guaranteed to match? -isUniversalPattern :: DsMonad q => DPat -> q Bool -isUniversalPattern (DLitPa {}) = return False -isUniversalPattern (DVarPa {}) = return True -isUniversalPattern (DConPa con_name pats) = do - data_name <- dataConNameToDataName con_name - (_tvbs, cons) <- getDataD "Internal error." data_name - if length cons == 1 - then fmap and $ mapM isUniversalPattern pats - else return False -isUniversalPattern (DTildePa {}) = return True -isUniversalPattern (DBangPa pat) = isUniversalPattern pat -isUniversalPattern DWildPa = return True - --- | Apply one 'DExp' to a list of arguments -applyDExp :: DExp -> [DExp] -> DExp -applyDExp = foldl DAppE - --- | Apply one 'DType' to a list of arguments -applyDType :: DType -> [DType] -> DType -applyDType = foldl DAppT - --- | Convert a 'DTyVarBndr' into a 'DType' -dTyVarBndrToDType :: DTyVarBndr -> DType -dTyVarBndrToDType (DPlainTV a) = DVarT a -dTyVarBndrToDType (DKindedTV a k) = DVarT a `DSigT` k - --- | Convert a 'Strict' to a 'Bang' in GHCs 7.x. This is just --- the identity operation in GHC 8.x, which has no 'Strict'. --- (This is included in GHC 8.x only for good Haddocking.) -#if __GLASGOW_HASKELL__ <= 710 -strictToBang :: Strict -> Bang -strictToBang IsStrict = Bang NoSourceUnpackedness SourceStrict -strictToBang NotStrict = Bang NoSourceUnpackedness NoSourceStrictness -strictToBang Unpacked = Bang SourceUnpack SourceStrict -#else -strictToBang :: Bang -> Bang -strictToBang = id -#endif +rae@cs.brynmawr.edu + +Desugars full Template Haskell syntax into a smaller core syntax for further +processing. The desugared types and constructors are prefixed with a D. +-} + +{-# LANGUAGE TemplateHaskellQuotes, LambdaCase, CPP, ScopedTypeVariables, + TupleSections, DeriveDataTypeable, DeriveGeneric #-} + +module Language.Haskell.TH.Desugar.Core where + +import Prelude hiding (mapM, foldl, foldr, all, elem, exp, concatMap, and) + +import Language.Haskell.TH hiding (Extension(..), match, clause, cxt) +import Language.Haskell.TH.Datatype.TyVarBndr +import Language.Haskell.TH.Syntax hiding (Extension(..), lift) + +import Control.Monad hiding (forM_, mapM) +import qualified Control.Monad.Fail as Fail +import Control.Monad.Trans (MonadTrans(..)) +import Control.Monad.Writer (MonadWriter(..), WriterT(..)) +import Control.Monad.Zip +import Data.Data (Data) +import Data.Either (lefts) +import Data.Foldable as F hiding (concat, notElem) +import Data.Function (on) +import qualified Data.List as L +import qualified Data.Map as M +import Data.Map (Map) +import Data.Maybe (catMaybes, isJust, mapMaybe) +import Data.Monoid (All(..)) +import qualified Data.Set as S +import Data.Set (Set) +import Data.Traversable + +#if __GLASGOW_HASKELL__ >= 803 +import GHC.OverloadedLabels ( fromLabel ) +#endif + +#if __GLASGOW_HASKELL__ >= 807 +import GHC.Classes (IP(..)) +#else +import qualified Language.Haskell.TH as LangExt (Extension(..)) +#endif + +#if __GLASGOW_HASKELL__ >= 902 +import Data.List.NonEmpty (NonEmpty(..)) +import GHC.Records (HasField(..)) +#endif + +import GHC.Exts +import GHC.Generics (Generic) + +import Language.Haskell.TH.Desugar.AST +import Language.Haskell.TH.Desugar.FV +import qualified Language.Haskell.TH.Desugar.OSet as OS +import Language.Haskell.TH.Desugar.OSet (OSet) +import Language.Haskell.TH.Desugar.Util +import Language.Haskell.TH.Desugar.Reify +import Language.Haskell.TH.Desugar.Subst (DSubst, IgnoreKinds(..), matchTy) +import qualified Language.Haskell.TH.Desugar.Subst.Capturing as SC + +-- | Desugar an expression +dsExp :: DsMonad q => Exp -> q DExp +dsExp (VarE n) = return $ DVarE n +dsExp (ConE n) = return $ DConE n +dsExp (LitE lit) = return $ DLitE lit +dsExp (AppE e1 e2) = DAppE <$> dsExp e1 <*> dsExp e2 +dsExp (InfixE Nothing op Nothing) = dsExp op +dsExp (InfixE (Just lhs) op Nothing) = DAppE <$> (dsExp op) <*> (dsExp lhs) +dsExp (InfixE Nothing op (Just rhs)) = do + lhsName <- newUniqueName "lhs" + op' <- dsExp op + rhs' <- dsExp rhs + return $ dLamE [DVarP lhsName] (foldl DAppE op' [DVarE lhsName, rhs']) +dsExp (InfixE (Just lhs) op (Just rhs)) = + DAppE <$> (DAppE <$> dsExp op <*> dsExp lhs) <*> dsExp rhs +dsExp (UInfixE _ _ _) = + fail "Cannot desugar unresolved infix operators." +dsExp (ParensE exp) = dsExp exp +dsExp (LamE pats exp) = do + exp' <- dsExp exp + (pats', exp'') <- dsPatsOverExp pats exp' + return $ dLamE pats' exp'' +dsExp (LamCaseE matches) = do + matches' <- dsMatches (LamCaseAlt LamCase) matches + return $ dLamCaseE matches' +dsExp (TupE exps) = dsTup tupleDataName exps +dsExp (UnboxedTupE exps) = dsTup unboxedTupleDataName exps +dsExp (CondE e1 e2 e3) = + dsExp (CaseE e1 [mkBoolMatch 'True e2, mkBoolMatch 'False e3]) + where + mkBoolMatch :: Name -> Exp -> Match + mkBoolMatch boolDataCon rhs = + Match (ConP boolDataCon +#if __GLASGOW_HASKELL__ >= 901 + [] +#endif + []) (NormalB rhs) [] +dsExp (MultiIfE guarded_exps) = + let failure = mkErrorMatchExpr MultiWayIfAlt in + dsGuards guarded_exps failure +dsExp (LetE decs exp) = do + (decs', ip_binder) <- dsLetDecs decs + exp' <- dsExp exp + return $ DLetE decs' $ ip_binder exp' +dsExp (CaseE exp matches) = do + exp' <- dsExp exp + matches' <- dsMatches CaseAlt matches + return $ dCaseE exp' matches' +#if __GLASGOW_HASKELL__ >= 900 +dsExp (DoE mb_mod stmts) = dsDoStmts mb_mod stmts +#else +dsExp (DoE stmts) = dsDoStmts Nothing stmts +#endif +dsExp (CompE stmts) = dsComp stmts +dsExp (ArithSeqE (FromR exp)) = DAppE (DVarE 'enumFrom) <$> dsExp exp +dsExp (ArithSeqE (FromThenR exp1 exp2)) = + DAppE <$> (DAppE (DVarE 'enumFromThen) <$> dsExp exp1) <*> dsExp exp2 +dsExp (ArithSeqE (FromToR exp1 exp2)) = + DAppE <$> (DAppE (DVarE 'enumFromTo) <$> dsExp exp1) <*> dsExp exp2 +dsExp (ArithSeqE (FromThenToR e1 e2 e3)) = + DAppE <$> (DAppE <$> (DAppE (DVarE 'enumFromThenTo) <$> dsExp e1) <*> + dsExp e2) <*> + dsExp e3 +dsExp (ListE exps) = go exps + where go [] = return $ DConE '[] + go (h : t) = DAppE <$> (DAppE (DConE '(:)) <$> dsExp h) <*> go t +dsExp (SigE exp ty) = DSigE <$> dsExp exp <*> dsType ty +dsExp (RecConE con_name field_exps) = do + con <- dataConNameToCon con_name + reordered <- reorder con + return $ foldl DAppE (DConE con_name) reordered + where + reorder con = case con of + NormalC _name fields -> non_record fields + InfixC field1 _name field2 -> non_record [field1, field2] + RecC _name fields -> reorder_fields fields + ForallC _ _ c -> reorder c + GadtC _names fields _ret_ty -> non_record fields + RecGadtC _names fields _ret_ty -> reorder_fields fields + + reorder_fields fields = reorderFields con_name fields field_exps + (repeat $ DVarE 'undefined) + + non_record fields | null field_exps + -- Special case: record construction is allowed for any + -- constructor, regardless of whether the constructor + -- actually was declared with records, provided that no + -- records are given in the expression itself. (See #59). + -- + -- Con{} desugars down to Con undefined ... undefined. + = return $ replicate (length fields) $ DVarE 'undefined + + | otherwise = + impossible $ "Record syntax used with non-record constructor " + ++ (show con_name) ++ "." + +dsExp (RecUpdE exp field_exps) = do + -- here, we need to use one of the field names to find the tycon, somewhat dodgily + first_name <- case field_exps of + ((name, _) : _) -> return name + _ -> impossible "Record update with no fields listed." + info <- reifyWithLocals first_name + applied_type <- case info of + VarI _name ty _m_dec -> extract_first_arg ty + _ -> impossible "Record update with an invalid field name." + type_name <- extract_type_name applied_type + (_, _, cons) <- getDataD "This seems to be an error in GHC." type_name + let filtered_cons = filter_cons_with_names cons (map fst field_exps) + exp' <- dsExp exp + matches <- mapM con_to_dmatch filtered_cons + let all_matches + | length filtered_cons == length cons = matches + | otherwise = matches ++ [error_match] + return $ dCaseE exp' all_matches + where + extract_first_arg :: DsMonad q => Type -> q Type + extract_first_arg (AppT (AppT ArrowT arg) _) = return arg + extract_first_arg (ForallT _ _ t) = extract_first_arg t + extract_first_arg (SigT t _) = extract_first_arg t + extract_first_arg _ = impossible "Record selector not a function." + + extract_type_name :: DsMonad q => Type -> q Name + extract_type_name (AppT t1 _) = extract_type_name t1 + extract_type_name (SigT t _) = extract_type_name t + extract_type_name (ConT n) = return n + extract_type_name _ = impossible "Record selector domain not a datatype." + + filter_cons_with_names cons field_names = + filter has_names cons + where + args_contain_names args = + let con_field_names = map fst_of_3 args in + all (`elem` con_field_names) field_names + + has_names (RecC _con_name args) = + args_contain_names args + has_names (RecGadtC _con_name args _ret_ty) = + args_contain_names args + has_names (ForallC _ _ c) = has_names c + has_names _ = False + + rec_con_to_dmatch con_name args = do + let con_field_names = map fst_of_3 args + field_var_names <- mapM (newUniqueName . nameBase) con_field_names + DMatch (DConP con_name [] (map DVarP field_var_names)) <$> + (foldl DAppE (DConE con_name) <$> + (reorderFields con_name args field_exps (map DVarE field_var_names))) + + con_to_dmatch :: DsMonad q => Con -> q DMatch + con_to_dmatch (RecC con_name args) = rec_con_to_dmatch con_name args + -- We're assuming the GADT constructor has only one Name here, but since + -- this constructor was reified, this assumption should always hold true. + con_to_dmatch (RecGadtC [con_name] args _ret_ty) = rec_con_to_dmatch con_name args + con_to_dmatch (ForallC _ _ c) = con_to_dmatch c + con_to_dmatch _ = impossible "Internal error within th-desugar." + + error_match = DMatch DWildP (mkErrorMatchExpr RecUpd) + + fst_of_3 (x, _, _) = x +dsExp (StaticE exp) = DStaticE <$> dsExp exp +dsExp (UnboundVarE n) = return (DVarE n) +#if __GLASGOW_HASKELL__ >= 801 +dsExp (AppTypeE exp ty) = DAppTypeE <$> dsExp exp <*> dsType ty +dsExp (UnboxedSumE exp alt arity) = + DAppE (DConE $ unboxedSumDataName alt arity) <$> dsExp exp +#endif +#if __GLASGOW_HASKELL__ >= 803 +dsExp (LabelE str) = return $ DVarE 'fromLabel `DAppTypeE` DLitT (StrTyLit str) +#endif +#if __GLASGOW_HASKELL__ >= 807 +dsExp (ImplicitParamVarE n) = return $ DVarE 'ip `DAppTypeE` DLitT (StrTyLit n) +dsExp (MDoE {}) = fail "th-desugar currently does not support RecursiveDo" +#endif +#if __GLASGOW_HASKELL__ >= 902 +dsExp (GetFieldE arg field) = DAppE (mkGetFieldProj field) <$> dsExp arg +dsExp (ProjectionE fields) = + case fields of + f :| fs -> return $ foldl' comp (mkGetFieldProj f) fs + where + comp :: DExp -> String -> DExp + comp acc f = DVarE '(.) `DAppE` mkGetFieldProj f `DAppE` acc +#endif +#if __GLASGOW_HASKELL__ >= 903 +dsExp (LamCasesE clauses) = DLamCasesE <$> dsClauses (LamCaseAlt LamCases) clauses +#endif +#if __GLASGOW_HASKELL__ >= 907 +dsExp (TypedBracketE exp) = DTypedBracketE <$> dsExp exp +dsExp (TypedSpliceE exp) = DTypedSpliceE <$> dsExp exp +#endif +#if __GLASGOW_HASKELL__ >= 909 +dsExp (TypeE ty) = DTypeE <$> dsType ty +#endif +#if __GLASGOW_HASKELL__ >= 911 +dsExp (ForallE tvbs exp) = + DForallE <$> (DForallInvis <$> mapM dsTvbSpec tvbs) <*> dsExp exp +dsExp (ForallVisE tvbs exp) = + DForallE <$> (DForallVis <$> mapM dsTvbUnit tvbs) <*> dsExp exp +dsExp (ConstrainedE preds exp) = + DConstrainedE <$> mapM dsExp preds <*> dsExp exp +#endif + +#if __GLASGOW_HASKELL__ >= 809 +dsTup :: DsMonad q => (Int -> Name) -> [Maybe Exp] -> q DExp +dsTup = ds_tup +#else +dsTup :: DsMonad q => (Int -> Name) -> [Exp] -> q DExp +dsTup tuple_data_name = ds_tup tuple_data_name . map Just +#endif + +-- | Desugar a tuple (or tuple section) expression. +ds_tup :: forall q. DsMonad q + => (Int -> Name) -- ^ Compute the 'Name' of a tuple (boxed or unboxed) + -- data constructor from its arity. + -> [Maybe Exp] -- ^ The tuple's subexpressions. 'Nothing' entries + -- denote empty fields in a tuple section. + -> q DExp +ds_tup tuple_data_name mb_exps = do + section_exps <- mapM ds_section_exp mb_exps + let section_vars = lefts section_exps + tup_body = mk_tup_body section_exps + pure $ + if null section_vars + then tup_body -- If this isn't a tuple section, don't create a lambda. + else dLamE (map DVarP section_vars) tup_body + where + -- If dealing with an empty field in a tuple section (Nothing), create a + -- unique name and return Left. These names will be used to construct the + -- lambda expression that it desugars to. + -- (For example, `(,5)` desugars to `\ts -> (,) ts 5`.) + -- + -- If dealing with a tuple subexpression (Just), desugar it and return + -- Right. + ds_section_exp :: Maybe Exp -> q (Either Name DExp) + ds_section_exp = maybe (Left <$> qNewName "ts") (fmap Right . dsExp) + + mk_tup_body :: [Either Name DExp] -> DExp + mk_tup_body section_exps = + foldl' apply_tup_body (DConE $ tuple_data_name (length section_exps)) + section_exps + + apply_tup_body :: DExp -> Either Name DExp -> DExp + apply_tup_body f (Left n) = f `DAppE` DVarE n + apply_tup_body f (Right e) = f `DAppE` e + +-- | Construct a 'DExp' value that is equivalent to writing a lambda expression. +-- Under the hood, this uses @\\cases@ ('DLamCasesE'). +-- +-- @'mkDLamEFromDPats' pats exp@ is equivalent to writing +-- @pure ('dLamE' pats exp)@. As such, 'mkDLamEFromDPats' is deprecated in favor +-- of 'dLamE', and 'mkDLamEFromDPats' will be removed in a future @th-desugar@ +-- release. +mkDLamEFromDPats :: Quasi q => [DPat] -> DExp -> q DExp +mkDLamEFromDPats pats exp = pure $ dLamE pats exp +{-# DEPRECATED mkDLamEFromDPats "Use `dLamE` or `DLamCasesE` instead." #-} + +#if __GLASGOW_HASKELL__ >= 902 +mkGetFieldProj :: String -> DExp +mkGetFieldProj field = DVarE 'getField `DAppTypeE` DLitT (StrTyLit field) +#endif + +-- | Desugar a list of matches for a @case@ or @\\case@ expression. +dsMatches :: DsMonad q + => MatchContext -- ^ The context in which the matches arise + -> [Match] -- ^ Matches of the @case@ or @\\case@ expression + -> q [DMatch] +dsMatches _ [] = pure [] +-- Include a special case for guard-less matches to make the desugared output +-- a little nicer. See Note [Desugaring clauses compactly (when possible)]. +dsMatches mc (Match pat (NormalB exp) where_decs : rest) = do + rest' <- dsMatches mc rest + exp' <- dsExp exp + (where_decs', ip_binder) <- dsLetDecs where_decs + let exp_with_wheres = maybeDLetE where_decs' (ip_binder exp') + (pats', exp'') <- dsPatOverExp pat exp_with_wheres + pure $ DMatch pats' exp'' : rest' +dsMatches mc matches@(Match _ _ _ : _) = do + scrutinee_name <- newUniqueName "scrutinee" + let scrutinee = DVarE scrutinee_name + matches' <- foldrM (ds_match scrutinee) [] matches + pure [DMatch (DVarP scrutinee_name) (dCaseE scrutinee matches')] + where + ds_match :: DsMonad q => DExp -> Match -> [DMatch] -> q [DMatch] + ds_match scrutinee (Match pat body where_decs) failure_matches = do + let failure_exp = maybeDCaseE mc scrutinee failure_matches + exp <- dsBody body where_decs failure_exp + (pat', exp') <- dsPatOverExp pat exp + uni_pattern <- isUniversalPattern pat' -- incomplete attempt at #6 + let match = DMatch pat' exp' + if uni_pattern + then return [match] + else return (match : failure_matches) + +-- | Desugar a @Body@ +dsBody :: DsMonad q + => Body -- ^ body to desugar + -> [Dec] -- ^ "where" declarations + -> DExp -- ^ what to do if the guards don't match + -> q DExp +dsBody (NormalB exp) decs _ = do + (decs', ip_binder) <- dsLetDecs decs + exp' <- dsExp exp + return $ maybeDLetE decs' $ ip_binder exp' +dsBody (GuardedB guarded_exps) decs failure = do + (decs', ip_binder) <- dsLetDecs decs + guarded_exp' <- dsGuards guarded_exps failure + return $ maybeDLetE decs' $ ip_binder guarded_exp' + +-- | Construct a 'DExp' value that is equivalent to writing a @case@ expression +-- that scrutinizes multiple values at once. Under the hood, this uses +-- @\\cases@ ('DLamCasesE'). For instance, given this code: +-- +-- @ +-- case (scrut_1, ..., scrut_n) of +-- (pat_1_1, ..., pat_1_n) -> rhs_1 +-- ... +-- (pat_m_1, ..., pat_m_n) -> rhs_n +-- @ +-- +-- The following @\\cases@ expression will be created under the hood: +-- +-- @ +-- (\\cases +-- pat_1_1 ... pat_1_n -> rhs_1 +-- ... +-- pat_m_1 ... pat_m_n -> rhs_n) scrut_1 ... scrut_n +-- @ +-- +-- In other words, this creates a 'DLamCasesE' value and then applies it to +-- argument values. +-- +-- Preconditions: +-- +-- * If the list of 'DClause's is non-empty, then the number of patterns in each +-- 'DClause' must be equal to the number of 'DExp' arguments. +-- +-- * If the list of 'DClause's is empty, then there must be exactly one 'DExp' +-- argument. +dCasesE :: [DExp] -> [DClause] -> DExp +dCasesE scruts clauses = applyDExp (DLamCasesE clauses) scruts + +-- | If decs is non-empty, delcare them in a let: +maybeDLetE :: [DLetDec] -> DExp -> DExp +maybeDLetE [] exp = exp +maybeDLetE decs exp = DLetE decs exp + +-- | If matches is non-empty, make a case statement; otherwise make an error statement +maybeDCaseE :: MatchContext -> DExp -> [DMatch] -> DExp +maybeDCaseE mc _ [] = mkErrorMatchExpr mc +maybeDCaseE _ scrut matches = dCaseE scrut matches + +-- | If the list of clauses is non-empty, make a @\\cases@ expression and apply +-- it using the expressions as arguments. Otherwise, make an error statement. +-- +-- Precondition: if the list of 'DClause's is non-empty, then the number of +-- patterns in each 'DClause' must be equal to the number of 'DExp' arguments. +maybeDCasesE :: MatchContext -> [DExp] -> [DClause] -> DExp +maybeDCasesE mc _ [] = mkErrorMatchExpr mc +maybeDCasesE _ scruts clauses = dCasesE scruts clauses + +-- | Desugar guarded expressions +dsGuards :: DsMonad q + => [(Guard, Exp)] -- ^ Guarded expressions + -> DExp -- ^ What to do if none of the guards match + -> q DExp +dsGuards [] thing_inside = return thing_inside +dsGuards ((NormalG gd, exp) : rest) thing_inside = + dsGuards ((PatG [NoBindS gd], exp) : rest) thing_inside +dsGuards ((PatG stmts, exp) : rest) thing_inside = do + success <- dsExp exp + failure <- dsGuards rest thing_inside + dsGuardStmts stmts success failure + +-- | Desugar the @Stmt@s in a guard +dsGuardStmts :: DsMonad q + => [Stmt] -- ^ The @Stmt@s to desugar + -> DExp -- ^ What to do if the @Stmt@s yield success + -> DExp -- ^ What to do if the @Stmt@s yield failure + -> q DExp +dsGuardStmts [] success _failure = return success +dsGuardStmts (BindS pat exp : rest) success failure = do + success' <- dsGuardStmts rest success failure + (pat', success'') <- dsPatOverExp pat success' + exp' <- dsExp exp + return $ dCaseE exp' [DMatch pat' success'', DMatch DWildP failure] +dsGuardStmts (LetS decs : rest) success failure = do + (decs', ip_binder) <- dsLetDecs decs + success' <- dsGuardStmts rest success failure + return $ DLetE decs' $ ip_binder success' + -- special-case a final pattern containing "otherwise" or "True" + -- note that GHC does this special-casing, too, in DsGRHSs.isTrueLHsExpr +dsGuardStmts [NoBindS exp] success _failure + | VarE name <- exp + , name == 'otherwise + = return success + + | ConE name <- exp + , name == 'True + = return success +dsGuardStmts (NoBindS exp : rest) success failure = do + exp' <- dsExp exp + success' <- dsGuardStmts rest success failure + return $ dCaseE exp' [ DMatch (DConP 'True [] []) success' + , DMatch (DConP 'False [] []) failure ] +dsGuardStmts (ParS _ : _) _ _ = impossible "Parallel comprehension in a pattern guard." +#if __GLASGOW_HASKELL__ >= 807 +dsGuardStmts (RecS {} : _) _ _ = fail "th-desugar currently does not support RecursiveDo" +#endif + +-- | Desugar the @Stmt@s in a @do@ expression +dsDoStmts :: forall q. DsMonad q => Maybe ModName -> [Stmt] -> q DExp +dsDoStmts mb_mod = go + where + go :: [Stmt] -> q DExp + go [] = impossible "do-expression ended with something other than bare statement." + go [NoBindS exp] = dsExp exp + go (BindS pat exp : rest) = do + rest' <- go rest + dsBindS mb_mod exp pat rest' "do expression" + go (LetS decs : rest) = do + (decs', ip_binder) <- dsLetDecs decs + rest' <- go rest + return $ DLetE decs' $ ip_binder rest' + go (NoBindS exp : rest) = do + exp' <- dsExp exp + rest' <- go rest + let sequence_name = mk_qual_do_name mb_mod '(>>) + return $ DAppE (DAppE (DVarE sequence_name) exp') rest' + go (ParS _ : _) = impossible "Parallel comprehension in a do-statement." +#if __GLASGOW_HASKELL__ >= 807 + go (RecS {} : _) = fail "th-desugar currently does not support RecursiveDo" +#endif + +-- | Desugar the @Stmt@s in a list or monad comprehension +dsComp :: DsMonad q => [Stmt] -> q DExp +dsComp [] = impossible "List/monad comprehension ended with something other than a bare statement." +dsComp [NoBindS exp] = DAppE (DVarE 'return) <$> dsExp exp +dsComp (BindS pat exp : rest) = do + rest' <- dsComp rest + dsBindS Nothing exp pat rest' "monad comprehension" +dsComp (LetS decs : rest) = do + (decs', ip_binder) <- dsLetDecs decs + rest' <- dsComp rest + return $ DLetE decs' $ ip_binder rest' +dsComp (NoBindS exp : rest) = do + exp' <- dsExp exp + rest' <- dsComp rest + return $ DAppE (DAppE (DVarE '(>>)) (DAppE (DVarE 'guard) exp')) rest' +dsComp (ParS stmtss : rest) = do + (pat, exp) <- dsParComp stmtss + rest' <- dsComp rest + return $ DAppE (DAppE (DVarE '(>>=)) exp) (dLamE [pat] rest') +#if __GLASGOW_HASKELL__ >= 807 +dsComp (RecS {} : _) = fail "th-desugar currently does not support RecursiveDo" +#endif + +-- Desugar a binding statement in a do- or list comprehension. +-- +-- In the event that the pattern in the statement is partial, the desugared +-- case expression will contain a catch-all case that calls 'fail' from either +-- 'MonadFail' or 'Monad', depending on whether the @MonadFailDesugaring@ +-- language extension is enabled or not. (On GHCs older than 8.0, 'fail' from +-- 'Monad' is always used.) +dsBindS :: forall q. DsMonad q + => Maybe ModName -> Exp -> Pat -> DExp -> String -> q DExp +dsBindS mb_mod bind_arg_exp success_pat success_exp ctxt = do + bind_arg_exp' <- dsExp bind_arg_exp + (success_pat', success_exp') <- dsPatOverExp success_pat success_exp + is_univ_pat <- isUniversalPattern success_pat' -- incomplete attempt at #6 + let bind_into = DAppE (DAppE (DVarE bind_name) bind_arg_exp') + if is_univ_pat + then return $ bind_into $ dLamE [success_pat'] success_exp' + else do fail_name <- mk_fail_name + return $ bind_into $ DLamCasesE + [ DClause [success_pat'] success_exp' + , DClause [DWildP] $ + DVarE fail_name `DAppE` + DLitE (StringL $ "Pattern match failure in " ++ ctxt) + ] + where + bind_name = mk_qual_do_name mb_mod '(>>=) + + mk_fail_name :: q Name +#if __GLASGOW_HASKELL__ >= 807 + -- GHC 8.8 deprecates the MonadFailDesugaring extension since its effects + -- are always enabled. Furthermore, MonadFailDesugaring is no longer + -- enabled by default, so simply use MonadFail.fail. (That happens to + -- be the same as Prelude.fail in 8.8+.) + mk_fail_name = return fail_MonadFail_name +#else + mk_fail_name = do + mfd <- qIsExtEnabled LangExt.MonadFailDesugaring + return $ if mfd then fail_MonadFail_name else fail_Prelude_name +#endif + + fail_MonadFail_name = mk_qual_do_name mb_mod 'Fail.fail + +#if __GLASGOW_HASKELL__ < 807 + fail_Prelude_name = mk_qual_do_name mb_mod 'Prelude.fail +#endif + +-- | Desugar the contents of a parallel comprehension (enabled via the +-- @ParallelListComp@ language extension). For example, this expression: +-- +-- @ +-- [ x + y | x <- [1,2,3] | y <- [4,5,6] ] +-- @ +-- +-- Will be desugared to code that looks roughly like: +-- +-- @ +-- 'mzip' [1, 2, 3] [4, 5, 6] '>>=' \\cases (x, y) -> 'return' (x + y) +-- @ +-- +-- This function returns a 'DPat' containing a tuple of all bound variables and +-- a 'DExp' to produce the values for those variables. +dsParComp :: DsMonad q => [[Stmt]] -> q (DPat, DExp) +dsParComp [] = impossible "Empty list of parallel comprehension statements." +dsParComp [r] = do + let rv = foldMap extractBoundNamesStmt r + dsR <- dsComp (r ++ [mk_tuple_stmt rv]) + return (mk_tuple_dpat rv, dsR) +dsParComp (q : rest) = do + let qv = foldMap extractBoundNamesStmt q + (rest_pat, rest_exp) <- dsParComp rest + dsQ <- dsComp (q ++ [mk_tuple_stmt qv]) + let zipped = DAppE (DAppE (DVarE 'mzip) dsQ) rest_exp + return (DConP (tupleDataName 2) [] [mk_tuple_dpat qv, rest_pat], zipped) + +-- helper function for dsParComp +mk_tuple_stmt :: OSet Name -> Stmt +mk_tuple_stmt name_set = + NoBindS (mkTupleExp (F.foldr ((:) . VarE) [] name_set)) + +-- helper function for dsParComp +mk_tuple_dpat :: OSet Name -> DPat +mk_tuple_dpat name_set = + mkTupleDPat (F.foldr ((:) . DVarP) [] name_set) + +-- | Desugar a pattern, along with processing a (desugared) expression that +-- is the entire scope of the variables bound in the pattern. +dsPatOverExp :: DsMonad q => Pat -> DExp -> q (DPat, DExp) +dsPatOverExp pat exp = do + (pat', vars) <- runWriterT $ dsPat pat + let name_decs = map (uncurry (DValD . DVarP)) vars + return (pat', maybeDLetE name_decs exp) + +-- | Desugar multiple patterns. Like 'dsPatOverExp'. +dsPatsOverExp :: DsMonad q => [Pat] -> DExp -> q ([DPat], DExp) +dsPatsOverExp pats exp = do + (pats', vars) <- runWriterT $ mapM dsPat pats + let name_decs = map (uncurry (DValD . DVarP)) vars + return (pats', maybeDLetE name_decs exp) + +-- | Desugar a pattern, returning a list of (Name, DExp) pairs of extra +-- variables that must be bound within the scope of the pattern +dsPatX :: DsMonad q => Pat -> q (DPat, [(Name, DExp)]) +dsPatX = runWriterT . dsPat + +-- | Desugaring a pattern also returns the list of variables bound in as-patterns +-- and the values they should be bound to. This variables must be brought into +-- scope in the "body" of the pattern. +type PatM q = WriterT [(Name, DExp)] q + +-- | Desugar a pattern. +dsPat :: DsMonad q => Pat -> PatM q DPat +dsPat (LitP lit) = return $ DLitP lit +dsPat (VarP n) = return $ DVarP n +dsPat (TupP pats) = DConP (tupleDataName (length pats)) [] <$> mapM dsPat pats +dsPat (UnboxedTupP pats) = DConP (unboxedTupleDataName (length pats)) [] <$> + mapM dsPat pats +#if __GLASGOW_HASKELL__ >= 901 +dsPat (ConP name tys pats) = DConP name <$> mapM dsType tys <*> mapM dsPat pats +#else +dsPat (ConP name pats) = DConP name [] <$> mapM dsPat pats +#endif +dsPat (InfixP p1 name p2) = DConP name [] <$> mapM dsPat [p1, p2] +dsPat (UInfixP _ _ _) = + fail "Cannot desugar unresolved infix operators." +dsPat (ParensP pat) = dsPat pat +dsPat (TildeP pat) = DTildeP <$> dsPat pat +dsPat (BangP pat) = DBangP <$> dsPat pat +dsPat (AsP name pat) = do + pat' <- dsPat pat + pat'' <- lift $ removeWilds pat' + tell [(name, dPatToDExp pat'')] + return pat'' +dsPat WildP = return DWildP +dsPat (RecP con_name field_pats) = do + con <- lift $ dataConNameToCon con_name + reordered <- reorder con + return $ DConP con_name [] reordered + where + reorder con = case con of + NormalC _name fields -> non_record fields + InfixC field1 _name field2 -> non_record [field1, field2] + RecC _name fields -> reorder_fields_pat fields + ForallC _ _ c -> reorder c + GadtC _names fields _ret_ty -> non_record fields + RecGadtC _names fields _ret_ty -> reorder_fields_pat fields + + reorder_fields_pat fields = reorderFieldsPat con_name fields field_pats + + non_record fields | null field_pats + -- Special case: record patterns are allowed for any + -- constructor, regardless of whether the constructor + -- actually was declared with records, provided that + -- no records are given in the pattern itself. (See #59). + -- + -- Con{} desugars down to Con _ ... _. + = return $ replicate (length fields) DWildP + | otherwise = lift $ impossible + $ "Record syntax used with non-record constructor " + ++ (show con_name) ++ "." + +dsPat (ListP pats) = go pats + where go [] = return $ DConP '[] [] [] + go (h : t) = do + h' <- dsPat h + t' <- go t + return $ DConP '(:) [] [h', t'] +dsPat (SigP pat ty) = DSigP <$> dsPat pat <*> dsType ty +#if __GLASGOW_HASKELL__ >= 801 +dsPat (UnboxedSumP pat alt arity) = + DConP (unboxedSumDataName alt arity) [] <$> ((:[]) <$> dsPat pat) +#endif +#if __GLASGOW_HASKELL__ >= 909 +dsPat (TypeP ty) = DTypeP <$> dsType ty +dsPat (InvisP ty) = DInvisP <$> dsType ty +#endif +dsPat (ViewP _ _) = + fail "View patterns are not supported in th-desugar. Use pattern guards instead." +#if __GLASGOW_HASKELL__ >= 911 +dsPat (OrP _) = + fail "Or-patterns are not supported in th-desugar." +#endif + +-- | Convert a 'DPat' to a 'DExp'. Fails on 'DWildP' and 'DInvisP'. +dPatToDExp :: DPat -> DExp +dPatToDExp (DLitP lit) = DLitE lit +dPatToDExp (DVarP name) = DVarE name +dPatToDExp (DConP name tys pats) = foldl DAppE (foldl DAppTypeE (DConE name) tys) (map dPatToDExp pats) +dPatToDExp (DTildeP pat) = dPatToDExp pat +dPatToDExp (DBangP pat) = dPatToDExp pat +dPatToDExp (DSigP pat ty) = DSigE (dPatToDExp pat) ty +dPatToDExp (DTypeP ty) = DTypeE ty +dPatToDExp DWildP = error "Internal error in th-desugar: wildcard in rhs of as-pattern" +dPatToDExp (DInvisP {}) = error "Internal error in th-desugar: invisible type pattern in rhs of as-pattern" + +-- | Remove all wildcards from a pattern, replacing any wildcard with a fresh +-- variable +removeWilds :: DsMonad q => DPat -> q DPat +removeWilds p@(DLitP _) = return p +removeWilds p@(DVarP _) = return p +removeWilds (DConP con_name tys pats) = DConP con_name tys <$> mapM removeWilds pats +removeWilds (DTildeP pat) = DTildeP <$> removeWilds pat +removeWilds (DBangP pat) = DBangP <$> removeWilds pat +removeWilds (DSigP pat ty) = DSigP <$> removeWilds pat <*> pure ty +removeWilds (DTypeP ty) = pure $ DTypeP ty +removeWilds (DInvisP ty) = pure $ DInvisP ty +removeWilds DWildP = DVarP <$> newUniqueName "wild" + +-- | Desugar @Info@ +dsInfo :: DsMonad q => Info -> q DInfo +dsInfo (ClassI dec instances) = do + [ddec] <- dsDec dec + dinstances <- dsDecs instances + return $ DTyConI ddec (Just dinstances) +dsInfo (ClassOpI name ty parent) = + DVarI name <$> dsType ty <*> pure (Just parent) +dsInfo (TyConI dec) = do + [ddec] <- dsDec dec + return $ DTyConI ddec Nothing +dsInfo (FamilyI dec instances) = do + [ddec] <- dsDec dec + dinstances <- dsDecs instances + return $ DTyConI ddec (Just dinstances) +dsInfo (PrimTyConI name arity unlifted) = + return $ DPrimTyConI name arity unlifted +dsInfo (DataConI name ty parent) = + DVarI name <$> dsType ty <*> pure (Just parent) +dsInfo (VarI name ty Nothing) = + DVarI name <$> dsType ty <*> pure Nothing +dsInfo (VarI name _ (Just _)) = + impossible $ "Declaration supplied with variable: " ++ show name +dsInfo (TyVarI name ty) = DTyVarI name <$> dsType ty +#if __GLASGOW_HASKELL__ >= 801 +dsInfo (PatSynI name ty) = DPatSynI name <$> dsType ty +#endif + +-- | Desugar arbitrary @Dec@s +dsDecs :: DsMonad q => [Dec] -> q [DDec] +dsDecs = concatMapM dsDec + +-- | Desugar a single @Dec@, perhaps producing multiple 'DDec's +dsDec :: DsMonad q => Dec -> q [DDec] +dsDec d@(FunD {}) = dsTopLevelLetDec d +dsDec d@(ValD {}) = dsTopLevelLetDec d +dsDec (DataD cxt n tvbs mk cons derivings) = + dsDataDec Data cxt n tvbs mk cons derivings +dsDec (NewtypeD cxt n tvbs mk con derivings) = + dsDataDec Newtype cxt n tvbs mk [con] derivings +dsDec (TySynD n tvbs ty) = + (:[]) <$> (DTySynD n <$> mapM dsTvbVis tvbs <*> dsType ty) +dsDec (ClassD cxt n tvbs fds decs) = + (:[]) <$> (DClassD <$> dsCxt cxt <*> pure n <*> mapM dsTvbVis tvbs + <*> pure fds <*> dsDecs decs) +dsDec (InstanceD over cxt ty decs) = + (:[]) <$> (DInstanceD over Nothing <$> dsCxt cxt <*> dsType ty <*> dsDecs decs) +dsDec d@(SigD {}) = dsTopLevelLetDec d +dsDec (ForeignD f) = (:[]) <$> (DForeignD <$> dsForeign f) +dsDec d@(InfixD {}) = dsTopLevelLetDec d +dsDec d@(PragmaD {}) = dsTopLevelLetDec d +dsDec (OpenTypeFamilyD tfHead) = + (:[]) <$> (DOpenTypeFamilyD <$> dsTypeFamilyHead tfHead) +dsDec (DataFamilyD n tvbs m_k) = + (:[]) <$> (DDataFamilyD n <$> mapM dsTvbVis tvbs <*> mapM dsType m_k) +#if __GLASGOW_HASKELL__ >= 807 +dsDec (DataInstD cxt mtvbs lhs mk cons derivings) = + case unfoldType lhs of + (ConT n, tys) -> dsDataInstDec Data cxt n mtvbs tys mk cons derivings + (_, _) -> fail $ "Unexpected data instance LHS: " ++ pprint lhs +dsDec (NewtypeInstD cxt mtvbs lhs mk con derivings) = + case unfoldType lhs of + (ConT n, tys) -> dsDataInstDec Newtype cxt n mtvbs tys mk [con] derivings + (_, _) -> fail $ "Unexpected newtype instance LHS: " ++ pprint lhs +#else +dsDec (DataInstD cxt n tys mk cons derivings) = + dsDataInstDec Data cxt n Nothing (map TANormal tys) mk cons derivings +dsDec (NewtypeInstD cxt n tys mk con derivings) = + dsDataInstDec Newtype cxt n Nothing (map TANormal tys) mk [con] derivings +#endif +#if __GLASGOW_HASKELL__ >= 807 +dsDec (TySynInstD eqn) = (:[]) <$> (DTySynInstD <$> dsTySynEqn unusedArgument eqn) +#else +dsDec (TySynInstD n eqn) = (:[]) <$> (DTySynInstD <$> dsTySynEqn n eqn) +#endif +dsDec (ClosedTypeFamilyD tfHead eqns) = + (:[]) <$> (DClosedTypeFamilyD <$> dsTypeFamilyHead tfHead + <*> mapM (dsTySynEqn (typeFamilyHeadName tfHead)) eqns) +dsDec (RoleAnnotD n roles) = return [DRoleAnnotD n roles] +#if __GLASGOW_HASKELL__ >= 801 +dsDec (PatSynD n args dir pat) = do + dir' <- dsPatSynDir n dir + (pat', vars) <- dsPatX pat + unless (null vars) $ + fail $ "Pattern synonym definition cannot contain as-patterns (@)." + return [DPatSynD n args dir' pat'] +dsDec (PatSynSigD n ty) = (:[]) <$> (DPatSynSigD n <$> dsType ty) +dsDec (StandaloneDerivD mds cxt ty) = + (:[]) <$> (DStandaloneDerivD <$> mapM dsDerivStrategy mds + <*> pure Nothing <*> dsCxt cxt <*> dsType ty) +#else +dsDec (StandaloneDerivD cxt ty) = + (:[]) <$> (DStandaloneDerivD Nothing Nothing <$> dsCxt cxt <*> dsType ty) +#endif +dsDec (DefaultSigD n ty) = (:[]) <$> (DDefaultSigD n <$> dsType ty) +#if __GLASGOW_HASKELL__ >= 807 +dsDec (ImplicitParamBindD {}) = impossible "Non-`let`-bound implicit param binding" +#endif +#if __GLASGOW_HASKELL__ >= 809 +dsDec (KiSigD n ki) = (:[]) <$> (DKiSigD n <$> dsType ki) +#endif +#if __GLASGOW_HASKELL__ >= 903 +dsDec (DefaultD tys) = (:[]) <$> (DDefaultD <$> mapM dsType tys) +#endif +#if __GLASGOW_HASKELL__ >= 906 +dsDec (TypeDataD n tys mk cons) = + dsDataDec TypeData [] n tys mk cons [] +#endif + +-- | Desugar a 'DataD', 'NewtypeD', or 'TypeDataD'. +dsDataDec :: DsMonad q + => DataFlavor -> Cxt -> Name -> [TyVarBndrVis] + -> Maybe Kind -> [Con] -> [DerivingClause] -> q [DDec] +dsDataDec nd cxt n tvbs mk cons derivings = do + tvbs' <- mapM dsTvbVis tvbs + h98_tvbs <- + case mk of + -- If there's an explicit return kind, we're dealing with a + -- GADT, so this argument goes unused in dsCon. + Just {} -> pure unusedArgument + -- If there is no explicit return kind, we're dealing with a + -- Haskell98-style data type, so we must compute the type variable + -- binders to use in the types of the data constructors. + -- + -- Rather than just returning `tvbs'` here, we propagate kind information + -- from the data type's standalone kind signature (if one exists) to make + -- the kinds more precise. + Nothing -> do + mb_sak <- dsReifyType n + let tvbSpecs = changeDTVFlags SpecifiedSpec tvbs' + pure $ maybe tvbSpecs dtvbForAllTyFlagsToSpecs $ do + sak <- mb_sak + dMatchUpSAKWithDecl sak tvbs' + let h98_return_type = nonFamilyDataReturnType n tvbs' + (:[]) <$> (DDataD nd <$> dsCxt cxt <*> pure n + <*> pure tvbs' <*> mapM dsType mk + <*> concatMapM (dsCon h98_tvbs h98_return_type) cons + <*> mapM dsDerivClause derivings) + +-- | Desugar a 'DataInstD' or a 'NewtypeInstD'. +dsDataInstDec :: DsMonad q + => DataFlavor -> Cxt -> Name -> Maybe [TyVarBndrUnit] -> [TypeArg] + -> Maybe Kind -> [Con] -> [DerivingClause] -> q [DDec] +dsDataInstDec nd cxt n mtvbs tys mk cons derivings = do + mtvbs' <- mapM (mapM dsTvbUnit) mtvbs + tys' <- mapM dsTypeArg tys + let lhs' = applyDType (DConT n) tys' + h98_tvbs = + changeDTVFlags SpecifiedSpec $ + case (mk, mtvbs') of + -- If there's an explicit return kind, we're dealing with a + -- GADT, so this argument goes unused in dsCon. + (Just {}, _) -> unusedArgument + -- H98, and there is an explicit `forall` in front. Just reuse the + -- type variable binders from the `forall`. + (Nothing, Just tvbs') -> tvbs' + -- H98, and no explicit `forall`. Compute the bound variables + -- manually. + (Nothing, Nothing) -> dataFamInstTvbs tys' + h98_fam_inst_type = dataFamInstReturnType n tys' + (:[]) <$> (DDataInstD nd <$> dsCxt cxt <*> pure mtvbs' + <*> pure lhs' <*> mapM dsType mk + <*> concatMapM (dsCon h98_tvbs h98_fam_inst_type) cons + <*> mapM dsDerivClause derivings) + +-- | Desugar a @FamilyResultSig@ +dsFamilyResultSig :: DsMonad q => FamilyResultSig -> q DFamilyResultSig +dsFamilyResultSig NoSig = return DNoSig +dsFamilyResultSig (KindSig k) = DKindSig <$> dsType k +dsFamilyResultSig (TyVarSig tvb) = DTyVarSig <$> dsTvbUnit tvb + +-- | Desugar a @TypeFamilyHead@ +dsTypeFamilyHead :: DsMonad q => TypeFamilyHead -> q DTypeFamilyHead +dsTypeFamilyHead (TypeFamilyHead n tvbs result inj) + = DTypeFamilyHead n <$> mapM dsTvbVis tvbs + <*> dsFamilyResultSig result + <*> pure inj + +typeFamilyHeadName :: TypeFamilyHead -> Name +typeFamilyHeadName (TypeFamilyHead n _ _ _) = n + +-- | Desugar @Dec@s that can appear in a @let@ expression. See the +-- documentation for 'dsLetDec' for an explanation of what the return type +-- represents. +dsLetDecs :: DsMonad q => [Dec] -> q ([DLetDec], DExp -> DExp) +dsLetDecs decs = do + (let_decss, ip_binders) <- mapAndUnzipM dsLetDec decs + let let_decs :: [DLetDec] + let_decs = concat let_decss + + ip_binder :: DExp -> DExp + ip_binder = foldr (.) id ip_binders + return (let_decs, ip_binder) + +-- | Desugar a single 'Dec' that can appear in a @let@ expression. +-- This produces the following output: +-- +-- * One or more 'DLetDec's (a single 'Dec' can produce multiple 'DLetDec's +-- in the event of a value declaration that binds multiple things by way +-- of pattern matching. +-- +-- * A function of type @'DExp' -> 'DExp'@, which should be applied to the +-- expression immediately following the 'DLetDec's. This function prepends +-- binding forms for any implicit params that were bound in the argument +-- 'Dec'. (If no implicit params are bound, this is simply the 'id' +-- function.) +-- +-- For instance, if the argument to 'dsLetDec' is the @?x = 42@ part of this +-- expression: +-- +-- @ +-- let { ?x = 42 } in ?x +-- @ +-- +-- Then the output is: +-- +-- * @let new_x_val = 42@ +-- +-- * @\\z -> 'bindIP' \@\"x\" new_x_val z@ +-- +-- This way, the expression +-- @let { new_x_val = 42 } in 'bindIP' \@"x" new_x_val ('ip' \@\"x\")@ can be +-- formed. The implicit param binders always come after all the other +-- 'DLetDec's to support parallel assignment of implicit params. +dsLetDec :: DsMonad q => Dec -> q ([DLetDec], DExp -> DExp) +dsLetDec (FunD name clauses) = do + clauses' <- dsClauses (FunRhs name) clauses + return ([DFunD name clauses'], id) +dsLetDec (ValD pat body where_decs) = do + (pat', vars) <- dsPatX pat + body' <- dsBody body where_decs error_exp + let extras = uncurry (zipWith (DValD . DVarP)) $ unzip vars + return (DValD pat' body' : extras, id) + where + error_exp = mkErrorMatchExpr (LetDecRhs pat) +dsLetDec (SigD name ty) = do + ty' <- dsType ty + return ([DSigD name ty'], id) +#if __GLASGOW_HASKELL__ >= 909 +dsLetDec (InfixD fixity ns_spec name) = + return ([DInfixD fixity ns_spec name], id) +#else +dsLetDec (InfixD fixity name) = + return ([DInfixD fixity NoNamespaceSpecifier name], id) +#endif +dsLetDec (PragmaD prag) = do + prag' <- dsPragma prag + return ([DPragmaD prag'], id) +#if __GLASGOW_HASKELL__ >= 807 +dsLetDec (ImplicitParamBindD n e) = do + new_n_name <- qNewName $ "new_" ++ n ++ "_val" + e' <- dsExp e + let let_dec :: DLetDec + let_dec = DValD (DVarP new_n_name) e' + + ip_binder :: DExp -> DExp + ip_binder = (DVarE 'bindIP `DAppTypeE` + DLitT (StrTyLit n) `DAppE` + DVarE new_n_name `DAppE`) + return ([let_dec], ip_binder) +#endif +dsLetDec _dec = impossible "Illegal declaration in let expression." + +-- | Desugar a single 'Dec' corresponding to something that could appear after +-- the @let@ in a @let@ expression, but occurring at the top level. Because the +-- 'Dec' occurs at the top level, there is nothing that would correspond to the +-- @in ...@ part of the @let@ expression. As a consequence, this function does +-- not return a @'DExp' -> 'DExp'@ function corresonding to implicit param +-- binders (these cannot occur at the top level). +dsTopLevelLetDec :: DsMonad q => Dec -> q [DDec] +dsTopLevelLetDec = fmap (map DLetDec . fst) . dsLetDec + -- Note the use of fst above: we're silently throwing away any implicit param + -- binders that dsLetDec returns, since there is invariant that there will be + -- no implicit params in the first place. + +-- | Desugar a single @Con@. +-- +-- Because we always desugar @Con@s to GADT syntax (see the documentation for +-- 'DCon'), it is not always possible to desugar with just a 'Con' alone. +-- For instance, we must desugar: +-- +-- @ +-- data Foo a = forall b. MkFoo b +-- @ +-- +-- To this: +-- +-- @ +-- data Foo a :: Type where +-- MkFoo :: forall a b. b -> Foo a +-- @ +-- +-- If our only argument was @forall b. MkFoo b@, it would be somewhat awkward +-- to figure out (1) what the set of universally quantified type variables +-- (@[a]@) was, and (2) what the return type (@Foo a@) was. For this reason, +-- we require passing these as arguments. (If we desugar an actual GADT +-- constructor, these arguments are ignored.) +dsCon :: DsMonad q + => [DTyVarBndrSpec] -- ^ The universally quantified type variables + -- (used if desugaring a non-GADT constructor). + -> DType -- ^ The original data declaration's type + -- (used if desugaring a non-GADT constructor). + -> Con -> q [DCon] +dsCon univ_dtvbs data_type con = do + dcons' <- dsCon' con + return $ flip map dcons' $ \(n, dtvbs, dcxt, fields, m_gadt_type) -> + case m_gadt_type of + Nothing -> + let ex_dtvbs = dtvbs + expl_dtvbs = univ_dtvbs ++ ex_dtvbs + impl_dtvbs = changeDTVFlags SpecifiedSpec $ + toposortKindVarsOfTvbs expl_dtvbs in + DCon (impl_dtvbs ++ expl_dtvbs) dcxt n fields data_type + Just gadt_type -> + let univ_ex_dtvbs = dtvbs in + DCon univ_ex_dtvbs dcxt n fields gadt_type + +-- Desugar a Con in isolation. The meaning of the returned DTyVarBndrs changes +-- depending on what the returned Maybe DType value is: +-- +-- * If returning Just gadt_ty, then we've encountered a GadtC or RecGadtC, +-- so the returned DTyVarBndrs are both the universally and existentially +-- quantified tyvars. +-- * If returning Nothing, we're dealing with a non-GADT constructor, so +-- the returned DTyVarBndrs are the existentials only. +dsCon' :: DsMonad q + => Con -> q [(Name, [DTyVarBndrSpec], DCxt, DConFields, Maybe DType)] +dsCon' (NormalC n stys) = do + dtys <- mapM dsBangType stys + return [(n, [], [], DNormalC False dtys, Nothing)] +dsCon' (RecC n vstys) = do + vdtys <- mapM dsVarBangType vstys + return [(n, [], [], DRecC vdtys, Nothing)] +dsCon' (InfixC sty1 n sty2) = do + dty1 <- dsBangType sty1 + dty2 <- dsBangType sty2 + return [(n, [], [], DNormalC True [dty1, dty2], Nothing)] +dsCon' (ForallC tvbs cxt con) = do + dtvbs <- mapM dsTvbSpec tvbs + dcxt <- dsCxt cxt + dcons' <- dsCon' con + return $ flip map dcons' $ \(n, dtvbs', dcxt', fields, m_gadt_type) -> + (n, dtvbs ++ dtvbs', dcxt ++ dcxt', fields, m_gadt_type) +dsCon' (GadtC nms btys rty) = do + dbtys <- mapM dsBangType btys + drty <- dsType rty + sequence $ flip map nms $ \nm -> do + mbFi <- reifyFixityWithLocals nm + -- A GADT data constructor is declared infix when these three + -- properties hold: + let decInfix = isInfixDataCon (nameBase nm) -- 1. Its name uses operator syntax + -- (e.g., (:*:)) + && length dbtys == 2 -- 2. It has exactly two fields + && isJust mbFi -- 3. It has a programmer-specified + -- fixity declaration + return (nm, [], [], DNormalC decInfix dbtys, Just drty) +dsCon' (RecGadtC nms vbtys rty) = do + dvbtys <- mapM dsVarBangType vbtys + drty <- dsType rty + return $ flip map nms $ \nm -> + (nm, [], [], DRecC dvbtys, Just drty) + +-- | Desugar a @BangType@. +dsBangType :: DsMonad q => BangType -> q DBangType +dsBangType (b, ty) = (b, ) <$> dsType ty + +-- | Desugar a @VarBangType@. +dsVarBangType :: DsMonad q => VarBangType -> q DVarBangType +dsVarBangType (n, b, ty) = (n, b, ) <$> dsType ty + +-- | Desugar a @Foreign@. +dsForeign :: DsMonad q => Foreign -> q DForeign +dsForeign (ImportF cc safety str n ty) = DImportF cc safety str n <$> dsType ty +dsForeign (ExportF cc str n ty) = DExportF cc str n <$> dsType ty + +-- | Desugar a @Pragma@. +dsPragma :: DsMonad q => Pragma -> q DPragma +dsPragma (InlineP n inl rm phases) = return $ DInlineP n inl rm phases +dsPragma (SpecialiseP n ty m_inl phases) = DSpecialiseP n <$> dsType ty + <*> pure m_inl + <*> pure phases +dsPragma (SpecialiseInstP ty) = DSpecialiseInstP <$> dsType ty +#if __GLASGOW_HASKELL__ >= 807 +dsPragma (RuleP str mtvbs rbs lhs rhs phases) + = DRuleP str <$> mapM (mapM dsTvbUnit) mtvbs + <*> mapM dsRuleBndr rbs + <*> dsExp lhs + <*> dsExp rhs + <*> pure phases +#else +dsPragma (RuleP str rbs lhs rhs phases) = DRuleP str Nothing + <$> mapM dsRuleBndr rbs + <*> dsExp lhs + <*> dsExp rhs + <*> pure phases +#endif +dsPragma (AnnP target exp) = DAnnP target <$> dsExp exp +dsPragma (LineP n str) = return $ DLineP n str +#if __GLASGOW_HASKELL__ >= 801 +dsPragma (CompleteP cls mty) = return $ DCompleteP cls mty +#endif +#if __GLASGOW_HASKELL__ >= 903 +dsPragma (OpaqueP n) = return $ DOpaqueP n +#endif +#if __GLASGOW_HASKELL__ >= 909 +dsPragma (SCCP nm mstr) = return $ DSCCP nm mstr +#endif +#if __GLASGOW_HASKELL__ >= 913 +dsPragma (SpecialiseEP mTyBndrs tmBndrs specE mInline phases) = + DSpecialiseEP + <$> mapM (mapM dsTvbUnit) mTyBndrs + <*> mapM dsRuleBndr tmBndrs + <*> dsExp specE + <*> pure mInline + <*> pure phases +#endif + +-- | Desugar a @RuleBndr@. +dsRuleBndr :: DsMonad q => RuleBndr -> q DRuleBndr +dsRuleBndr (RuleVar n) = return $ DRuleVar n +dsRuleBndr (TypedRuleVar n ty) = DTypedRuleVar n <$> dsType ty + +#if __GLASGOW_HASKELL__ >= 807 +-- | Desugar a @TySynEqn@. (Available only with GHC 7.8+) +-- +-- This requires a 'Name' as an argument since 'TySynEqn's did not have +-- this information prior to GHC 8.8. +dsTySynEqn :: DsMonad q => Name -> TySynEqn -> q DTySynEqn +dsTySynEqn _ (TySynEqn mtvbs lhs rhs) = + DTySynEqn <$> mapM (mapM dsTvbUnit) mtvbs <*> dsType lhs <*> dsType rhs +#else +-- | Desugar a @TySynEqn@. (Available only with GHC 7.8+) +dsTySynEqn :: DsMonad q => Name -> TySynEqn -> q DTySynEqn +dsTySynEqn n (TySynEqn lhss rhs) = do + lhss' <- mapM dsType lhss + let lhs' = applyDType (DConT n) $ map DTANormal lhss' + DTySynEqn Nothing lhs' <$> dsType rhs +#endif + +-- | Desugar clauses to a function definition +dsClauses :: DsMonad q + => MatchContext -- ^ The context in which the clauses arise + -> [Clause] -- ^ Clauses to desugar + -> q [DClause] +dsClauses _ [] = return [] +-- Include a special case for guard-less clauses to make the desugared output +-- a little nicer. See Note [Desugaring clauses compactly (when possible)]. +dsClauses mc (Clause pats (NormalB exp) where_decs : rest) = do + rest' <- dsClauses mc rest + exp' <- dsExp exp + (where_decs', ip_binder) <- dsLetDecs where_decs + let exp_with_wheres = maybeDLetE where_decs' (ip_binder exp') + (pats', exp'') <- dsPatsOverExp pats exp_with_wheres + return $ DClause pats' exp'' : rest' +dsClauses mc clauses@(Clause outer_pats _ _ : _) = do + arg_names <- replicateM (length outer_pats) (newUniqueName "arg") + let scrutinees = map DVarE arg_names + clauses' <- foldrM (ds_clause scrutinees) [] clauses + pure [DClause (map DVarP arg_names) (dCasesE scrutinees clauses')] + where + ds_clause :: DsMonad q => [DExp] -> Clause -> [DClause] -> q [DClause] + ds_clause scrutinees (Clause pats body where_decs) failure_clauses = do + let failure_exp = maybeDCasesE mc scrutinees failure_clauses + exp <- dsBody body where_decs failure_exp + (pats', exp') <- dsPatsOverExp pats exp + -- incomplete attempt at #6 + uni_pats <- fmap getAll $ concatMapM (fmap All . isUniversalPattern) pats' + let clause = DClause pats' exp' + if uni_pats + then return [clause] + else return (clause : failure_clauses) + +-- | The context of a pattern match. This is used to produce +-- @Non-exhaustive patterns in...@ messages that are tailored to specific +-- situations. Compare this to GHC's @HsMatchContext@ data type +-- (https://gitlab.haskell.org/ghc/ghc/-/blob/81cf52bb301592ff3d043d03eb9a0d547891a3e1/compiler/Language/Haskell/Syntax/Expr.hs#L1662-1695), +-- from which the @MatchContext@ data type takes inspiration. +data MatchContext + = FunRhs Name + -- ^ A pattern matching on an argument of a function binding + | LetDecRhs Pat + -- ^ A pattern in a @let@ declaration + | RecUpd + -- ^ A record update + | MultiWayIfAlt + -- ^ Guards in a multi-way if alternative + | CaseAlt + -- ^ Patterns and guards in a case alternative + | LamCaseAlt LamCaseVariant + -- ^ Patterns and guards in @\\case@ and @\\cases@ + +-- | Which kind of lambda case are we dealing with? Compare this to GHC's +-- @LamCaseVariant@ data type +-- (https://gitlab.haskell.org/ghc/ghc/-/blob/81cf52bb301592ff3d043d03eb9a0d547891a3e1/compiler/Language/Haskell/Syntax/Expr.hs#L686-690) +-- from which we take inspiration. +data LamCaseVariant + = LamCase -- ^ @\\case@ + | LamCases -- ^ @\\cases@ + +-- | Construct an expression that throws an error when encountering a pattern +-- at runtime that is not covered by pattern matching. +mkErrorMatchExpr :: MatchContext -> DExp +mkErrorMatchExpr mc = + DAppE (DVarE 'error) (DLitE (StringL ("Non-exhaustive patterns in " ++ pp_context))) + where + pp_context = + case mc of + FunRhs n -> show n + LetDecRhs pat -> pprint pat + RecUpd -> "record update" + MultiWayIfAlt -> "multi-way if" + CaseAlt -> "case" + LamCaseAlt lv -> pp_lam_case_variant lv + + pp_lam_case_variant LamCase = "\\case" + pp_lam_case_variant LamCases = "\\cases" + +{- +Note [Desugaring clauses compactly (when possible)] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the general case, th-desugar's approach to desugaring clauses with guards +requires binding an extra variable. For example, consider this code: + + \case + A x | x == "hello" -> x + B y -> y + _ -> "" + +As part of desugaring, th-desugar will get rid of the guards by rewriting the +code to something that looks closer to this: + + \scrutinee -> + case scrutinee of + A x -> + if x == "hello" + then x + else case scrutinee of + B y -> y + _ -> "" + B y -> y + _ -> "" + +(The fully desugared output would then translate the lambda and `case` +expressions to `\cases` expressions, but let's put that aside for now. We'll +come back to this in a bit.) + +Note the `scrutinee` argument, which is now explicitly named. Binding the +argument to a name is important because we need to further match on it when the +`x == "hello"` guard fails to match. + +This approach gets the job done, but it does add a some amount of extra +clutter. We take steps to avoid this clutter where possible. Consider this +simpler example: + + \case + A x -> x + B y -> y + _ -> "" + +If we were to desugar this example using the same approach as above, we'd end +up with something like this: + + \scrutinee -> + case scrutinee of + A x -> x + B y -> y + _ -> "" + +Recall that th-desugar will desugar lambda and `case` expressions to `\cases` +exprressions. As such, the fully desugared output would be: + + \cases + scrutinee -> + (\cases + A x -> x + B y -> y + _ -> "") scrutinee + +This would technically work, but we would lose something along the way. By +using this approach, we would transform something with a single `\case` +expression to something with multiple `\cases` expressions. Moreover, the +original expression never needed to give a name to the `scrutinee` variable, so +it would be strange for the desugared output to require this extra clutter. + +Luckily, we can avoid the clutter by observing that the `scrutinee` variable +can be eta-contracted away. More generally, if a set of clauses does not use +any guards, then we don't bother explicitly binding a variable like +`scrutinee`, as we never need to use it outside of the initial matching. This +means that we can desugar the simpler example above to: + + \cases + (A x) -> x + (B y) -> y + _ -> "" + +Ahh. Much nicer. + +Of course, the flip side is that we /do/ need the extra `scrutinee` clutter +when desugaring clauses involving guards. Personally, I'm not too bothered by +this, as th-desugar's approach to desugaring guards already has various +limitations (see the "Known limitations" section of the th-desugar README). As +such, I'm not inclined to invest more effort into fixing this unless someone +explicitly asks for it. +-} + +-- | Desugar a type +dsType :: DsMonad q => Type -> q DType +#if __GLASGOW_HASKELL__ >= 900 +-- See Note [Gracefully handling linear types] +dsType (MulArrowT `AppT` _) = return DArrowT +dsType MulArrowT = fail "Cannot desugar exotic uses of linear types." +#endif +dsType (ForallT tvbs preds ty) = + mkDForallConstrainedT <$> (DForallInvis <$> mapM dsTvbSpec tvbs) + <*> dsCxt preds <*> dsType ty +dsType (AppT t1 t2) = DAppT <$> dsType t1 <*> dsType t2 +dsType (SigT ty ki) = DSigT <$> dsType ty <*> dsType ki +dsType (VarT name) = return $ DVarT name +dsType (ConT name) = return $ DConT name +-- The PromotedT case is identical to the ConT case above. +-- See Note [Desugaring promoted types]. +dsType (PromotedT name) = return $ DConT name +dsType (TupleT n) = return $ DConT (tupleTypeName n) +dsType (UnboxedTupleT n) = return $ DConT (unboxedTupleTypeName n) +dsType ArrowT = return DArrowT +dsType ListT = return $ DConT ''[] +dsType (PromotedTupleT n) = return $ DConT (tupleDataName n) +dsType PromotedNilT = return $ DConT '[] +dsType PromotedConsT = return $ DConT '(:) +dsType StarT = return $ DConT typeKindName +dsType ConstraintT = return $ DConT ''Constraint +dsType (LitT lit) = return $ DLitT lit +dsType EqualityT = return $ DConT ''(~) +dsType (InfixT t1 n t2) = dsInfixT t1 n t2 +dsType (UInfixT{}) = dsUInfixT +dsType (ParensT t) = dsType t +dsType WildCardT = return DWildCardT +#if __GLASGOW_HASKELL__ >= 801 +dsType (UnboxedSumT arity) = return $ DConT (unboxedSumTypeName arity) +#endif +#if __GLASGOW_HASKELL__ >= 807 +dsType (AppKindT t k) = DAppKindT <$> dsType t <*> dsType k +dsType (ImplicitParamT n t) = do + t' <- dsType t + return $ DConT ''IP `DAppT` DLitT (StrTyLit n) `DAppT` t' +#endif +#if __GLASGOW_HASKELL__ >= 809 +dsType (ForallVisT tvbs ty) = + DForallT <$> (DForallVis <$> mapM dsTvbUnit tvbs) <*> dsType ty +#endif +#if __GLASGOW_HASKELL__ >= 903 +-- The PromotedInfixT case is identical to the InfixT case above. +-- See Note [Desugaring promoted types]. +dsType (PromotedInfixT t1 n t2) = dsInfixT t1 n t2 +dsType PromotedUInfixT{} = dsUInfixT +#endif + +#if __GLASGOW_HASKELL__ >= 900 +-- | Desugar a 'TyVarBndr'. +dsTvb :: DsMonad q => TyVarBndr_ flag -> q (DTyVarBndr flag) +dsTvb (PlainTV n flag) = return $ DPlainTV n flag +dsTvb (KindedTV n flag k) = DKindedTV n flag <$> dsType k +#else +-- | Desugar a 'TyVarBndr' with a particular @flag@. +dsTvb :: DsMonad q => flag -> TyVarBndr -> q (DTyVarBndr flag) +dsTvb flag (PlainTV n) = return $ DPlainTV n flag +dsTvb flag (KindedTV n k) = DKindedTV n flag <$> dsType k +#endif + +{- +Note [Gracefully handling linear types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Per the README, th-desugar does not currently support linear types. +Unfortunately, we cannot simply reject all occurrences of +multiplicity-polymorphic function arrows (i.e., MulArrowT), as it is possible +for "non-linear" code to contain them when reified. For example, the type of a +Haskell98 data constructor such as `Just` will be reified as + + a #-> Maybe a + +In terms of the TH AST, that is: + + MulArrowT `AppT` PromotedConT 'One `AppT` VarT a `AppT` (ConT ''Maybe `AppT` VarT a) + +Therefore, in order to desugar these sorts of types, we have to do *something* +with MulArrowT. The approach that th-desugar takes is to pretend that all +multiplicity-polymorphic function arrows are actually ordinary function arrows +(->) when desugaring types. In other words, whenever th-desugar sees +(MulArrowT `AppT` m), for any particular value of `m`, it will turn it into +DArrowT. + +This approach is enough to gracefully handle most uses of MulArrowT, as TH +reification always generates MulArrowT applied to some particular multiplicity +(as of GHC 9.0, at least). It's conceivable that some wily user could manually +construct a TH AST containing MulArrowT in a different position, but since this +situation is rare, we simply throw an error in such cases. + +We adopt a similar stance in L.H.TH.Desugar.Reify when locally reifying the +types of data constructors: since th-desugar doesn't currently support linear +types, we pretend as if MulArrowT does not exist. As a result, the type of +`Just` would be locally reified as `a -> Maybe a`, not `a #-> Maybe a`. + +Note [Desugaring promoted types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +ConT and PromotedT both contain Names as a payload, the only difference being +that PromotedT is intended to refer exclusively to promoted data constructor +Names, while ConT can refer to both type and data constructor Names alike. + +When desugaring a PromotedT, we make the assumption that the TH quoting +mechanism produced the correct Name and wrap the name in a DConT. In other +words, we desugar ConT and PromotedT identically. This assumption about +PromotedT may not always be correct, however. Consider this example: + + data a :+: b = Inl a | Inr b + data Exp a = ... | Exp :+: Exp + +How should `PromotedT (mkName ":+:")` be desugared? Morally, it ought to be +desugared to a DConT that contains (:+:) the data constructor, not (:+:) the +type constructor. Deciding between the two is not always straightforward, +however. We could use the `lookupDataName` function to try and distinguish +between the two Names, but this may not necessarily work. This is because the +Name passed to `lookupDataName` could have its original module attached, which +may not be in scope. + +Long story short: we make things simple (albeit slightly wrong) by desugaring +ConT and PromotedT identically. We'll wait for someone to complain about the +wrongness of this approach before researching a more accurate solution. + +Note that the same considerations also apply to InfixT and PromotedInfixT, +which are also desugared identically. +-} + +-- | Desugar an infix 'Type'. +dsInfixT :: DsMonad q => Type -> Name -> Type -> q DType +dsInfixT t1 n t2 = DAppT <$> (DAppT (DConT n) <$> dsType t1) <*> dsType t2 + +-- | We cannot desugar unresolved infix operators, so fail if we encounter one. +dsUInfixT :: Fail.MonadFail m => m a +dsUInfixT = fail "Cannot desugar unresolved infix operators." + +-- | Desugar a 'TyVarBndrSpec'. +dsTvbSpec :: DsMonad q => TyVarBndrSpec -> q DTyVarBndrSpec +#if __GLASGOW_HASKELL__ >= 900 +dsTvbSpec = dsTvb +#else +dsTvbSpec = dsTvb SpecifiedSpec +#endif + +-- | Desugar a 'TyVarBndrUnit'. +dsTvbUnit :: DsMonad q => TyVarBndrUnit -> q DTyVarBndrUnit +#if __GLASGOW_HASKELL__ >= 900 +dsTvbUnit = dsTvb +#else +dsTvbUnit = dsTvb () +#endif + +-- | Desugar a 'TyVarBndrVis'. +dsTvbVis :: DsMonad q => TyVarBndrVis -> q DTyVarBndrVis +#if __GLASGOW_HASKELL__ >= 900 +dsTvbVis = dsTvb +#else +dsTvbVis = dsTvb BndrReq +#endif + +-- | Desugar a @Cxt@ +dsCxt :: DsMonad q => Cxt -> q DCxt +dsCxt = concatMapM dsPred + +#if __GLASGOW_HASKELL__ >= 801 +-- | A backwards-compatible type synonym for the thing representing a single +-- derived class in a @deriving@ clause. (This is a @DerivClause@, @Pred@, or +-- @Name@ depending on the GHC version.) +type DerivingClause = DerivClause + +-- | Desugar a @DerivingClause@. +dsDerivClause :: DsMonad q => DerivingClause -> q DDerivClause +dsDerivClause (DerivClause mds cxt) = + DDerivClause <$> mapM dsDerivStrategy mds <*> dsCxt cxt +#else +type DerivingClause = Pred + +dsDerivClause :: DsMonad q => DerivingClause -> q DDerivClause +dsDerivClause p = DDerivClause Nothing <$> dsPred p +#endif + +#if __GLASGOW_HASKELL__ >= 801 +-- | Desugar a @DerivStrategy@. +dsDerivStrategy :: DsMonad q => DerivStrategy -> q DDerivStrategy +dsDerivStrategy StockStrategy = pure DStockStrategy +dsDerivStrategy AnyclassStrategy = pure DAnyclassStrategy +dsDerivStrategy NewtypeStrategy = pure DNewtypeStrategy +#if __GLASGOW_HASKELL__ >= 805 +dsDerivStrategy (ViaStrategy ty) = DViaStrategy <$> dsType ty +#endif +#endif + +#if __GLASGOW_HASKELL__ >= 801 +-- | Desugar a @PatSynDir@. (Available only with GHC 8.2+) +dsPatSynDir :: DsMonad q => Name -> PatSynDir -> q DPatSynDir +dsPatSynDir _ Unidir = pure DUnidir +dsPatSynDir _ ImplBidir = pure DImplBidir +dsPatSynDir n (ExplBidir clauses) = DExplBidir <$> dsClauses (FunRhs n) clauses +#endif + +-- | Desugar a @Pred@, flattening any internal tuples +dsPred :: DsMonad q => Pred -> q DCxt +dsPred t + | Just ts <- splitTuple_maybe t + = concatMapM dsPred ts +dsPred (ForallT tvbs cxt p) = dsForallPred tvbs cxt p +dsPred (AppT t1 t2) = do + [p1] <- dsPred t1 -- tuples can't be applied! + (:[]) <$> DAppT p1 <$> dsType t2 +dsPred (SigT ty ki) = do + preds <- dsPred ty + case preds of + [p] -> (:[]) <$> DSigT p <$> dsType ki + other -> return other -- just drop the kind signature on a tuple. +dsPred (VarT n) = return [DVarT n] +dsPred (ConT n) = return [DConT n] +dsPred t@(PromotedT _) = + impossible $ "Promoted type seen as head of constraint: " ++ show t +dsPred (TupleT 0) = return [DConT (tupleTypeName 0)] +dsPred (TupleT _) = + impossible "Internal error in th-desugar in detecting tuple constraints." +dsPred t@(UnboxedTupleT _) = + impossible $ "Unboxed tuple seen as head of constraint: " ++ show t +dsPred ArrowT = impossible "Arrow seen as head of constraint." +dsPred ListT = impossible "List seen as head of constraint." +dsPred (PromotedTupleT _) = + impossible "Promoted tuple seen as head of constraint." +dsPred PromotedNilT = impossible "Promoted nil seen as head of constraint." +dsPred PromotedConsT = impossible "Promoted cons seen as head of constraint." +dsPred StarT = impossible "* seen as head of constraint." +dsPred ConstraintT = + impossible "The kind `Constraint' seen as head of constraint." +dsPred t@(LitT _) = + impossible $ "Type literal seen as head of constraint: " ++ show t +dsPred EqualityT = return [DConT ''(~)] +dsPred (InfixT t1 n t2) = (:[]) <$> dsInfixT t1 n t2 +dsPred (UInfixT{}) = dsUInfixT +dsPred (ParensT t) = dsPred t +dsPred WildCardT = return [DWildCardT] +#if __GLASGOW_HASKELL__ >= 801 +dsPred t@(UnboxedSumT {}) = + impossible $ "Unboxed sum seen as head of constraint: " ++ show t +#endif +#if __GLASGOW_HASKELL__ >= 807 +dsPred (AppKindT t k) = do + [p] <- dsPred t + (:[]) <$> (DAppKindT p <$> dsType k) +dsPred (ImplicitParamT n t) = do + t' <- dsType t + return [DConT ''IP `DAppT` DLitT (StrTyLit n) `DAppT` t'] +#endif +#if __GLASGOW_HASKELL__ >= 809 +dsPred t@(ForallVisT {}) = + impossible $ "Visible dependent quantifier seen as head of constraint: " ++ show t +#endif +#if __GLASGOW_HASKELL__ >= 900 +dsPred MulArrowT = impossible "Linear arrow seen as head of constraint." +#endif +#if __GLASGOW_HASKELL__ >= 903 +dsPred t@PromotedInfixT{} = + impossible $ "Promoted infix type seen as head of constraint: " ++ show t +dsPred PromotedUInfixT{} = dsUInfixT +#endif + +-- | Desugar a quantified constraint. +dsForallPred :: DsMonad q => [TyVarBndrSpec] -> Cxt -> Pred -> q DCxt +dsForallPred tvbs cxt p = do + ps' <- dsPred p + case ps' of + [p'] -> (:[]) <$> (mkDForallConstrainedT <$> + (DForallInvis <$> mapM dsTvbSpec tvbs) <*> dsCxt cxt <*> pure p') + _ -> fail "Cannot desugar constraint tuples in the body of a quantified constraint" + -- See GHC #15334. + +-- | Like 'reify', but safer and desugared. Uses local declarations where +-- available. +dsReify :: DsMonad q => Name -> q (Maybe DInfo) +dsReify = traverse dsInfo <=< reifyWithLocals_maybe + +-- | Like 'reifyType', but safer and desugared. Uses local declarations where +-- available. +dsReifyType :: DsMonad q => Name -> q (Maybe DType) +dsReifyType = traverse dsType <=< reifyTypeWithLocals_maybe + +-- Given a list of `forall`ed type variable binders and a context, construct +-- a DType using DForallT and DConstrainedT as appropriate. The phrase +-- "as appropriate" is used because DConstrainedT will not be used if the +-- context is empty, per Note [Desugaring and sweetening ForallT]. +mkDForallConstrainedT :: DForallTelescope -> DCxt -> DType -> DType +mkDForallConstrainedT tele ctxt ty = + DForallT tele $ if null ctxt then ty else DConstrainedT ctxt ty + +-- create a list of expressions in the same order as the fields in the first argument +-- but with the values as given in the second argument +-- if a field is missing from the second argument, use the corresponding expression +-- from the third argument +reorderFields :: DsMonad q => Name -> [VarStrictType] -> [FieldExp] -> [DExp] -> q [DExp] +reorderFields = reorderFields' dsExp + +reorderFieldsPat :: DsMonad q => Name -> [VarStrictType] -> [FieldPat] -> PatM q [DPat] +reorderFieldsPat con_name field_decs field_pats = + reorderFields' dsPat con_name field_decs field_pats (repeat DWildP) + +reorderFields' :: (Applicative m, Fail.MonadFail m) + => (a -> m da) + -> Name -- ^ The name of the constructor (used for error reporting) + -> [VarStrictType] -> [(Name, a)] + -> [da] -> m [da] +reorderFields' ds_thing con_name field_names_types field_things deflts = + check_valid_fields >> reorder field_names deflts + where + field_names = map (\(a, _, _) -> a) field_names_types + + check_valid_fields = + forM_ field_things $ \(thing_name, _) -> + unless (thing_name `elem` field_names) $ + fail $ "Constructor ‘" ++ nameBase con_name ++ "‘ does not have field ‘" + ++ nameBase thing_name ++ "‘" + + reorder [] _ = return [] + reorder (field_name : rest) (deflt : rest_deflt) = do + rest' <- reorder rest rest_deflt + case find (\(thing_name, _) -> thing_name == field_name) field_things of + Just (_, thing) -> (: rest') <$> ds_thing thing + Nothing -> return $ deflt : rest' + reorder (_ : _) [] = error "Internal error in th-desugar." + +-- mkTupleDExp and friends construct tuples, avoiding the use of 1-tuples. These +-- are used to create auxiliary tuple values when desugaring ParallelListComp +-- expressions (see the Haddocks for dsParComp) and when match-flattening lazy +-- patterns (see the Haddocks for mkSelectorDecs in L.H.TH.Desugar.Match). + +-- | Make a tuple 'DExp' from a list of 'DExp's. Avoids using a 1-tuple. +mkTupleDExp :: [DExp] -> DExp +mkTupleDExp [exp] = exp +mkTupleDExp exps = foldl DAppE (DConE $ tupleDataName (length exps)) exps + +-- | Make a tuple 'Exp' from a list of 'Exp's. Avoids using a 1-tuple. +mkTupleExp :: [Exp] -> Exp +mkTupleExp [exp] = exp +mkTupleExp exps = foldl AppE (ConE $ tupleDataName (length exps)) exps + +-- | Make a tuple 'DPat' from a list of 'DPat's. Avoids using a 1-tuple. +mkTupleDPat :: [DPat] -> DPat +mkTupleDPat [pat] = pat +mkTupleDPat pats = DConP (tupleDataName (length pats)) [] pats + +-- | Make a tuple 'DType' from a list of 'DType's. Avoids using a 1-tuple. +mkTupleDType :: [DType] -> DType +mkTupleDType [ty] = ty +mkTupleDType tys = foldl DAppT (DConT $ tupleTypeName (length tys)) tys + +-- | Is this pattern guaranteed to match? +isUniversalPattern :: DsMonad q => DPat -> q Bool +isUniversalPattern (DLitP {}) = return False +isUniversalPattern (DVarP {}) = return True +isUniversalPattern (DConP con_name _ pats) = do + data_name <- dataConNameToDataName con_name + (_df, _tvbs, cons) <- getDataD "Internal error." data_name + if length cons == 1 + then fmap and $ mapM isUniversalPattern pats + else return False +isUniversalPattern (DTildeP {}) = return True +isUniversalPattern (DBangP pat) = isUniversalPattern pat +isUniversalPattern (DSigP pat _) = isUniversalPattern pat +isUniversalPattern DWildP = return True +isUniversalPattern (DTypeP _) = return True +isUniversalPattern (DInvisP _) = return True + +-- | Apply one 'DExp' to a list of arguments +applyDExp :: DExp -> [DExp] -> DExp +applyDExp = foldl DAppE + +-- | Apply one 'DType' to a list of arguments +applyDType :: DType -> [DTypeArg] -> DType +applyDType = foldl apply + where + apply :: DType -> DTypeArg -> DType + apply f (DTANormal x) = f `DAppT` x + apply f (DTyArg x) = f `DAppKindT` x + +-- | An argument to a type, either a normal type ('DTANormal') or a visible +-- kind application ('DTyArg'). +-- +-- 'DTypeArg' does not appear directly in the @th-desugar@ AST, but it is +-- useful when decomposing an application of a 'DType' to its arguments. +data DTypeArg + = DTANormal DType + | DTyArg DKind + deriving (Eq, Show, Data, Generic) + +-- | Desugar a 'TypeArg'. +dsTypeArg :: DsMonad q => TypeArg -> q DTypeArg +dsTypeArg (TANormal t) = DTANormal <$> dsType t +dsTypeArg (TyArg k) = DTyArg <$> dsType k + +-- | Filter the normal type arguments from a list of 'DTypeArg's. +filterDTANormals :: [DTypeArg] -> [DType] +filterDTANormals = mapMaybe getDTANormal + where + getDTANormal :: DTypeArg -> Maybe DType + getDTANormal (DTANormal t) = Just t + getDTANormal (DTyArg {}) = Nothing + +-- | Convert a 'DTyVarBndr' into a 'DType' +dTyVarBndrToDType :: DTyVarBndr flag -> DType +dTyVarBndrToDType (DPlainTV a _) = DVarT a +dTyVarBndrToDType (DKindedTV a _ k) = DVarT a `DSigT` k + +-- | Convert a 'DTyVarBndrVis' to a 'DTypeArg'. That is, convert a binder with a +-- 'BndrReq' visibility to a 'DTANormal' and a binder with 'BndrInvis' +-- visibility to a 'DTyArg'. +-- +-- If given a 'DKindedTV', the resulting 'DTypeArg' will omit the kind +-- signature. Use 'dTyVarBndrVisToDTypeArgWithSig' if you want to preserve the +-- kind signature. +dTyVarBndrVisToDTypeArg :: DTyVarBndrVis -> DTypeArg +dTyVarBndrVisToDTypeArg bndr = + case dtvbFlag bndr of + BndrReq -> DTANormal bndr_ty + BndrInvis -> DTyArg bndr_ty + where + bndr_ty = case bndr of + DPlainTV a _ -> DVarT a + DKindedTV a _ _ -> DVarT a + +-- | Convert a 'DTyVarBndrVis' to a 'DTypeArg'. That is, convert a binder with a +-- 'BndrReq' visibility to a 'DTANormal' and a binder with 'BndrInvis' +-- visibility to a 'DTyArg'. +-- +-- If given a 'DKindedTV', the resulting 'DTypeArg' will preserve the kind +-- signature. Use 'dTyVarBndrVisToDTypeArg' if you want to omit the kind +-- signature. +dTyVarBndrVisToDTypeArgWithSig :: DTyVarBndrVis -> DTypeArg +dTyVarBndrVisToDTypeArgWithSig bndr = + case dtvbFlag bndr of + BndrReq -> DTANormal bndr_ty + BndrInvis -> DTyArg bndr_ty + where + bndr_ty = dTyVarBndrToDType bndr + +-- | Extract the underlying 'DType' or 'DKind' from a 'DTypeArg'. This forgets +-- information about whether a type is a normal argument or not, so use with +-- caution. +probablyWrongUnDTypeArg :: DTypeArg -> DType +probablyWrongUnDTypeArg (DTANormal t) = t +probablyWrongUnDTypeArg (DTyArg k) = k + +-- Take a data type name (which does not belong to a data family) and +-- apply it to its type variable binders to form a DType. +nonFamilyDataReturnType :: Name -> [DTyVarBndrVis] -> DType +nonFamilyDataReturnType con_name = + applyDType (DConT con_name) . map dTyVarBndrVisToDTypeArg + +-- Take a data family name and apply it to its argument types to form a +-- data family instance DType. +dataFamInstReturnType :: Name -> [DTypeArg] -> DType +dataFamInstReturnType fam_name = applyDType (DConT fam_name) + +-- Data family instance declarations did not come equipped with a list of bound +-- type variables until GHC 8.8 (and even then, it's optional whether the user +-- provides them or not). This means that there are situations where we must +-- reverse engineer this information ourselves from the list of type +-- arguments. We accomplish this by taking the free variables of the types +-- and performing a reverse topological sort on them to ensure that the +-- returned list is well scoped. +dataFamInstTvbs :: [DTypeArg] -> [DTyVarBndrUnit] +dataFamInstTvbs = toposortTyVarsOf . map probablyWrongUnDTypeArg + +-- | Take a list of 'DType's, find their free variables, and sort them in +-- reverse topological order to ensure that they are well scoped. In other +-- words, the free variables are ordered such that: +-- +-- 1. Whenever an explicit kind signature of the form @(A :: K)@ is +-- encountered, the free variables of @K@ will always appear to the left of +-- the free variables of @A@ in the returned result. +-- +-- 2. The constraint in (1) notwithstanding, free variables will appear in +-- left-to-right order of their original appearance. +-- +-- On older GHCs, this takes measures to avoid returning explicitly bound +-- kind variables, which was not possible before @TypeInType@. +toposortTyVarsOf :: [DType] -> [DTyVarBndrUnit] +toposortTyVarsOf tys = + let freeVars :: [Name] + freeVars = F.toList $ foldMap fvDType tys + + varKindSigs :: Map Name DKind + varKindSigs = foldMap go_ty tys + where + go_ty :: DType -> Map Name DKind + go_ty (DForallT tele t) = go_tele tele (go_ty t) + go_ty (DConstrainedT ctxt t) = foldMap go_ty ctxt `mappend` go_ty t + go_ty (DAppT t1 t2) = go_ty t1 `mappend` go_ty t2 + go_ty (DAppKindT t k) = go_ty t `mappend` go_ty k + go_ty (DSigT t k) = + let kSigs = go_ty k + in case t of + DVarT n -> M.insert n k kSigs + _ -> go_ty t `mappend` kSigs + go_ty (DVarT {}) = mempty + go_ty (DConT {}) = mempty + go_ty DArrowT = mempty + go_ty (DLitT {}) = mempty + go_ty DWildCardT = mempty + + go_tele :: DForallTelescope -> Map Name DKind -> Map Name DKind + go_tele (DForallVis tvbs) = go_tvbs tvbs + go_tele (DForallInvis tvbs) = go_tvbs tvbs + + go_tvbs :: [DTyVarBndr flag] -> Map Name DKind -> Map Name DKind + go_tvbs tvbs m = foldr go_tvb m tvbs + + go_tvb :: DTyVarBndr flag -> Map Name DKind -> Map Name DKind + go_tvb (DPlainTV n _) m = M.delete n m + go_tvb (DKindedTV n _ k) m = M.delete n m `mappend` go_ty k + + -- | Do a topological sort on a list of tyvars, + -- so that binders occur before occurrences + -- E.g. given [ a::k, k::*, b::k ] + -- it'll return a well-scoped list [ k::*, a::k, b::k ] + -- + -- This is a deterministic sorting operation + -- (that is, doesn't depend on Uniques). + -- + -- It is also meant to be stable: that is, variables should not + -- be reordered unnecessarily. + scopedSort :: [Name] -> [Name] + scopedSort = go [] [] + + go :: [Name] -- already sorted, in reverse order + -> [Set Name] -- each set contains all the variables which must be placed + -- before the tv corresponding to the set; they are accumulations + -- of the fvs in the sorted tvs' kinds + + -- This list is in 1-to-1 correspondence with the sorted tyvars + -- INVARIANT: + -- all (\tl -> all (`isSubsetOf` head tl) (tail tl)) (tails fv_list) + -- That is, each set in the list is a superset of all later sets. + -> [Name] -- yet to be sorted + -> [Name] + go acc _fv_list [] = reverse acc + go acc fv_list (tv:tvs) + = go acc' fv_list' tvs + where + (acc', fv_list') = insert tv acc fv_list + + insert :: Name -- var to insert + -> [Name] -- sorted list, in reverse order + -> [Set Name] -- list of fvs, as above + -> ([Name], [Set Name]) -- augmented lists + insert tv [] [] = ([tv], [kindFVSet tv]) + insert tv (a:as) (fvs:fvss) + | tv `S.member` fvs + , (as', fvss') <- insert tv as fvss + = (a:as', fvs `S.union` fv_tv : fvss') + + | otherwise + = (tv:a:as, fvs `S.union` fv_tv : fvs : fvss) + where + fv_tv = kindFVSet tv + + -- lists not in correspondence + insert _ _ _ = error "scopedSort" + + kindFVSet n = + maybe S.empty (OS.toSet . fvDType) + (M.lookup n varKindSigs) + ascribeWithKind n = + maybe (DPlainTV n ()) (DKindedTV n ()) (M.lookup n varKindSigs) + + in map ascribeWithKind $ + scopedSort freeVars + +-- | Take a telescope of 'DTyVarBndr's, find the free variables in their kinds, +-- and sort them in reverse topological order to ensure that they are well +-- scoped. Because the argument list is assumed to be telescoping, kind +-- variables that are bound earlier in the list are not returned. For example, +-- this: +-- +-- @ +-- 'toposortKindVarsOfTvbs' [a :: k, b :: Proxy a] +-- @ +-- +-- Will return @[k]@, not @[k, a]@, since @a@ is bound earlier by @a :: k@. +toposortKindVarsOfTvbs :: [DTyVarBndr flag] -> [DTyVarBndrUnit] +toposortKindVarsOfTvbs tvbs = + foldr (\tvb kvs -> + foldMap (\t -> toposortTyVarsOf [t]) (extractTvbKind tvb) `L.union` + L.deleteBy ((==) `on` dtvbName) tvb kvs) + [] + (changeDTVFlags () tvbs) + +dtvbName :: DTyVarBndr flag -> Name +dtvbName (DPlainTV n _) = n +dtvbName (DKindedTV n _ _) = n + +dtvbFlag :: DTyVarBndr flag -> flag +dtvbFlag (DPlainTV _ flag) = flag +dtvbFlag (DKindedTV _ flag _) = flag + +-- | Map over the 'Name' of a 'DTyVarBndr'. +mapDTVName :: (Name -> Name) -> DTyVarBndr flag -> DTyVarBndr flag +mapDTVName f (DPlainTV name flag) = DPlainTV (f name) flag +mapDTVName f (DKindedTV name flag kind) = DKindedTV (f name) flag kind + +-- | Map over the 'DKind' of a 'DTyVarBndr'. +mapDTVKind :: (DKind -> DKind) -> DTyVarBndr flag -> DTyVarBndr flag +mapDTVKind _ tvb@(DPlainTV{}) = tvb +mapDTVKind f (DKindedTV name flag kind) = DKindedTV name flag (f kind) + +-- @mk_qual_do_name mb_mod orig_name@ will simply return @orig_name@ if +-- @mb_mod@ is Nothing. If @mb_mod@ is @Just mod_@, then a new 'Name' will be +-- returned that uses @mod_@ as the new module prefix. This is useful for +-- emulating the behavior of the @QualifiedDo@ extension, which adds module +-- prefixes to functions such as ('>>=') and ('>>'). +mk_qual_do_name :: Maybe ModName -> Name -> Name +mk_qual_do_name mb_mod orig_name = case mb_mod of + Nothing -> orig_name + Just mod_ -> Name (OccName (nameBase orig_name)) (NameQ mod_) + +-- | Reconstruct an arrow 'DType' from its argument and result types. +ravelDType :: DFunArgs -> DType -> DType +ravelDType DFANil res = res +ravelDType (DFAForalls tele args) res = DForallT tele (ravelDType args res) +ravelDType (DFACxt cxt args) res = DConstrainedT cxt (ravelDType args res) +ravelDType (DFAAnon t args) res = DAppT (DAppT DArrowT t) (ravelDType args res) + +-- | Decompose a function 'DType' into its arguments (the 'DFunArgs') and its +-- result type (the 'DType). +unravelDType :: DType -> (DFunArgs, DType) +unravelDType (DForallT tele ty) = + let (args, res) = unravelDType ty in + (DFAForalls tele args, res) +unravelDType (DConstrainedT cxt ty) = + let (args, res) = unravelDType ty in + (DFACxt cxt args, res) +unravelDType (DAppT (DAppT DArrowT t1) t2) = + let (args, res) = unravelDType t2 in + (DFAAnon t1 args, res) +unravelDType t = (DFANil, t) + +-- | The list of arguments in a function 'DType'. +data DFunArgs + = DFANil + -- ^ No more arguments. + | DFAForalls DForallTelescope DFunArgs + -- ^ A series of @forall@ed type variables followed by a dot (if + -- 'ForallInvis') or an arrow (if 'ForallVis'). For example, + -- the type variables @a1 ... an@ in @forall a1 ... an. r@. + | DFACxt DCxt DFunArgs + -- ^ A series of constraint arguments followed by @=>@. For example, + -- the @(c1, ..., cn)@ in @(c1, ..., cn) => r@. + | DFAAnon DType DFunArgs + -- ^ An anonymous argument followed by an arrow. For example, the @a@ + -- in @a -> r@. + deriving (Eq, Show, Data, Generic) + +-- | A /visible/ function argument type (i.e., one that must be supplied +-- explicitly in the source code). This is in contrast to /invisible/ +-- arguments (e.g., the @c@ in @c => r@), which are instantiated without +-- the need for explicit user input. +data DVisFunArg + = DVisFADep DTyVarBndrUnit + -- ^ A visible @forall@ (e.g., @forall a -> a@). + | DVisFAAnon DType + -- ^ An anonymous argument followed by an arrow (e.g., @a -> r@). + deriving (Eq, Show, Data, Generic) + +-- | Filter the visible function arguments from a list of 'DFunArgs'. +filterDVisFunArgs :: DFunArgs -> [DVisFunArg] +filterDVisFunArgs DFANil = [] +filterDVisFunArgs (DFAForalls tele args) = + case tele of + DForallVis tvbs -> map DVisFADep tvbs ++ args' + DForallInvis _ -> args' + where + args' = filterDVisFunArgs args +filterDVisFunArgs (DFACxt _ args) = + filterDVisFunArgs args +filterDVisFunArgs (DFAAnon t args) = + DVisFAAnon t:filterDVisFunArgs args + +-- | Decompose an applied type into its individual components. For example, this: +-- +-- @ +-- Proxy \@Type Char +-- @ +-- +-- would be unfolded to this: +-- +-- @ +-- ('DConT' ''Proxy, ['DTyArg' ('DConT' ''Type), 'DTANormal' ('DConT' ''Char)]) +-- @ +unfoldDType :: DType -> (DType, [DTypeArg]) +unfoldDType = go [] + where + go :: [DTypeArg] -> DType -> (DType, [DTypeArg]) + go acc (DForallT _ ty) = go acc ty + go acc (DAppT ty1 ty2) = go (DTANormal ty2:acc) ty1 + go acc (DAppKindT ty ki) = go (DTyArg ki:acc) ty + go acc (DSigT ty _) = go acc ty + go acc ty = (ty, acc) + +-- | Extract the kind from a 'DTyVarBndr', if one is present. +extractTvbKind :: DTyVarBndr flag -> Maybe DKind +extractTvbKind (DPlainTV _ _) = Nothing +extractTvbKind (DKindedTV _ _ k) = Just k + +-- | Set the flag in a list of 'DTyVarBndr's. This is often useful in contexts +-- where one needs to re-use a list of 'DTyVarBndr's from one flag setting to +-- another flag setting. For example, in order to re-use the 'DTyVarBndr's bound +-- by a 'DDataD' in a 'DForallT', one can do the following: +-- +-- @ +-- case x of +-- 'DDataD' _ _ _ tvbs _ _ _ -> +-- 'DForallT' ('DForallInvis' ('changeDTVFlags' 'SpecifiedSpec' tvbs)) ... +-- @ +changeDTVFlags :: newFlag -> [DTyVarBndr oldFlag] -> [DTyVarBndr newFlag] +changeDTVFlags new_flag = map (new_flag <$) + +-- @'dMatchUpSAKWithDecl' decl_sak decl_bndrs@ produces @'DTyVarBndr' +-- 'ForAllTyFlag'@s for a declaration, using the original declaration's +-- standalone kind signature (@decl_sak@) and its user-written binders +-- (@decl_bndrs@) as a template. For this example: +-- +-- @ +-- type D :: forall j k. k -> j -> Type +-- data D \@j \@l (a :: l) b = ... +-- @ +-- +-- We would produce the following @'DTyVarBndr' 'ForAllTyFlag'@s: +-- +-- @ +-- \@j \@l (a :: l) (b :: j) +-- @ +-- +-- From here, these @'DTyVarBndr' 'ForAllTyFlag'@s can be converted into other +-- forms of 'DTyVarBndr's: +-- +-- * They can be converted to 'DTyVarBndrSpec's using 'dtvbForAllTyFlagsToSpecs'. +-- +-- * They can be converted to 'DTyVarBndrVis'es using 'tvbForAllTyFlagsToVis'. +-- +-- Note that: +-- +-- * This function has a precondition that the length of @decl_bndrs@ must +-- always be equal to the number of visible quantifiers (i.e., the number of +-- function arrows plus the number of visible @forall@–bound variables) in +-- @decl_sak@. +-- +-- * Whenever possible, this function reuses type variable names from the +-- declaration's user-written binders. This is why the @'DTyVarBndr' +-- 'ForAllTyFlag'@ use @\@j \@l@ instead of @\@j \@k@, since the @(a :: l)@ +-- binder uses @l@ instead of @k@. We could have just as well chose the other +-- way around, but we chose to pick variable names from the user-written +-- binders since they scope over other parts of the declaration. (For example, +-- the user-written binders of a @data@ declaration scope over the type +-- variables mentioned in a @deriving@ clause.) As such, keeping these names +-- avoids having to perform some alpha-renaming. +-- +-- This function's implementation was heavily inspired by parts of GHC's +-- kcCheckDeclHeader_sig function: +-- https://gitlab.haskell.org/ghc/ghc/-/blob/1464a2a8de082f66ae250d63ab9d94dbe2ef8620/compiler/GHC/Tc/Gen/HsType.hs#L2524-2643 +dMatchUpSAKWithDecl :: + forall q. + Fail.MonadFail q + => DKind + -- ^ The declaration's standalone kind signature + -> [DTyVarBndrVis] + -- ^ The user-written binders in the declaration + -> q [DTyVarBndr ForAllTyFlag] +dMatchUpSAKWithDecl decl_sak decl_bndrs = do + -- (1) First, explicitly quantify any free kind variables in `decl_sak` using + -- an invisible @forall@. This is done to ensure that precondition (2) in + -- `dMatchUpSigWithDecl` is upheld. (See the Haddocks for that function). + let decl_sak_free_tvbs = + changeDTVFlags SpecifiedSpec $ toposortTyVarsOf [decl_sak] + decl_sak' = DForallT (DForallInvis decl_sak_free_tvbs) decl_sak + + -- (2) Next, compute type variable binders using `dMatchUpSigWithDecl`. Note + -- that these can be biased towards type variable names mention in `decl_sak` + -- over names mentioned in `decl_bndrs`, but we will fix that up in the next + -- step. + let (decl_sak_args, _) = unravelDType decl_sak' + sing_sak_tvbs <- dMatchUpSigWithDecl decl_sak_args decl_bndrs + + -- (3) Finally, swizzle the type variable names so that names in `decl_bndrs` + -- are preferred over names in `decl_sak`. + -- + -- This is heavily inspired by similar code in GHC: + -- https://gitlab.haskell.org/ghc/ghc/-/blob/cec903899234bf9e25ea404477ba846ac1e963bb/compiler/GHC/Tc/Gen/HsType.hs#L2607-2616 + let invis_decl_sak_args = filterInvisTvbArgs decl_sak_args + invis_decl_sak_arg_nms = map dtvbName invis_decl_sak_args + + invis_decl_bndrs = toposortKindVarsOfTvbs decl_bndrs + invis_decl_bndr_nms = map dtvbName invis_decl_bndrs + + swizzle_env = + M.fromList $ zip invis_decl_sak_arg_nms invis_decl_bndr_nms + (_, swizzled_sing_sak_tvbs) = + mapAccumL (swizzleTvb swizzle_env) M.empty sing_sak_tvbs + pure swizzled_sing_sak_tvbs + +-- Match the quantifiers in a type-level declaration's standalone kind signature +-- with the user-written binders in the declaration. This function assumes the +-- following preconditions: +-- +-- 1. The number of required binders in the declaration's user-written binders +-- is equal to the number of visible quantifiers (i.e., the number of +-- function arrows plus the number of visible @forall@–bound variables) in +-- the standalone kind signature. +-- +-- 2. The number of invisible \@-binders in the declaration's user-written +-- binders is less than or equal to the number of invisible quantifiers +-- (i.e., the number of invisible @forall@–bound variables) in the +-- standalone kind signature. +-- +-- The implementation of this function is heavily based on a GHC function of +-- the same name: +-- https://gitlab.haskell.org/ghc/ghc/-/blob/1464a2a8de082f66ae250d63ab9d94dbe2ef8620/compiler/GHC/Tc/Gen/HsType.hs#L2645-2715 +dMatchUpSigWithDecl :: + forall q. + Fail.MonadFail q + => DFunArgs + -- ^ The quantifiers in the declaration's standalone kind signature + -> [DTyVarBndrVis] + -- ^ The user-written binders in the declaration + -> q [DTyVarBndr ForAllTyFlag] +dMatchUpSigWithDecl = go_fun_args M.empty + where + go_fun_args :: + DSubst + -- ^ A substitution from the names of @forall@-bound variables in the + -- standalone kind signature to corresponding binder names in the + -- user-written binders. This is because we want to reuse type variable + -- names from the user-written binders whenever possible. For example: + -- + -- @ + -- type T :: forall a. forall b -> Maybe (a, b) -> Type + -- data T @x y z + -- @ + -- + -- After matching up the @a@ in @forall a.@ with @x@ and + -- the @b@ in @forall b ->@ with @y@, this substitution will be + -- extended with @[a :-> x, b :-> y]@. This ensures that we will + -- produce @Maybe (x, y)@ instead of @Maybe (a, b)@ in + -- the kind for @z@. + -> DFunArgs -> [DTyVarBndrVis] -> q [DTyVarBndr ForAllTyFlag] + go_fun_args _ DFANil [] = + pure [] + -- This should not happen, per precondition (1). + go_fun_args _ DFANil decl_bndrs = + fail $ "dMatchUpSigWithDecl.go_fun_args: Too many binders: " ++ show decl_bndrs + -- GHC now disallows kind-level constraints, per this GHC proposal: + -- https://github.com/ghc-proposals/ghc-proposals/blob/b0687d96ce8007294173b7f628042ac4260cc738/proposals/0547-no-kind-equalities.rst + -- As such, we reject non-empty kind contexts. Empty contexts (which are + -- benign) can sometimes arise due to @ForallT@, so we add a special case + -- to allow them. + go_fun_args subst (DFACxt [] args) decl_bndrs = + go_fun_args subst args decl_bndrs + go_fun_args _ (DFACxt{}) _ = + fail "dMatchUpSigWithDecl.go_fun_args: Unexpected kind-level constraint" + go_fun_args subst (DFAForalls (DForallInvis tvbs) sig_args) decl_bndrs = + go_invis_tvbs subst tvbs sig_args decl_bndrs + go_fun_args subst (DFAForalls (DForallVis tvbs) sig_args) decl_bndrs = + go_vis_tvbs subst tvbs sig_args decl_bndrs + go_fun_args subst (DFAAnon anon sig_args) (decl_bndr:decl_bndrs) = + case dtvbFlag decl_bndr of + -- If the next decl_bndr is required, then we must match its kind (if + -- one is provided) against the anonymous kind argument. + BndrReq -> do + let decl_bndr_name = dtvbName decl_bndr + mb_decl_bndr_kind = extractTvbKind decl_bndr + anon' = SC.substTy subst anon + + anon'' = + case mb_decl_bndr_kind of + Nothing -> anon' + Just decl_bndr_kind -> + let mb_match_subst = matchTy NoIgnore decl_bndr_kind anon' in + maybe decl_bndr_kind (`SC.substTy` decl_bndr_kind) mb_match_subst + sig_args' <- go_fun_args subst sig_args decl_bndrs + pure $ DKindedTV decl_bndr_name Required anon'' : sig_args' + -- We have a visible, anonymous argument in the kind, but an invisible + -- @-binder as the next decl_bndr. This is ill kinded, so throw an + -- error. + -- + -- This should not happen, per precondition (2). + BndrInvis -> + fail $ "dMatchUpSigWithDecl.go_fun_args: Expected visible binder, encountered invisible binder: " + ++ show decl_bndr + -- This should not happen, per precondition (1). + go_fun_args _ _ [] = + fail "dMatchUpSigWithDecl.go_fun_args: Too few binders" + + go_invis_tvbs :: DSubst -> [DTyVarBndrSpec] -> DFunArgs -> [DTyVarBndrVis] -> q [DTyVarBndr ForAllTyFlag] + go_invis_tvbs subst [] sig_args decl_bndrs = + go_fun_args subst sig_args decl_bndrs + go_invis_tvbs subst (invis_tvb:invis_tvbs) sig_args decl_bndrss = + case decl_bndrss of + [] -> skip_invis_bndr + decl_bndr:decl_bndrs -> + case dtvbFlag decl_bndr of + BndrReq -> skip_invis_bndr + -- If the next decl_bndr is an invisible @-binder, then we must match it + -- against the invisible forall–bound variable in the kind. + BndrInvis -> do + let (subst', sig_tvb) = match_tvbs subst invis_tvb decl_bndr + sig_args' <- go_invis_tvbs subst' invis_tvbs sig_args decl_bndrs + pure (fmap Invisible sig_tvb : sig_args') + where + -- There is an invisible forall in the kind without a corresponding + -- invisible @-binder, which is allowed. In this case, we simply apply + -- the substitution and recurse. + skip_invis_bndr :: q [DTyVarBndr ForAllTyFlag] + skip_invis_bndr = do + let (subst', invis_tvb') = SC.substTyVarBndr subst invis_tvb + sig_args' <- go_invis_tvbs subst' invis_tvbs sig_args decl_bndrss + pure $ fmap Invisible invis_tvb' : sig_args' + + go_vis_tvbs :: DSubst -> [DTyVarBndrUnit] -> DFunArgs -> [DTyVarBndrVis] -> q [DTyVarBndr ForAllTyFlag] + go_vis_tvbs subst [] sig_args decl_bndrs = + go_fun_args subst sig_args decl_bndrs + -- This should not happen, per precondition (1). + go_vis_tvbs _ (_:_) _ [] = + fail "dMatchUpSigWithDecl.go_vis_tvbs: Too few binders" + go_vis_tvbs subst (vis_tvb:vis_tvbs) sig_args (decl_bndr:decl_bndrs) = do + case dtvbFlag decl_bndr of + -- If the next decl_bndr is required, then we must match it against the + -- visible forall–bound variable in the kind. + BndrReq -> do + let (subst', sig_tvb) = match_tvbs subst vis_tvb decl_bndr + sig_args' <- go_vis_tvbs subst' vis_tvbs sig_args decl_bndrs + pure ((Required <$ sig_tvb) : sig_args') + -- We have a visible forall in the kind, but an invisible @-binder as + -- the next decl_bndr. This is ill kinded, so throw an error. + -- + -- This should not happen, per precondition (2). + BndrInvis -> + fail $ "dMatchUpSigWithDecl.go_vis_tvbs: Expected visible binder, encountered invisible binder: " + ++ show decl_bndr + + -- @match_tvbs subst sig_tvb decl_bndr@ will match the kind of @decl_bndr@ + -- against the kind of @sig_tvb@ to produce a new kind. This function + -- produces two values as output: + -- + -- 1. A new @subst@ that has been extended such that the name of @sig_tvb@ + -- maps to the name of @decl_bndr@. (See the Haddocks for the 'DSubst' + -- argument to @go_fun_args@ for an explanation of why we do this.) + -- + -- 2. A 'DTyVarBndrSpec' that has the name of @decl_bndr@, but with the new + -- kind resulting from matching. + match_tvbs :: DSubst -> DTyVarBndr flag -> DTyVarBndrVis -> (DSubst, DTyVarBndr flag) + match_tvbs subst sig_tvb decl_bndr = + let decl_bndr_name = dtvbName decl_bndr + mb_decl_bndr_kind = extractTvbKind decl_bndr + + sig_tvb_name = dtvbName sig_tvb + sig_tvb_flag = dtvbFlag sig_tvb + mb_sig_tvb_kind = SC.substTy subst <$> extractTvbKind sig_tvb + + mb_kind :: Maybe DKind + mb_kind = + case (mb_decl_bndr_kind, mb_sig_tvb_kind) of + (Nothing, Nothing) -> Nothing + (Just decl_bndr_kind, Nothing) -> Just decl_bndr_kind + (Nothing, Just sig_tvb_kind) -> Just sig_tvb_kind + (Just decl_bndr_kind, Just sig_tvb_kind) -> do + match_subst <- matchTy NoIgnore decl_bndr_kind sig_tvb_kind + Just $ SC.substTy match_subst decl_bndr_kind + + subst' = M.insert sig_tvb_name (DVarT decl_bndr_name) subst + sig_tvb' = case mb_kind of + Nothing -> DPlainTV decl_bndr_name sig_tvb_flag + Just kind -> DKindedTV decl_bndr_name sig_tvb_flag kind in + + (subst', sig_tvb') + +-- Collect the invisible type variable binders from a sequence of DFunArgs. +filterInvisTvbArgs :: DFunArgs -> [DTyVarBndrSpec] +filterInvisTvbArgs DFANil = [] +filterInvisTvbArgs (DFACxt _ args) = filterInvisTvbArgs args +filterInvisTvbArgs (DFAAnon _ args) = filterInvisTvbArgs args +filterInvisTvbArgs (DFAForalls tele args) = + let res = filterInvisTvbArgs args in + case tele of + DForallVis _ -> res + DForallInvis tvbs' -> tvbs' ++ res + +-- This is heavily inspired by the `swizzleTcb` function in GHC: +-- https://gitlab.haskell.org/ghc/ghc/-/blob/cec903899234bf9e25ea404477ba846ac1e963bb/compiler/GHC/Tc/Gen/HsType.hs#L2741-2755 +swizzleTvb :: + Map Name Name + -- ^ A \"swizzle environment\" (i.e., a map from binder names in a + -- standalone kind signature to binder names in the corresponding + -- type-level declaration). + -> DSubst + -- ^ Like the swizzle environment, but as a full-blown substitution. + -> DTyVarBndr flag + -> (DSubst, DTyVarBndr flag) +swizzleTvb swizzle_env subst tvb = + (subst', tvb2) + where + subst' = M.insert tvb_name (DVarT (dtvbName tvb2)) subst + tvb_name = dtvbName tvb + tvb1 = mapDTVKind (SC.substTy subst) tvb + tvb2 = + case M.lookup tvb_name swizzle_env of + Just user_name -> mapDTVName (const user_name) tvb1 + Nothing -> tvb1 + +-- | Convert a list of @'DTyVarBndr' 'ForAllTyFlag'@s to a list of +-- 'DTyVarBndrSpec's, which is suitable for use in an invisible @forall@. +-- Specifically: +-- +-- * Variable binders that use @'Invisible' spec@ are converted to @spec@. +-- +-- * Variable binders that are 'Required' are converted to 'SpecifiedSpec', +-- as all of the 'DTyVarBndrSpec's are invisible. As an example of how this +-- is used, consider what would happen when singling this data type: +-- +-- @ +-- type T :: forall k -> k -> Type +-- data T k (a :: k) where ... +-- @ +-- +-- Here, the @k@ binder is 'Required'. When we produce the standalone kind +-- signature for the singled data type, we use 'dtvbForAllTyFlagsToSpecs' to +-- produce the type variable binders in the outermost @forall@: +-- +-- @ +-- type ST :: forall k (a :: k). T k a -> Type +-- data ST z where ... +-- @ +-- +-- Note that the @k@ is bound visibily (i.e., using 'SpecifiedSpec') in the +-- outermost, invisible @forall@. +dtvbForAllTyFlagsToSpecs :: [DTyVarBndr ForAllTyFlag] -> [DTyVarBndrSpec] +dtvbForAllTyFlagsToSpecs = map (fmap to_spec) + where + to_spec :: ForAllTyFlag -> Specificity + to_spec (Invisible spec) = spec + to_spec Required = SpecifiedSpec + +-- | Convert a list of @'DTyVarBndr' 'ForAllTyFlag'@s to a list of +-- 'DTyVarBndrVis'es, which is suitable for use in a type-level declaration +-- (e.g., the @var_1 ... var_n@ in @class C var_1 ... var_n@). Specifically: +-- +-- * Variable binders that use @'Invisible' 'InferredSpec'@ are dropped +-- entirely. Such binders cannot be represented in source Haskell. +-- +-- * Variable binders that use @'Invisible' 'SpecifiedSpec'@ are converted to +-- 'BndrInvis'. +-- +-- * Variable binders that are 'Required' are converted to 'BndrReq'. +dtvbForAllTyFlagsToBndrVis :: [DTyVarBndr ForAllTyFlag] -> [DTyVarBndrVis] +dtvbForAllTyFlagsToBndrVis = catMaybes . map (traverse to_spec_maybe) + where + to_spec_maybe :: ForAllTyFlag -> Maybe BndrVis + to_spec_maybe (Invisible InferredSpec) = Nothing + to_spec_maybe (Invisible SpecifiedSpec) = Just bndrInvis + to_spec_maybe Required = Just BndrReq + +-- | Some functions in this module only use certain arguments on particular +-- versions of GHC. Other versions of GHC (that don't make use of those +-- arguments) might need to conjure up those arguments out of thin air at the +-- functions' call sites, so this function serves as a placeholder to use in +-- those situations. (In other words, this is a slightly more informative +-- version of 'undefined'.) +unusedArgument :: a +unusedArgument = error "Unused" + +{- +Note [Desugaring and sweetening ForallT] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The ForallT constructor from template-haskell is tremendously awkward. Because +ForallT contains both a list of type variable binders and constraint arguments, +ForallT expressions can be ambiguous when one of these lists is empty. For +example, consider this expression with no constraints: + + ForallT [PlainTV a] [] (VarT a) + +What should this desugar to in th-desugar, which must maintain a clear +separation between type variable binders and constraints? There are two +possibilities: + +1. DForallT DForallInvis [DPlainTV a] (DVarT a) + (i.e., forall a. a) +2. DForallT DForallInvis [DPlainTV a] (DConstrainedT [] (DVarT a)) + (i.e., forall a. () => a) + +Template Haskell generally drops these empty lists when splicing Template +Haskell expressions, so we would like to do the same in th-desugar to mimic +TH's behavior as closely as possible. However, there are some situations where +dropping empty lists of `forall`ed type variable binders can change the +semantics of a program. For instance, contrast `foo :: forall. a -> a` (which +is an error) with `foo :: a -> a` (which is fine). Therefore, we try to +preserve empty `forall`s to the best of our ability. + +Here is an informal specification of how th-desugar should handle different sorts +of ambiguity. First, a specification for desugaring. +Let `tvbs` and `ctxt` be non-empty: + +* `ForallT tvbs [] ty` should desugar to `DForallT DForallInvis tvbs ty`. +* `ForallT [] ctxt ty` should desguar to `DForallT DForallInvis [] (DConstrainedT ctxt ty)`. +* `ForallT [] [] ty` should desugar to `DForallT DForallInvis [] ty`. +* For all other cases, just straightforwardly desugar + `ForallT tvbs ctxt ty` to `DForallT DForallInvis tvbs (DConstraintedT ctxt ty)`. + +For sweetening: + +* `DForallT DForallInvis tvbs (DConstrainedT ctxt ty)` should sweeten to `ForallT tvbs ctxt ty`. +* `DForallT DForallInvis [] (DConstrainedT ctxt ty)` should sweeten to `ForallT [] ctxt ty`. +* `DForallT DForallInvis tvbs (DConstrainedT [] ty)` should sweeten to `ForallT tvbs [] ty`. +* `DForallT DForallInvis [] (DConstrainedT [] ty)` should sweeten to `ForallT [] [] ty`. +* For all other cases, just straightforwardly sweeten + `DForallT DForallInvis tvbs ty` to `ForallT tvbs [] ty` and + `DConstrainedT ctxt ty` to `ForallT [] ctxt ty`. +-} 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,17 +1,17 @@ {- Language/Haskell/TH/Desugar/Expand.hs (c) Richard Eisenberg 2013 -eir@cis.upenn.edu +rae@cs.brynmawr.edu -} -{-# LANGUAGE CPP, NoMonomorphismRestriction #-} +{-# LANGUAGE NoMonomorphismRestriction, ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Language.Haskell.TH.Desugar.Expand -- Copyright : (C) 2014 Richard Eisenberg -- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (eir@cis.upenn.edu) +-- Maintainer : Ryan Scott -- Stability : experimental -- Portability : non-portable -- @@ -26,242 +26,175 @@ expand, expandType, -- * Expand synonyms potentially unsoundly - expandUnsoundly, - - -- * Capture-avoiding substitution - substTy + expandUnsoundly ) where import qualified Data.Map as M -import qualified Data.Set as S -import Control.Monad -#if __GLASGOW_HASKELL__ < 709 -import Control.Applicative -#endif import Language.Haskell.TH hiding (cxt) import Language.Haskell.TH.Syntax ( Quasi(..) ) import Data.Data import Data.Generics -import Data.List import qualified Data.Traversable as T +import Language.Haskell.TH.Desugar.AST import Language.Haskell.TH.Desugar.Core import Language.Haskell.TH.Desugar.Util import Language.Haskell.TH.Desugar.Sweeten import Language.Haskell.TH.Desugar.Reify - --- | Ignore kind annotations? -data IgnoreKinds = YesIgnore | NoIgnore +import Language.Haskell.TH.Desugar.Subst -- | Expands all type synonyms in a desugared type. Also expands open type family --- applications, as long as the arguments have no free variables. Attempts to +-- applications. (In GHCs before 7.10, this part does not work if there are any +-- variables.) Attempts to -- expand closed type family applications, but aborts the moment it spots anything -- strange, like a nested type family application or type variable. expandType :: DsMonad q => DType -> q DType expandType = expand_type NoIgnore -expand_type :: DsMonad q => IgnoreKinds -> DType -> q DType +expand_type :: forall q. DsMonad q => IgnoreKinds -> DType -> q DType expand_type ign = go [] where - go [] (DForallT tvbs cxt ty) = - DForallT tvbs <$> mapM (expand_ ign) cxt <*> expand_type ign ty + go :: [DTypeArg] -> DType -> q DType + go [] (DForallT tele ty) = + DForallT <$> expand_tele ign tele + <*> expand_type ign ty go _ (DForallT {}) = impossible "A forall type is applied to another type." + go [] (DConstrainedT cxt ty) = + DConstrainedT <$> mapM (expand_type ign) cxt + <*> expand_type ign ty + go _ (DConstrainedT {}) = + impossible "A constrained type is applied to another type." go args (DAppT t1 t2) = do t2' <- expand_type ign t2 - go (t2' : args) t1 + go (DTANormal t2' : args) t1 + go args (DAppKindT p k) = do + k' <- expand_type ign k + go (DTyArg k' : args) p go args (DSigT ty ki) = do ty' <- go [] ty - return $ foldl DAppT (DSigT ty' ki) args + ki' <- go [] ki + finish (DSigT ty' ki') args go args (DConT n) = expand_con ign n args - go args ty = return $ foldl DAppT ty args + go args ty@(DVarT _) = finish ty args + go args ty@DArrowT = finish ty args + go args ty@(DLitT _) = finish ty args + go args ty@DWildCardT = finish ty args --- | Expands all type synonyms in a desugared predicate. -expand_pred :: DsMonad q => IgnoreKinds -> DPred -> q DPred -expand_pred ign = go [] - where - go args (DAppPr p t) = do - t' <- expand_type ign t - go (t' : args) p - go args (DSigPr p k) = do - p' <- go [] p - return $ foldl DAppPr (DSigPr p' k) args - go args (DConPr n) = do - ty <- expand_con ign n args - dTypeToDPred ty - go args p = return $ foldl DAppPr p args + finish :: DType -> [DTypeArg] -> q DType + finish ty args = return $ applyDType ty args +-- | Expands all type synonyms in the kinds of a @forall@ telescope. +expand_tele :: DsMonad q => IgnoreKinds -> DForallTelescope -> q DForallTelescope +expand_tele ign (DForallVis tvbs) = DForallVis <$> mapM (expand_tvb ign) tvbs +expand_tele ign (DForallInvis tvbs) = DForallInvis <$> mapM (expand_tvb ign) tvbs + +-- | Expands all type synonyms in a type variable binder's kind. +expand_tvb :: DsMonad q => IgnoreKinds -> DTyVarBndr flag -> q (DTyVarBndr flag) +expand_tvb _ tvb@DPlainTV{} = pure tvb +expand_tvb ign (DKindedTV n flag k) = DKindedTV n flag <$> expand_type ign k + -- | Expand a constructor with given arguments -expand_con :: DsMonad q +expand_con :: forall q. + DsMonad q => IgnoreKinds - -> Name -- ^ Tycon name - -> [DType] -- ^ Arguments - -> q DType -- ^ Expanded type + -> Name -- ^ Tycon name + -> [DTypeArg] -- ^ Arguments + -> q DType -- ^ Expanded type expand_con ign n args = do info <- reifyWithLocals n - dinfo <- dsInfo info - args_ok <- allM no_tyvars_tyfams args - case dinfo of - DTyConI (DTySynD _n tvbs rhs) _ - | length args >= length tvbs -- this should always be true! - -> do - let (syn_args, rest_args) = splitAtList tvbs args - ty <- substTy (M.fromList $ zip (map extractDTvbName tvbs) syn_args) rhs - ty' <- expand_type ign ty - return $ foldl DAppT ty' rest_args + case info of + TyConI (TySynD _ _ StarT) + -- See Note [Don't expand synonyms for *] + -> return $ applyDType (DConT typeKindName) args + _ -> go info + where + -- Only the normal (i.e., non-visibly applied) arguments. These are + -- important since we need to align these with the arguments of the type + -- synonym/family, and visible kind arguments can mess with this. + normal_args :: [DType] + normal_args = filterDTANormals args - DTyConI (DOpenTypeFamilyD (DTypeFamilyHead _n tvbs _frs _ann)) _ - | length args >= length tvbs -- this should always be true! - , args_ok - -> do - let (syn_args, rest_args) = splitAtList tvbs args - -- need to get the correct instance - insts <- qReifyInstances n (map typeToTH syn_args) - dinsts <- dsDecs insts - case dinsts of - [DTySynInstD _n (DTySynEqn lhs rhs)] -> do - subst <- - expectJustM "Impossible: reification returned a bogus instance" $ - merge_maps $ zipWith build_subst lhs syn_args - ty <- substTy subst rhs + go :: Info -> q DType + go info = do + dinfo <- dsInfo info + case dinfo of + DTyConI (DTySynD _n tvbs rhs) _ + | length normal_args >= length tvbs -- this should always be true! + -> do + let (syn_args, rest_args) = splitAtList tvbs normal_args + ty <- substTy (M.fromList $ zip (map dtvbName tvbs) syn_args) rhs ty' <- expand_type ign ty - return $ foldl DAppT ty' rest_args - _ -> return $ foldl DAppT (DConT n) args + return $ applyDType ty' $ map DTANormal rest_args + DTyConI (DOpenTypeFamilyD (DTypeFamilyHead _n tvbs _frs _ann)) _ + | length normal_args >= length tvbs -- this should always be true! + -> do + let (syn_args, rest_args) = splitAtList tvbs normal_args + -- We need to get the correct instance. If we fail to reify anything + -- (e.g., if a type family is quasiquoted), then fall back by + -- pretending that there are no instances in scope. + insts <- qRecover (return []) $ + qReifyInstances n (map typeToTH syn_args) + dinsts <- dsDecs insts + case dinsts of + [DTySynInstD (DTySynEqn _ lhs rhs)] + | (_, lhs_args) <- unfoldDType lhs + , let lhs_normal_args = filterDTANormals lhs_args + , Just subst <- + unionMaybeSubsts $ zipWith (matchTy ign) lhs_normal_args syn_args + -> do ty <- substTy subst rhs + ty' <- expand_type ign ty + return $ applyDType ty' $ map DTANormal rest_args + _ -> give_up - DTyConI (DClosedTypeFamilyD (DTypeFamilyHead _n tvbs _frs _ann) eqns) _ - | length args >= length tvbs - , args_ok - -> do - let (syn_args, rest_args) = splitAtList tvbs args - rhss <- mapMaybeM (check_eqn syn_args) eqns - case rhss of - (rhs : _) -> do - rhs' <- expand_type ign rhs - return $ foldl DAppT rhs' rest_args - [] -> return $ foldl DAppT (DConT n) args - where - -- returns the substed rhs - check_eqn :: DsMonad q => [DType] -> DTySynEqn -> q (Maybe DType) - check_eqn arg_tys (DTySynEqn lhs rhs) = do - let m_subst = merge_maps $ zipWith build_subst lhs arg_tys - T.mapM (flip substTy rhs) m_subst - - _ -> return $ foldl DAppT (DConT n) args - - where - no_tyvars_tyfams :: (DsMonad q, Data a) => a -> q Bool - no_tyvars_tyfams = everything (liftM2 (&&)) (mkQ (return True) no_tyvar_tyfam) - - no_tyvar_tyfam :: DsMonad q => DType -> q Bool - no_tyvar_tyfam (DVarT _) = return False - no_tyvar_tyfam (DConT con_name) = do - m_info <- dsReify con_name - return $ case m_info of - Nothing -> False -- we don't know anything. False is safe. - Just (DTyConI (DOpenTypeFamilyD {}) _) -> False - Just (DTyConI (DDataFamilyD {}) _) -> False - Just (DTyConI (DClosedTypeFamilyD {}) _) -> False - _ -> True - no_tyvar_tyfam t = gmapQl (liftM2 (&&)) (return True) no_tyvars_tyfams t - - build_subst :: DType -> DType -> Maybe (M.Map Name DType) - build_subst (DVarT var_name) arg = Just $ M.singleton var_name arg - -- if a pattern has a kind signature, it's really easy to get - -- this wrong. - build_subst (DSigT ty _ki) arg = case ign of - YesIgnore -> build_subst ty arg - NoIgnore -> Nothing - -- but we can safely ignore kind signatures on the target - build_subst pat (DSigT ty _ki) = build_subst pat ty - build_subst (DForallT {}) _ = - error "Impossible: forall-quantified pattern to type family" - -- reifyInstances should fail if an argument is forall-quantified. - build_subst _ (DForallT {}) = - error "Impossible: forall-quantified argument to type family" - build_subst (DAppT pat1 pat2) (DAppT arg1 arg2) = - merge_maps [build_subst pat1 arg1, build_subst pat2 arg2] - build_subst (DConT pat_con) (DConT arg_con) - | pat_con == arg_con = Just M.empty - build_subst DArrowT DArrowT = Just M.empty - build_subst (DLitT pat_lit) (DLitT arg_lit) - | pat_lit == arg_lit = Just M.empty - build_subst _ _ = Nothing - - merge_maps :: [Maybe (M.Map Name DType)] -> Maybe (M.Map Name DType) - merge_maps = foldl' merge_map1 (Just M.empty) - - merge_map1 :: Maybe (M.Map Name DType) -> Maybe (M.Map Name DType) - -> Maybe (M.Map Name DType) - merge_map1 ma mb = do - a <- ma - b <- mb - let shared_key_set = M.keysSet a `S.intersection` M.keysSet b - matches_up = S.foldr (\name -> ((a M.! name) `geq` (b M.! name) &&)) - True shared_key_set - if matches_up then return (a `M.union` b) else Nothing + DTyConI (DClosedTypeFamilyD (DTypeFamilyHead _n tvbs _frs _ann) eqns) _ + | length normal_args >= length tvbs + -> do + let (syn_args, rest_args) = splitAtList tvbs normal_args + rhss <- mapMaybeM (check_eqn syn_args) eqns + case rhss of + (rhs : _) -> do + rhs' <- expand_type ign rhs + return $ applyDType rhs' $ map DTANormal rest_args + [] -> give_up - allM :: Monad m => (a -> m Bool) -> [a] -> m Bool - allM f = foldM (\b x -> (b &&) `liftM` f x) True + where + -- returns the substed rhs + check_eqn :: [DType] -> DTySynEqn -> q (Maybe DType) + check_eqn arg_tys (DTySynEqn _ lhs rhs) = do + let (_, lhs_args) = unfoldDType lhs + normal_lhs_args = filterDTANormals lhs_args + m_subst = unionMaybeSubsts $ zipWith (matchTy ign) normal_lhs_args arg_tys + T.mapM (flip substTy rhs) m_subst --- | Capture-avoiding substitution on types -substTy :: DsMonad q => M.Map Name DType -> DType -> q DType -substTy vars (DForallT tvbs cxt ty) = - substTyVarBndrs vars tvbs $ \vars' tvbs' -> do - cxt' <- mapM (substPred vars') cxt - ty' <- substTy vars' ty - return $ DForallT tvbs' cxt' ty' -substTy vars (DAppT t1 t2) = - DAppT <$> substTy vars t1 <*> substTy vars t2 -substTy vars (DSigT ty ki) = - DSigT <$> substTy vars ty <*> pure ki -substTy vars (DVarT n) - | Just ty <- M.lookup n vars - = return ty - | otherwise - = return $ DVarT n -substTy _ ty = return ty + _ -> give_up -substTyVarBndrs :: DsMonad q => M.Map Name DType -> [DTyVarBndr] - -> (M.Map Name DType -> [DTyVarBndr] -> q DType) - -> q DType -substTyVarBndrs vars tvbs thing = do - new_names <- mapM (const (qNewName "local")) tvbs - let new_vars = M.fromList (zip (map extractDTvbName tvbs) (map DVarT new_names)) - -- this is very inefficient. Oh well. - thing (M.union vars new_vars) (zipWith substTvb tvbs new_names) + -- Used when we can't proceed with type family instance expansion any more, + -- and must conservatively return the orignal type family applied to its + -- arguments. + give_up :: q DType + give_up = return $ applyDType (DConT n) args -substTvb :: DTyVarBndr -> Name -> DTyVarBndr -substTvb (DPlainTV _) n = DPlainTV n -substTvb (DKindedTV _ k) n = DKindedTV n k +{- +Note [Don't expand synonyms for *] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We deliberately avoid expanding type synonyms for * such as Type and ★. +Why? If you reify any such type synonym using Template Haskell, this is +what you'll get: --- | Extract the name from a @TyVarBndr@ -extractDTvbName :: DTyVarBndr -> Name -extractDTvbName (DPlainTV n) = n -extractDTvbName (DKindedTV n _) = n + TyConI (TySynD [] StarT) -substPred :: DsMonad q => M.Map Name DType -> DPred -> q DPred -substPred vars (DAppPr p t) = DAppPr <$> substPred vars p <*> substTy vars t -substPred vars (DSigPr p k) = DSigPr <$> substPred vars p <*> pure k -substPred vars (DVarPr n) - | Just ty <- M.lookup n vars - = dTypeToDPred ty - | otherwise - = return $ DVarPr n -substPred _ p = return p +If you blindly charge ahead and recursively inspect the right-hand side of +this type synonym, you'll desugar StarT into (DConT ''Type), reify ''Type, +and get back another type synonym with StarT as its right-hand side. Then +you'll recursively inspect StarT and find yourself knee-deep in an infinite +loop. --- | Convert a 'DType' to a 'DPred' -dTypeToDPred :: DsMonad q => DType -> q DPred -dTypeToDPred (DForallT _ _ _) = impossible "Forall-type used as constraint" -dTypeToDPred (DAppT t1 t2) = DAppPr <$> dTypeToDPred t1 <*> pure t2 -dTypeToDPred (DSigT ty ki) = DSigPr <$> dTypeToDPred ty <*> pure ki -dTypeToDPred (DVarT n) = return $ DVarPr n -dTypeToDPred (DConT n) = return $ DConPr n -dTypeToDPred DArrowT = impossible "Arrow used as head of constraint" -dTypeToDPred (DLitT _) = impossible "Type literal used as head of constraint" -dTypeToDPred DWildCardT = return DWildCardPr -dTypeToDPred DStarT = impossible "Star used as head of constraint" +To prevent these sorts of shenanigans, we simply stop whenever we see a type +synonym with StarT as its right-hand side and return Type. +-} -- | Expand all type synonyms and type families in the desugared abstract -- syntax tree provided, where type family simplification is on a "best effort" @@ -290,4 +223,4 @@ -- | Generalization of 'expand' that either can or won't ignore kind annotations.sx expand_ :: (DsMonad q, Data a) => IgnoreKinds -> a -> q a -expand_ ign = everywhereM (mkM (expand_type ign) >=> mkM (expand_pred ign)) +expand_ ign = everywhereM (mkM (expand_type ign)) diff --git a/Language/Haskell/TH/Desugar/FV.hs b/Language/Haskell/TH/Desugar/FV.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/TH/Desugar/FV.hs @@ -0,0 +1,76 @@ +{- Language/Haskell/TH/Desugar/FV.hs + +(c) Ryan Scott 2018 + +Compute free variables of programs. +-} + +{-# LANGUAGE CPP #-} +module Language.Haskell.TH.Desugar.FV + ( fvDType + , extractBoundNamesDPat + ) where + +#if __GLASGOW_HASKELL__ < 804 +import Data.Monoid ((<>)) +#endif +import Language.Haskell.TH.Syntax +import Language.Haskell.TH.Desugar.AST +import qualified Language.Haskell.TH.Desugar.OSet as OS +import Language.Haskell.TH.Desugar.OSet (OSet) + +-- | Compute the free variables of a 'DType'. +fvDType :: DType -> OSet Name +fvDType = go + where + go :: DType -> OSet Name + go (DForallT tele ty) = fv_dtele tele (go ty) + go (DConstrainedT ctxt ty) = foldMap fvDType ctxt <> go ty + go (DAppT t1 t2) = go t1 <> go t2 + go (DAppKindT t k) = go t <> go k + go (DSigT ty ki) = go ty <> go ki + go (DVarT n) = OS.singleton n + go (DConT {}) = OS.empty + go DArrowT = OS.empty + go (DLitT {}) = OS.empty + go DWildCardT = OS.empty + +----- +-- Extracting bound term names +----- + +-- | Extract the term variables bound by a 'DPat'. +-- +-- This does /not/ extract any type variables bound by pattern signatures, +-- constructor patterns, or type patterns. +extractBoundNamesDPat :: DPat -> OSet Name +extractBoundNamesDPat = go + where + go :: DPat -> OSet Name + go (DLitP _) = OS.empty + go (DVarP n) = OS.singleton n + go (DConP _ _ pats) = foldMap go pats + go (DTildeP p) = go p + go (DBangP p) = go p + go (DSigP p _) = go p + go DWildP = OS.empty + go (DTypeP _) = OS.empty + go (DInvisP _) = OS.empty + +----- +-- Binding forms +----- + +-- | Adjust the free variables of something following a 'DForallTelescope'. +fv_dtele :: DForallTelescope -> OSet Name -> OSet Name +fv_dtele (DForallVis tvbs) = fv_dtvbs tvbs +fv_dtele (DForallInvis tvbs) = fv_dtvbs tvbs + +-- | Adjust the free variables of something following 'DTyVarBndr's. +fv_dtvbs :: [DTyVarBndr flag] -> OSet Name -> OSet Name +fv_dtvbs tvbs fvs = foldr fv_dtvb fvs tvbs + +-- | Adjust the free variables of something following a 'DTyVarBndr'. +fv_dtvb :: DTyVarBndr flag -> OSet Name -> OSet Name +fv_dtvb (DPlainTV n _) fvs = OS.delete n fvs +fv_dtvb (DKindedTV n _ k) fvs = OS.delete n fvs <> fvDType k 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 @@ -3,36 +3,16 @@ -- Module : Language.Haskell.TH.Desugar.Lift -- Copyright : (C) 2014 Richard Eisenberg -- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (eir@cis.upenn.edu) +-- Maintainer : Ryan Scott -- Stability : experimental -- Portability : non-portable -- --- Defines @Lift@ instances for the desugared language. This is defined --- in a separate module because it also must define @Lift@ instances for --- several TH types, which are orphans and may want another definition --- downstream. +-- Historically, this module defined orphan @Lift@ instances for the data types +-- in @th-desugar@. Nowadays, these instances are defined alongside the data +-- types themselves, so this module simply re-exports the instances. -- ---------------------------------------------------------------------------- -{-# LANGUAGE CPP, TemplateHaskell #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - module Language.Haskell.TH.Desugar.Lift () where -import Language.Haskell.TH.Desugar -import Language.Haskell.TH.Instances () -import Language.Haskell.TH.Lift - -$(deriveLiftMany [ ''DExp, ''DPat, ''DType, ''DPred, ''DTyVarBndr - , ''DMatch, ''DClause, ''DLetDec, ''DDec, ''DCon - , ''DConFields, ''DForeign, ''DPragma, ''DRuleBndr, ''DTySynEqn - , ''NewOrData -#if __GLASGOW_HASKELL__ < 707 - , ''AnnTarget, ''Role -#endif - , ''DTypeFamilyHead, ''DFamilyResultSig -#if __GLASGOW_HASKELL__ <= 710 - , ''InjectivityAnn, ''Bang, ''SourceUnpackedness - , ''SourceStrictness, ''Overlap -#endif - ]) +import Language.Haskell.TH.Desugar () 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,7 +1,7 @@ {- Language/Haskell/TH/Desugar/Match.hs (c) Richard Eisenberg 2013 -eir@cis.upenn.edu +rae@cs.brynmawr.edu Simplifies case statements in desugared TH. After this pass, there are no more nested patterns. @@ -9,27 +9,28 @@ This code is directly based on the analogous operation as written in GHC. -} -{-# LANGUAGE CPP, TemplateHaskell #-} - -#if __GLASGOW_HASKELL__ <= 708 -{-# LANGUAGE StandaloneDeriving #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -- we need Ord Lit. argh. -#endif +{-# LANGUAGE CPP, TemplateHaskellQuotes #-} module Language.Haskell.TH.Desugar.Match (scExp, scLetDec) where import Prelude hiding ( fail, exp ) -#if __GLASGOW_HASKELL__ < 709 -import Control.Applicative -#endif import Control.Monad hiding ( fail ) +import qualified Control.Monad as Monad +import Data.Data +import qualified Data.Foldable as F +import Data.Generics +import qualified Data.List.NonEmpty as NE +import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.Set as S import qualified Data.Map as Map import Language.Haskell.TH.Instances () import Language.Haskell.TH.Syntax -import Language.Haskell.TH.Desugar.Core +import Language.Haskell.TH.Desugar.AST +import Language.Haskell.TH.Desugar.Core (dsReify, maybeDLetE, mkTupleDExp) +import Language.Haskell.TH.Desugar.FV +import qualified Language.Haskell.TH.Desugar.OSet as OS import Language.Haskell.TH.Desugar.Util import Language.Haskell.TH.Desugar.Reify @@ -39,34 +40,65 @@ -- a 'DLitPa', or a 'DWildPa'. scExp :: DsMonad q => DExp -> q DExp scExp (DAppE e1 e2) = DAppE <$> scExp e1 <*> scExp e2 -scExp (DLamE names exp) = DLamE names <$> scExp exp -scExp (DCaseE scrut matches) - | DVarE name <- scrut - = simplCaseExp [name] clauses - | otherwise - = do scrut_name <- newUniqueName "scrut" - case_exp <- simplCaseExp [scrut_name] clauses - return $ DLetE [DValD (DVarPa scrut_name) scrut] case_exp - where - clauses = map match_to_clause matches - match_to_clause (DMatch pat exp) = DClause [pat] exp - +scExp (DLamCasesE clauses) = do + -- Per the Haddocks for DLamCasesE, an empty list of clauses indicates that + -- the overall `\cases` expression takes one argument. Otherwise, we look at + -- the first clause to see how many arguments the expression takes, as each + -- clause is required to have the same number of patterns. + let num_args = + case clauses of + [] -> 1 + DClause pats _ : _ -> length pats + clause' <- scClauses num_args clauses + pure $ DLamCasesE [clause'] scExp (DLetE decs body) = DLetE <$> mapM scLetDec decs <*> scExp body scExp (DSigE exp ty) = DSigE <$> scExp exp <*> pure ty -scExp e = return e +scExp (DAppTypeE exp ty) = DAppTypeE <$> scExp exp <*> pure ty +scExp (DTypedBracketE exp) = DTypedBracketE <$> scExp exp +scExp (DTypedSpliceE exp) = DTypedSpliceE <$> scExp exp +scExp (DForallE tele exp) = DForallE tele <$> scExp exp +scExp (DConstrainedE cxt exp) = DConstrainedE <$> mapM scExp cxt <*> scExp exp +scExp e@(DVarE {}) = return e +scExp e@(DConE {}) = return e +scExp e@(DLitE {}) = return e +scExp e@(DStaticE {}) = return e +scExp e@(DTypeE {}) = return e -- | Like 'scExp', but for a 'DLetDec'. scLetDec :: DsMonad q => DLetDec -> q DLetDec -scLetDec (DFunD name clauses@(DClause pats1 _ : _)) = do - arg_names <- mapM (const (newUniqueName "_arg")) pats1 +scLetDec (DFunD name clauses) = do + -- `DFunD`s are expected to have a non-empty list of clauses where each clause + -- has a number of patterns equal to the number of arguments. + let num_args = + case clauses of + [] -> error $ "The `" ++ nameBase name ++ + "` function has no clauses -- should never happen" + DClause pats _ : _ -> length pats + clause' <- scClauses num_args clauses + pure $ DFunD name [clause'] +scLetDec (DValD pat exp) = DValD pat <$> scExp exp +scLetDec (DPragmaD prag) = DPragmaD <$> scLetPragma prag +scLetDec dec@(DSigD {}) = return dec +scLetDec dec@(DInfixD {}) = return dec + +-- | Convert a list of 'DClause's into a single 'DClause', where the right-hand +-- side of the output 'DClause' matches on all of the patterns of the input +-- 'DClause's without using nested pattern matching. +scClauses :: + DsMonad q + => Int -- ^ The number of arguments in each 'DClause'. + -> [DClause] -> q DClause +scClauses num_args clauses = do + arg_names <- replicateM num_args (newUniqueName "_arg") clauses' <- mapM sc_clause_rhs clauses case_exp <- simplCaseExp arg_names clauses' - return $ DFunD name [DClause (map DVarPa arg_names) case_exp] + pure $ DClause (map DVarP arg_names) case_exp where sc_clause_rhs (DClause pats exp) = DClause pats <$> scExp exp -scLetDec (DValD pat exp) = DValD pat <$> scExp exp -scLetDec dec = return dec +scLetPragma :: DsMonad q => DPragma -> q DPragma +scLetPragma = topEverywhereM scExp -- Only topEverywhereM because scExp already recurses on its own + type MatchResult = DExp -> DExp matchResultToDExp :: MatchResult -> DExp @@ -80,11 +112,17 @@ -> [DClause] -> q DExp simplCaseExp vars clauses = - do let eis = [ EquationInfo pats (\_ -> rhs) | + do let eis = [ EquationInfo (to_ne_pats pats) (\_ -> rhs) | DClause pats rhs <- clauses ] matchResultToDExp `liftM` simplCase vars eis + where + to_ne_pats :: [DPat] -> NonEmpty DPat + to_ne_pats pats = + case pats of + p:ps -> p:|ps + [] -> error "Clause encountered with no patterns -- should never happen" -data EquationInfo = EquationInfo [DPat] MatchResult -- like DClause, but with a hole +data EquationInfo = EquationInfo (NonEmpty DPat) MatchResult -- like DClause, but with a hole -- analogous to GHC's match (in deSugar/Match.lhs) simplCase :: DsMonad q @@ -94,77 +132,124 @@ simplCase [] clauses = return (foldr1 (.) match_results) where match_results = [ mr | EquationInfo _ mr <- clauses ] -simplCase vars@(v:_) clauses = do +simplCase (v:vs) clauses = do (aux_binds, tidy_clauses) <- mapAndUnzipM (tidyClause v) clauses let grouped = groupClauses tidy_clauses match_results <- match_groups grouped return (adjustMatchResult (foldr (.) id aux_binds) $ foldr1 (.) match_results) where - match_groups :: DsMonad q => [[(PatGroup, EquationInfo)]] -> q [MatchResult] + match_groups :: DsMonad q => [NonEmpty (PatGroup, EquationInfo)] -> q [MatchResult] match_groups [] = matchEmpty v match_groups gs = mapM match_group gs - match_group :: DsMonad q => [(PatGroup, EquationInfo)] -> q MatchResult - match_group [] = error "Internal error in th-desugar (match_group)" - match_group eqns@((group,_) : _) = + match_group :: DsMonad q => NonEmpty (PatGroup, EquationInfo) -> q MatchResult + match_group eqns@((group,_) :| _) = case group of - PgCon _ -> matchConFamily vars (subGroup [(c,e) | (PgCon c, e) <- eqns]) - PgLit _ -> matchLiterals vars (subGroup [(l,e) | (PgLit l, e) <- eqns]) - PgBang -> matchBangs vars (drop_group eqns) - PgAny -> matchVariables vars (drop_group eqns) + PgCon _ -> matchConFamily vars $ subGroup [(c,e) | (PgCon c, e) <- NE.toList eqns] + PgLit _ -> matchLiterals vars $ subGroup [(l,e) | (PgLit l, e) <- NE.toList eqns] + PgBang -> matchBangs vars $ drop_group eqns + PgAny -> matchVariables vars $ drop_group eqns - drop_group = map snd + drop_group :: NonEmpty (PatGroup, EquationInfo) -> NonEmpty EquationInfo + drop_group = fmap snd + vars = v:|vs + -- analogous to GHC's tidyEqnInfo tidyClause :: DsMonad q => Name -> EquationInfo -> q (DExp -> DExp, EquationInfo) -tidyClause _ (EquationInfo [] _) = - error "Internal error in th-desugar: no patterns in tidyClause." -tidyClause v (EquationInfo (pat : pats) body) = do +tidyClause v (EquationInfo (pat :| pats) body) = do (wrap, pat') <- tidy1 v pat - return (wrap, EquationInfo (pat' : pats) body) + return (wrap, EquationInfo (pat' :| pats) body) tidy1 :: DsMonad q => Name -- the name of the variable that ... -> DPat -- ... this pattern is matching against -> q (DExp -> DExp, DPat) -- a wrapper and tidied pattern -tidy1 _ p@(DLitPa {}) = return (id, p) -tidy1 v (DVarPa var) = return (wrapBind var v, DWildPa) -tidy1 _ p@(DConPa {}) = return (id, p) -tidy1 v (DTildePa pat) = do +tidy1 _ p@(DLitP {}) = return (id, p) +tidy1 v (DVarP var) = return (wrapBind var v, DWildP) +tidy1 _ p@(DConP {}) = return (id, p) +tidy1 v (DTildeP pat) = do sel_decs <- mkSelectorDecs pat v - return (maybeDLetE sel_decs, DWildPa) -tidy1 v (DBangPa pat) = + return (maybeDLetE sel_decs, DWildP) +tidy1 v (DBangP pat) = case pat of - DLitPa _ -> tidy1 v pat -- already strict - DVarPa _ -> return (id, DBangPa pat) -- no change - DConPa _ _ -> tidy1 v pat -- already strict - DTildePa p -> tidy1 v (DBangPa p) -- discard ~ under ! - DBangPa p -> tidy1 v (DBangPa p) -- discard ! under ! - DWildPa -> return (id, DBangPa pat) -- no change -tidy1 _ DWildPa = return (id, DWildPa) + DLitP _ -> tidy1 v pat -- already strict + DVarP _ -> return (id, DBangP pat) -- no change + DConP{} -> tidy1 v pat -- already strict + DTildeP p -> tidy1 v (DBangP p) -- discard ~ under ! + DBangP p -> tidy1 v (DBangP p) -- discard ! under ! + DSigP p _ -> tidy1 v (DBangP p) -- discard sig under ! + DWildP -> return (id, DBangP pat) -- no change + DTypeP _ -> return (id, DBangP pat) -- no change + DInvisP _ -> return (id, DBangP pat) -- no change +tidy1 v (DSigP pat ty) + | no_tyvars_ty ty = tidy1 v pat + -- The match-flattener doesn't know how to deal with patterns that mention + -- type variables properly, so we give up if we encounter one. + -- See https://github.com/goldfirere/th-desugar/pull/48#issuecomment-266778976 + -- for further discussion. + | otherwise = Monad.fail + "Match-flattening patterns that mention type variables is not supported." + where + no_tyvars_ty :: Data a => a -> Bool + no_tyvars_ty = everything (&&) (mkQ True no_tyvar_ty) + no_tyvar_ty :: DType -> Bool + no_tyvar_ty (DVarT{}) = False + no_tyvar_ty t = gmapQl (&&) True no_tyvars_ty t +tidy1 _ DWildP = return (id, DWildP) +tidy1 _ (DTypeP ty) = return (id, DTypeP ty) +tidy1 _ (DInvisP ty) = return (id, DInvisP ty) + wrapBind :: Name -> Name -> DExp -> DExp wrapBind new old | new == old = id - | otherwise = DLetE [DValD (DVarPa new) (DVarE old)] + | otherwise = DLetE [DValD (DVarP new) (DVarE old)] --- like GHC's mkSelectorBinds +-- | Desugar a lazy pattern that bind multiple variables to code that extracts +-- fields from tuples. For instance, this: +-- +-- @ +-- data Pair a b = MkPair a b +-- +-- f :: Pair a b -> Pair b a +-- f ~(MkPair x y) = MkPair y x +-- @ +-- +-- Desugars to this (roughly) when match-flattened: +-- +-- @ +-- f :: Pair a b -> Pair b a +-- f p = +-- let tuple = case p of +-- MkPair x y -> (x, y) +-- +-- x = case tuple of +-- (x, _) -> x +-- +-- y = case tuple of +-- (_, y) -> x +-- +-- in MkPair y x +-- @ +-- +-- This takes heavy inspiration from GHC's own @mkSelectorBinds@ function. mkSelectorDecs :: DsMonad q => DPat -- pattern to deconstruct -> Name -- variable being matched against -> q [DLetDec] -mkSelectorDecs (DVarPa v) name = return [DValD (DVarPa v) (DVarE name)] +mkSelectorDecs (DVarP v) name = return [DValD (DVarP v) (DVarE name)] mkSelectorDecs pat name - | S.null binders + | OS.null binders = return [] - | S.size binders == 1 + | [binder] <- F.toList binders = do val_var <- newUniqueName "var" err_var <- newUniqueName "err" - bind <- mk_bind val_var err_var (head $ S.elems binders) - return [DValD (DVarPa val_var) (DVarE name), - DValD (DVarPa err_var) (DVarE 'error `DAppE` + bind <- mk_bind val_var err_var binder + return [DValD (DVarP val_var) (DVarE name), + DValD (DVarP err_var) (DVarE 'error `DAppE` (DLitE $ StringL "Irrefutable match failed")), bind] @@ -172,12 +257,12 @@ = do tuple_expr <- simplCaseExp [name] [DClause [pat] local_tuple] tuple_var <- newUniqueName "tuple" projections <- mapM (mk_projection tuple_var) [0 .. tuple_size-1] - return (DValD (DVarPa tuple_var) tuple_expr : - zipWith DValD (map DVarPa binders_list) projections) + return (DValD (DVarP tuple_var) tuple_expr : + zipWith DValD (map DVarP binders_list) projections) where binders = extractBoundNamesDPat pat - binders_list = S.toAscList binders + binders_list = F.toList binders tuple_size = length binders_list local_tuple = mkTupleDExp (map DVarE binders_list) @@ -187,25 +272,17 @@ -> q DExp mk_projection tup_name i = do var_name <- newUniqueName "proj" - return $ DCaseE (DVarE tup_name) [DMatch (DConPa (tupleDataName tuple_size) (mk_tuple_pats var_name i)) + return $ dCaseE (DVarE tup_name) [DMatch (DConP (tupleDataName tuple_size) [] (mk_tuple_pats var_name i)) (DVarE var_name)] mk_tuple_pats :: Name -- of the projected element -> Int -- which element to get (0-indexed) -> [DPat] - mk_tuple_pats elt_name i = replicate i DWildPa ++ DVarPa elt_name : replicate (tuple_size - i - 1) DWildPa + mk_tuple_pats elt_name i = replicate i DWildP ++ DVarP elt_name : replicate (tuple_size - i - 1) DWildP mk_bind scrut_var err_var bndr_var = do - rhs_mr <- simplCase [scrut_var] [EquationInfo [pat] (\_ -> DVarE bndr_var)] - return (DValD (DVarPa bndr_var) (rhs_mr (DVarE err_var))) - -extractBoundNamesDPat :: DPat -> S.Set Name -extractBoundNamesDPat (DLitPa _) = S.empty -extractBoundNamesDPat (DVarPa n) = S.singleton n -extractBoundNamesDPat (DConPa _ pats) = S.unions (map extractBoundNamesDPat pats) -extractBoundNamesDPat (DTildePa p) = extractBoundNamesDPat p -extractBoundNamesDPat (DBangPa p) = extractBoundNamesDPat p -extractBoundNamesDPat DWildPa = S.empty + rhs_mr <- simplCase [scrut_var] [EquationInfo (pat:|[]) (\_ -> DVarE bndr_var)] + return (DValD (DVarP bndr_var) (rhs_mr (DVarE err_var))) data PatGroup = PgAny -- immediate match (wilds, vars, lazies) @@ -214,20 +291,23 @@ | PgBang -- like GHC's groupEquations -groupClauses :: [EquationInfo] -> [[(PatGroup, EquationInfo)]] +groupClauses :: [EquationInfo] -> [NonEmpty (PatGroup, EquationInfo)] groupClauses clauses - = runs same_gp [(patGroup (firstPat clause), clause) | clause <- clauses] + = NE.groupBy same_gp [(patGroup (firstPat clause), clause) | clause <- clauses] where same_gp :: (PatGroup, EquationInfo) -> (PatGroup, EquationInfo) -> Bool (pg1,_) `same_gp` (pg2,_) = pg1 `sameGroup` pg2 patGroup :: DPat -> PatGroup -patGroup (DLitPa l) = PgLit l -patGroup (DVarPa {}) = error "Internal error in th-desugar (patGroup DVarP)" -patGroup (DConPa con _) = PgCon con -patGroup (DTildePa {}) = error "Internal error in th-desugar (patGroup DTildeP)" -patGroup (DBangPa {}) = PgBang -patGroup DWildPa = PgAny +patGroup (DLitP l) = PgLit l +patGroup (DVarP {}) = error "Internal error in th-desugar (patGroup DVarP)" +patGroup (DConP con _ _) = PgCon con +patGroup (DTildeP {}) = error "Internal error in th-desugar (patGroup DTildeP)" +patGroup (DBangP {}) = PgBang +patGroup (DSigP{}) = error "Internal error in th-desugar (patGroup DSigP)" +patGroup DWildP = PgAny +patGroup (DTypeP {}) = PgAny +patGroup (DInvisP {}) = PgAny sameGroup :: PatGroup -> PatGroup -> Bool sameGroup PgAny PgAny = True @@ -236,18 +316,20 @@ sameGroup (PgLit _) (PgLit _) = True sameGroup _ _ = False -subGroup :: Ord a => [(a, EquationInfo)] -> [[EquationInfo]] +-- Precondition: the input list contains at least one element. +subGroup :: Ord a => [(a, EquationInfo)] -> NonEmpty (NonEmpty EquationInfo) subGroup group - = map reverse $ Map.elems $ foldl accumulate Map.empty group + = case map NE.reverse $ Map.elems $ foldl accumulate Map.empty group of + e:es -> e:|es + [] -> error "Internal error in th-desugar (subGroup)" where accumulate pg_map (pg, eqn) = case Map.lookup pg pg_map of - Just eqns -> Map.insert pg (eqn:eqns) pg_map - Nothing -> Map.insert pg [eqn] pg_map + Just eqns -> Map.insert pg (NE.cons eqn eqns) pg_map + Nothing -> Map.insert pg (eqn :| []) pg_map firstPat :: EquationInfo -> DPat -firstPat (EquationInfo (pat : _) _) = pat -firstPat _ = error "Clause encountered with no patterns -- should never happen" +firstPat (EquationInfo (pat :| _) _) = pat data CaseAlt = CaseAlt { alt_con :: Name -- con name , _alt_args :: [Name] -- bound var names @@ -255,15 +337,14 @@ } -- from GHC's MatchCon.lhs -matchConFamily :: DsMonad q => [Name] -> [[EquationInfo]] -> q MatchResult -matchConFamily (var:vars) groups +matchConFamily :: DsMonad q => NonEmpty Name -> NonEmpty (NonEmpty EquationInfo) -> q MatchResult +matchConFamily (var:|vars) groups = do alts <- mapM (matchOneCon vars) groups mkDataConCase var alts -matchConFamily [] _ = error "Internal error in th-desugar (matchConFamily)" -- like matchOneConLike from MatchCon -matchOneCon :: DsMonad q => [Name] -> [EquationInfo] -> q CaseAlt -matchOneCon vars eqns@(eqn1 : _) +matchOneCon :: DsMonad q => [Name] -> NonEmpty EquationInfo -> q CaseAlt +matchOneCon vars eqns@(eqn1 :| _) = do arg_vars <- selectMatchVars (pat_args pat1) match_result <- match_group arg_vars @@ -271,35 +352,43 @@ where pat1 = firstPat eqn1 - pat_args (DConPa _ pats) = pats - pat_args _ = error "Internal error in th-desugar (pat_args)" + pat_args (DConP _ _ pats) = pats + pat_args _ = error "Internal error in th-desugar (pat_args)" - pat_con (DConPa con _) = con - pat_con _ = error "Internal error in th-desugar (pat_con)" + pat_con (DConP con _ _) = con + pat_con _ = error "Internal error in th-desugar (pat_con)" match_group :: DsMonad q => [Name] -> q MatchResult match_group arg_vars - = simplCase (arg_vars ++ vars) (map shift eqns) + = simplCase (arg_vars ++ vars) $ NE.toList $ fmap shift eqns - shift (EquationInfo (DConPa _ args : pats) exp) = EquationInfo (args ++ pats) exp + shift (EquationInfo (DConP _ _ args :| pats) exp) + = EquationInfo (to_ne_pats (args ++ pats)) exp shift _ = error "Internal error in th-desugar (shift)" -matchOneCon _ _ = error "Internal error in th-desugar (matchOneCon)" -mkDataConCase :: DsMonad q => Name -> [CaseAlt] -> q MatchResult + to_ne_pats :: [DPat] -> NonEmpty DPat + to_ne_pats pats = + case pats of + p:ps -> p:|ps + [] -> error "Internal error in th-desugar (matchOneCon.to_ne_pats)" + +mkDataConCase :: DsMonad q => Name -> NonEmpty CaseAlt -> q MatchResult mkDataConCase var case_alts = do - all_ctors <- get_all_ctors (alt_con $ head case_alts) + all_ctors <- get_all_ctors (alt_con $ NE.head case_alts) return $ \fail -> - let matches = map (mk_alt fail) case_alts in - DCaseE (DVarE var) (matches ++ mk_default all_ctors fail) + let matches = fmap (mk_alt fail) case_alt_list in + dCaseE (DVarE var) (matches ++ mk_default all_ctors fail) where + case_alt_list = NE.toList case_alts + mk_alt fail (CaseAlt con args body_fn) = let body = body_fn fail in - DMatch (DConPa con (map DVarPa args)) body + DMatch (DConP con [] (map DVarP args)) body mk_default all_ctors fail | exhaustive_case all_ctors = [] - | otherwise = [DMatch DWildPa fail] + | otherwise = [DMatch DWildP fail] - mentioned_ctors = S.fromList $ map alt_con case_alts + mentioned_ctors = S.fromList $ map alt_con case_alt_list exhaustive_case all_ctors = all_ctors `S.isSubsetOf` mentioned_ctors get_all_ctors :: DsMonad q => Name -> q (S.Set Name) @@ -308,68 +397,72 @@ Just (DTyConI tycon_dec _) <- dsReify ty_name return $ S.fromList $ map get_con_name $ get_cons tycon_dec - get_cons (DDataD _ _ _ _ cons _) = cons - get_cons (DDataInstD _ _ _ _ cons _) = cons - get_cons _ = [] + get_cons (DDataD _ _ _ _ _ cons _) = cons + get_cons (DDataInstD _ _ _ _ _ cons _) = cons + get_cons _ = [] get_con_name (DCon _ _ n _ _) = n matchEmpty :: DsMonad q => Name -> q [MatchResult] matchEmpty var = return [mk_seq] where - mk_seq fail = DCaseE (DVarE var) [DMatch DWildPa fail] + mk_seq fail = dCaseE (DVarE var) [DMatch DWildP fail] -matchLiterals :: DsMonad q => [Name] -> [[EquationInfo]] -> q MatchResult -matchLiterals (var:vars) sub_groups +matchLiterals :: DsMonad q => NonEmpty Name -> NonEmpty (NonEmpty EquationInfo) -> q MatchResult +matchLiterals (var:|vars) sub_groups = do alts <- mapM match_group sub_groups return (mkCoPrimCaseMatchResult var alts) where - match_group :: DsMonad q => [EquationInfo] -> q (Lit, MatchResult) + match_group :: DsMonad q => NonEmpty EquationInfo -> q (Lit, MatchResult) match_group eqns - = do let DLitPa lit = firstPat (head eqns) - match_result <- simplCase vars (shiftEqns eqns) + = do let lit = case firstPat (NE.head eqns) of + DLitP lit' -> lit' + _ -> error $ "Internal error in th-desugar " + ++ "(matchLiterals.match_group)" + match_result <- simplCase vars $ NE.toList $ shiftEqns eqns return (lit, match_result) -matchLiterals [] _ = error "Internal error in th-desugar (matchLiterals)" mkCoPrimCaseMatchResult :: Name -- Scrutinee - -> [(Lit, MatchResult)] + -> NonEmpty (Lit, MatchResult) -> MatchResult mkCoPrimCaseMatchResult var match_alts = mk_case where - mk_case fail = let alts = map (mk_alt fail) match_alts in - DCaseE (DVarE var) (alts ++ [DMatch DWildPa fail]) + mk_case fail = let alts = NE.toList $ fmap (mk_alt fail) match_alts in + dCaseE (DVarE var) (alts ++ [DMatch DWildP fail]) mk_alt fail (lit, body_fn) - = DMatch (DLitPa lit) (body_fn fail) + = DMatch (DLitP lit) (body_fn fail) -matchBangs :: DsMonad q => [Name] -> [EquationInfo] -> q MatchResult -matchBangs (var:vars) eqns - = do match_result <- simplCase (var:vars) $ - map (decomposeFirstPat getBangPat) eqns +matchBangs :: DsMonad q => NonEmpty Name -> NonEmpty EquationInfo -> q MatchResult +matchBangs (var:|vars) eqns + = do match_result <- simplCase (var:vars) $ NE.toList $ + fmap (decomposeFirstPat getBangPat) eqns return (mkEvalMatchResult var match_result) -matchBangs [] _ = error "Internal error in th-desugar (matchBangs)" decomposeFirstPat :: (DPat -> DPat) -> EquationInfo -> EquationInfo -decomposeFirstPat extractpat (EquationInfo (pat:pats) body) - = EquationInfo (extractpat pat : pats) body -decomposeFirstPat _ _ = error "Internal error in th-desugar (decomposeFirstPat)" +decomposeFirstPat extractpat (EquationInfo (pat:|pats) body) + = EquationInfo (extractpat pat :| pats) body getBangPat :: DPat -> DPat -getBangPat (DBangPa p) = p -getBangPat _ = error "Internal error in th-desugar (getBangPat)" +getBangPat (DBangP p) = p +getBangPat _ = error "Internal error in th-desugar (getBangPat)" mkEvalMatchResult :: Name -> MatchResult -> MatchResult mkEvalMatchResult var body_fn fail = foldl DAppE (DVarE 'seq) [DVarE var, body_fn fail] -matchVariables :: DsMonad q => [Name] -> [EquationInfo] -> q MatchResult -matchVariables (_:vars) eqns = simplCase vars (shiftEqns eqns) -matchVariables _ _ = error "Internal error in th-desugar (matchVariables)" +matchVariables :: DsMonad q => NonEmpty Name -> NonEmpty EquationInfo -> q MatchResult +matchVariables (_:|vars) eqns = simplCase vars $ NE.toList $ shiftEqns eqns -shiftEqns :: [EquationInfo] -> [EquationInfo] -shiftEqns = map shift +shiftEqns :: NonEmpty EquationInfo -> NonEmpty EquationInfo +shiftEqns = fmap shift where - shift (EquationInfo pats rhs) = EquationInfo (tail pats) rhs + shift (EquationInfo pats rhs) = EquationInfo (to_ne_pats (NE.tail pats)) rhs + to_ne_pats :: [DPat] -> NonEmpty DPat + to_ne_pats pats = + case pats of + p:ps -> p:|ps + [] -> error "Internal error in th-desugar (shiftEqns.to_ne_pats)" adjustMatchResult :: (DExp -> DExp) -> MatchResult -> MatchResult adjustMatchResult wrap mr fail = wrap $ mr fail @@ -380,13 +473,7 @@ -- from DsUtils selectMatchVar :: DsMonad q => DPat -> q Name -selectMatchVar (DBangPa pat) = selectMatchVar pat -selectMatchVar (DTildePa pat) = selectMatchVar pat -selectMatchVar (DVarPa var) = newUniqueName ('_' : nameBase var) -selectMatchVar _ = newUniqueName "_pat" - --- like GHC's runs -runs :: (a -> a -> Bool) -> [a] -> [[a]] -runs _ [] = [] -runs p (x:xs) = case span (p x) xs of - (first, rest) -> (x:first) : (runs p rest) +selectMatchVar (DBangP pat) = selectMatchVar pat +selectMatchVar (DTildeP pat) = selectMatchVar pat +selectMatchVar (DVarP var) = newUniqueName ('_' : nameBase var) +selectMatchVar _ = newUniqueName "_pat" diff --git a/Language/Haskell/TH/Desugar/OMap.hs b/Language/Haskell/TH/Desugar/OMap.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/TH/Desugar/OMap.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Language.Haskell.TH.Desugar.OMap +-- Copyright : (C) 2016-2018 Daniel Wagner, 2019 Ryan Scott +-- License : BSD-style (see LICENSE) +-- Maintainer : Ryan Scott +-- Stability : experimental +-- Portability : non-portable +-- +-- An 'OMap' behaves much like a 'M.Map', with all the same asymptotics, but +-- also remembers the order that keys were inserted. +-- +-- This module offers a simplified version of the "Data.Map.Ordered" API +-- that assumes left-biased indices everywhere and uses a different 'Semigroup' +-- instance (the one in this module uses @('<>') = 'union'@) and 'Monoid' +-- instance (the one in this module uses @'mappend' = 'union'@). +-- +---------------------------------------------------------------------------- +module Language.Haskell.TH.Desugar.OMap + ( OMap(..) + -- * Trivial maps + , empty, singleton + -- * Insertion + , insertPre, insertPost, union, unionWithKey + -- * Deletion + , delete, filterWithKey, (\\), intersection, intersectionWithKey + -- * Query + , null, size, member, notMember, lookup + -- * Indexing + , Index, lookupIndex, lookupAt + -- * List conversions + , fromList, assocs, toAscList + -- * 'M.Map' conversion + , toMap + ) where + +import Data.Coerce +import Data.Data +import qualified Data.Map.Lazy as M (Map) +import Data.Map.Ordered (Bias(..), Index, L) +import qualified Data.Map.Ordered as OM +import Prelude hiding (filter, lookup, null) + +#if !(MIN_VERSION_base(4,11,0)) +import Data.Semigroup (Semigroup(..)) +#endif + +-- | An ordered map whose 'insertPre', 'insertPost', 'intersection', +-- 'intersectionWithKey', 'union', and 'unionWithKey' operations are biased +-- towards leftmost indices when when breaking ties between keys. +newtype OMap k v = OMap (Bias L (OM.OMap k v)) + deriving (Data, Foldable, Functor, Eq, Ord, Read, Show, Traversable) + +instance Ord k => Semigroup (OMap k v) where + (<>) = union +instance Ord k => Monoid (OMap k v) where + mempty = empty +#if !(MIN_VERSION_base(4,11,0)) + mappend = (<>) +#endif + +empty :: forall k v. OMap k v +empty = coerce (OM.empty @k @v) + +singleton :: k -> v -> OMap k v +singleton k v = coerce (OM.singleton (k, v)) + +-- | The value's index will be lower than the indices of the values in the +-- 'OSet'. +insertPre :: Ord k => k -> v -> OMap k v -> OMap k v +insertPre k v = coerce ((k, v) OM.|<) + +-- | The value's index will be higher than the indices of the values in the +-- 'OSet'. +insertPost :: Ord k => OMap k v -> k -> v -> OMap k v +insertPost m k v = coerce (coerce m OM.|> (k, v)) + +union :: forall k v. Ord k => OMap k v -> OMap k v -> OMap k v +union = coerce ((OM.|<>) @k @v) + +unionWithKey :: Ord k => (k -> v -> v -> v) -> OMap k v -> OMap k v -> OMap k v +unionWithKey f = coerce (OM.unionWithL f) + +delete :: forall k v. Ord k => k -> OMap k v -> OMap k v +delete = coerce (OM.delete @k @v) + +filterWithKey :: Ord k => (k -> v -> Bool) -> OMap k v -> OMap k v +filterWithKey f = coerce (OM.filter f) + +(\\) :: forall k v v'. Ord k => OMap k v -> OMap k v' -> OMap k v +(\\) = coerce ((OM.\\) @k @v @v') + +intersection :: forall k v v'. Ord k => OMap k v -> OMap k v' -> OMap k v +intersection = coerce ((OM.|/\) @k @v @v') + +intersectionWithKey :: Ord k => (k -> v -> v' -> v'') -> OMap k v -> OMap k v' -> OMap k v'' +intersectionWithKey f = coerce (OM.intersectionWith f) + +null :: forall k v. OMap k v -> Bool +null = coerce (OM.null @k @v) + +size :: forall k v. OMap k v -> Int +size = coerce (OM.size @k @v) + +member :: forall k v. Ord k => k -> OMap k v -> Bool +member = coerce (OM.member @k @v) + +notMember :: forall k v. Ord k => k -> OMap k v -> Bool +notMember = coerce (OM.notMember @k @v) + +lookup :: forall k v. Ord k => k -> OMap k v -> Maybe v +lookup = coerce (OM.lookup @k @v) + +lookupIndex :: forall k v. Ord k => k -> OMap k v -> Maybe Index +lookupIndex = coerce (OM.findIndex @k @v) + +lookupAt :: forall k v. Index -> OMap k v -> Maybe (k, v) +lookupAt i m = OM.elemAt @k @v (coerce m) i + +fromList :: Ord k => [(k, v)] -> OMap k v +fromList l = coerce (OM.fromList l) + +assocs :: forall k v. OMap k v -> [(k, v)] +assocs = coerce (OM.assocs @k @v) + +toAscList :: forall k v. OMap k v -> [(k, v)] +toAscList = coerce (OM.toAscList @k @v) + +toMap :: forall k v. OMap k v -> M.Map k v +toMap = coerce (OM.toMap @k @v) diff --git a/Language/Haskell/TH/Desugar/OMap/Strict.hs b/Language/Haskell/TH/Desugar/OMap/Strict.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/TH/Desugar/OMap/Strict.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Language.Haskell.TH.Desugar.OMap +-- Copyright : (C) 2016-2018 Daniel Wagner, 2019 Ryan Scott +-- License : BSD-style (see LICENSE) +-- Maintainer : Ryan Scott +-- Stability : experimental +-- Portability : non-portable +-- +-- An 'OMap' behaves much like a 'M.Map', with all the same asymptotics, but +-- also remembers the order that keys were inserted. +-- +-- This module offers a simplified version of the "Data.Map.Ordered.Strict" API +-- that assumes left-biased indices everywhere and uses a different 'Semigroup' +-- instance (the one in this module uses @('<>') = 'union'@) and 'Monoid' +-- instance (the one in this module uses @'mappend' = 'union'@). +-- +---------------------------------------------------------------------------- +module Language.Haskell.TH.Desugar.OMap.Strict + ( OMap(..) + -- * Trivial maps + , empty, singleton + -- * Insertion + , insertPre, insertPost, union, unionWithKey + -- * Deletion + , delete, filterWithKey, (\\), intersection, intersectionWithKey + -- * Query + , null, size, member, notMember, lookup + -- * Indexing + , Index, lookupIndex, lookupAt + -- * List conversions + , fromList, assocs, toAscList + -- * 'M.Map' conversion + , toMap + ) where + +import Data.Coerce +import qualified Data.Map.Strict as M (Map) +import Data.Map.Ordered.Strict (Index) +import qualified Data.Map.Ordered.Strict as OM +import Language.Haskell.TH.Desugar.OMap (OMap(..)) +import Prelude hiding (filter, lookup, null) + +empty :: forall k v. OMap k v +empty = coerce (OM.empty @k @v) + +singleton :: k -> v -> OMap k v +singleton k v = coerce (OM.singleton (k, v)) + +-- | The value's index will be lower than the indices of the values in the +-- 'OSet'. +insertPre :: Ord k => k -> v -> OMap k v -> OMap k v +insertPre k v = coerce ((k, v) OM.|<) + +-- | The value's index will be higher than the indices of the values in the +-- 'OSet'. +insertPost :: Ord k => OMap k v -> k -> v -> OMap k v +insertPost m k v = coerce (coerce m OM.|> (k, v)) + +union :: forall k v. Ord k => OMap k v -> OMap k v -> OMap k v +union = coerce ((OM.|<>) @k @v) + +unionWithKey :: Ord k => (k -> v -> v -> v) -> OMap k v -> OMap k v -> OMap k v +unionWithKey f = coerce (OM.unionWithL f) + +delete :: forall k v. Ord k => k -> OMap k v -> OMap k v +delete = coerce (OM.delete @k @v) + +filterWithKey :: Ord k => (k -> v -> Bool) -> OMap k v -> OMap k v +filterWithKey f = coerce (OM.filter f) + +(\\) :: forall k v v'. Ord k => OMap k v -> OMap k v' -> OMap k v +(\\) = coerce ((OM.\\) @k @v @v') + +intersection :: forall k v v'. Ord k => OMap k v -> OMap k v' -> OMap k v +intersection = coerce ((OM.|/\) @k @v @v') + +intersectionWithKey :: Ord k => (k -> v -> v' -> v'') -> OMap k v -> OMap k v' -> OMap k v'' +intersectionWithKey f = coerce (OM.intersectionWith f) + +null :: forall k v. OMap k v -> Bool +null = coerce (OM.null @k @v) + +size :: forall k v. OMap k v -> Int +size = coerce (OM.size @k @v) + +member :: forall k v. Ord k => k -> OMap k v -> Bool +member = coerce (OM.member @k @v) + +notMember :: forall k v. Ord k => k -> OMap k v -> Bool +notMember = coerce (OM.notMember @k @v) + +lookup :: forall k v. Ord k => k -> OMap k v -> Maybe v +lookup = coerce (OM.lookup @k @v) + +lookupIndex :: forall k v. Ord k => k -> OMap k v -> Maybe Index +lookupIndex = coerce (OM.findIndex @k @v) + +lookupAt :: forall k v. Index -> OMap k v -> Maybe (k, v) +lookupAt i m = OM.elemAt @k @v (coerce m) i + +fromList :: Ord k => [(k, v)] -> OMap k v +fromList l = coerce (OM.fromList l) + +assocs :: forall k v. OMap k v -> [(k, v)] +assocs = coerce (OM.assocs @k @v) + +toAscList :: forall k v. OMap k v -> [(k, v)] +toAscList = coerce (OM.toAscList @k @v) + +toMap :: forall k v. OMap k v -> M.Map k v +toMap = coerce (OM.toMap @k @v) diff --git a/Language/Haskell/TH/Desugar/OSet.hs b/Language/Haskell/TH/Desugar/OSet.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/TH/Desugar/OSet.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Language.Haskell.TH.Desugar.OSet +-- Copyright : (C) 2016-2018 Daniel Wagner, 2019 Ryan Scott +-- License : BSD-style (see LICENSE) +-- Maintainer : Ryan Scott +-- Stability : experimental +-- Portability : non-portable +-- +-- An 'OSet' behaves much like a 'S.Set', with all the same asymptotics, but +-- also remembers the order that values were inserted. +-- +-- This module offers a simplified version of the "Data.Set.Ordered" API +-- that assumes left-biased indices everywhere. +-- +---------------------------------------------------------------------------- +module Language.Haskell.TH.Desugar.OSet + ( OSet + -- * Trivial sets + , empty, singleton + -- * Insertion + , insertPre, insertPost, union + -- * Query + , null, size, member, notMember + -- * Deletion + , delete, filter, (\\), intersection + -- * Indexing + , Index, lookupIndex, lookupAt + -- * List conversions + , fromList, toAscList + -- * 'Set' conversion + , toSet + ) where + +import Data.Coerce +import Data.Data +import qualified Data.Set as S (Set) +import Data.Set.Ordered (Bias(..), Index, L) +import qualified Data.Set.Ordered as OS +import Language.Haskell.TH.Desugar.OMap () +import Prelude hiding (filter, null) + +#if !(MIN_VERSION_base(4,11,0)) +import Data.Semigroup (Semigroup(..)) +#endif + +-- | An ordered set whose 'insertPre', 'insertPost', 'intersection', and 'union' +-- operations are biased towards leftmost indices when when breaking ties +-- between keys. +newtype OSet a = OSet (Bias L (OS.OSet a)) + deriving (Data, Foldable, Eq, Monoid, Ord, Read, Show) + +instance Ord a => Semigroup (OSet a) where + (<>) = union + +empty :: forall a. OSet a +empty = coerce (OS.empty @a) + +singleton :: a -> OSet a +singleton a = coerce (OS.singleton a) + +-- | The element's index will be lower than the indices of the elements in the +-- 'OSet'. +insertPre :: Ord a => a -> OSet a -> OSet a +insertPre a = coerce (a OS.|<) + +-- | The element's index will be higher than the indices of the elements in the +-- 'OSet'. +insertPost :: Ord a => OSet a -> a -> OSet a +insertPost s a = coerce (coerce s OS.|> a) + +union :: forall a. Ord a => OSet a -> OSet a -> OSet a +union = coerce ((OS.|<>) @a) + +null :: forall a. OSet a -> Bool +null = coerce (OS.null @a) + +size :: forall a. OSet a -> Int +size = coerce (OS.size @a) + +member, notMember :: Ord a => a -> OSet a -> Bool +member a = coerce (OS.member a) +notMember a = coerce (OS.notMember a) + +delete :: Ord a => a -> OSet a -> OSet a +delete a = coerce (OS.delete a) + +filter :: Ord a => (a -> Bool) -> OSet a -> OSet a +filter f = coerce (OS.filter f) + +(\\) :: forall a. Ord a => OSet a -> OSet a -> OSet a +(\\) = coerce ((OS.\\) @a) + +intersection :: forall a. Ord a => OSet a -> OSet a -> OSet a +intersection = coerce ((OS.|/\) @a) + +lookupIndex :: Ord a => a -> OSet a -> Maybe Index +lookupIndex a = coerce (OS.findIndex a) + +lookupAt :: forall a. Index -> OSet a -> Maybe a +lookupAt i s = OS.elemAt @a (coerce s) i + +fromList :: Ord a => [a] -> OSet a +fromList l = coerce (OS.fromList l) + +toAscList :: forall a. OSet a -> [a] +toAscList = coerce (OS.toAscList @a) + +toSet :: forall a. OSet a -> S.Set a +toSet = coerce (OS.toSet @a) 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,507 +1,1505 @@ {- Language/Haskell/TH/Desugar/Reify.hs (c) Richard Eisenberg 2014 -eir@cis.upenn.edu - -Allows for reification from a list of declarations, without looking a name -up in the environment. --} - -{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-} - -module Language.Haskell.TH.Desugar.Reify ( - -- * Reification - reifyWithLocals_maybe, reifyWithLocals, reifyWithWarning, reifyInDecs, - - -- ** Fixity reification - qReifyFixity, reifyFixity, reifyFixityWithLocals, reifyFixityInDecs, - - -- * Datatype lookup - getDataD, dataConNameToCon, dataConNameToDataName, - - -- * Monad support - DsMonad(..), DsM, withLocalDeclarations - ) where - -import Control.Monad.Reader -import Control.Monad.State -import Control.Monad.Writer -import Control.Monad.RWS -import Data.List -import Data.Maybe -#if __GLASGOW_HASKELL__ < 709 -import Control.Applicative -#endif -import qualified Data.Set as S -#if __GLASGOW_HASKELL__ >= 800 -import qualified Control.Monad.Fail as Fail -#else -import qualified Control.Monad as Fail -#endif - -import Language.Haskell.TH.Instances () -import Language.Haskell.TH.Syntax hiding ( lift ) - -import Language.Haskell.TH.Desugar.Util - --- | Like @reify@ from Template Haskell, but looks also in any not-yet-typechecked --- declarations. To establish this list of not-yet-typechecked declarations, --- use 'withLocalDeclarations'. Returns 'Nothing' if reification fails. --- Note that no inferred type information is available from local declarations; --- bottoms may be used if necessary. -reifyWithLocals_maybe :: DsMonad q => Name -> q (Maybe Info) -reifyWithLocals_maybe name = qRecover - (return . reifyInDecs name =<< localDeclarations) - (Just `fmap` qReify name) - --- | Like 'reifyWithLocals_maybe', but throws an exception upon failure, --- warning the user about separating splices. -reifyWithLocals :: DsMonad q => Name -> q Info -reifyWithLocals name = do - m_info <- reifyWithLocals_maybe name - case m_info of - Nothing -> reifyFail name - Just i -> return i - --- | Reify a declaration, warning the user about splices if the reify fails. --- The warning says that reification can fail if you try to reify a type in --- the same splice as it is declared. -reifyWithWarning :: Quasi q => Name -> q Info -reifyWithWarning name = qRecover (reifyFail name) (qReify name) - --- | Print out a warning about separating splices and fail. -#if __GLASGOW_HASKELL__ >= 800 -reifyFail :: Fail.MonadFail m => Name -> m a -#else -reifyFail :: Monad m => Name -> m a -#endif -reifyFail name = - Fail.fail $ "Looking up " ++ (show name) ++ " in the list of available " ++ - "declarations failed.\nThis lookup fails if the declaration " ++ - "referenced was made in the same Template\nHaskell splice as the use " ++ - "of the declaration. If this is the case, put\nthe reference to " ++ - "the declaration in a new splice." - ---------------------------------- --- Utilities ---------------------------------- - --- | Extract the @TyVarBndr@s and constructors given the @Name@ of a type -getDataD :: Quasi q - => String -- ^ Print this out on failure - -> Name -- ^ Name of the datatype (@data@ or @newtype@) of interest - -> q ([TyVarBndr], [Con]) -getDataD err name = do - info <- reifyWithWarning name - dec <- case info of - TyConI dec -> return dec - _ -> badDeclaration - case dec of -#if __GLASGOW_HASKELL__ > 710 - DataD _cxt _name tvbs _mk cons _derivings -> return (tvbs, cons) - NewtypeD _cxt _name tvbs _mk con _derivings -> return (tvbs, [con]) -#else - DataD _cxt _name tvbs cons _derivings -> return (tvbs, cons) - NewtypeD _cxt _name tvbs con _derivings -> return (tvbs, [con]) -#endif - _ -> badDeclaration - where badDeclaration = - fail $ "The name (" ++ (show name) ++ ") refers to something " ++ - "other than a datatype. " ++ err - --- | From the name of a data constructor, retrive the datatype definition it --- is a part of. -dataConNameToDataName :: Quasi q => Name -> q Name -dataConNameToDataName con_name = do - info <- reifyWithWarning con_name - case info of -#if __GLASGOW_HASKELL__ > 710 - DataConI _name _type parent_name -> return parent_name -#else - DataConI _name _type parent_name _fixity -> return parent_name -#endif - _ -> fail $ "The name " ++ show con_name ++ " does not appear to be " ++ - "a data constructor." - --- | From the name of a data constructor, retrieve its definition as a @Con@ -dataConNameToCon :: Quasi q => Name -> q Con -dataConNameToCon con_name = do - -- we need to get the field ordering from the constructor. We must reify - -- the constructor to get the tycon, and then reify the tycon to get the `Con`s - type_name <- dataConNameToDataName con_name - (_, cons) <- getDataD "This seems to be an error in GHC." type_name - let m_con = find (any (con_name ==) . get_con_name) cons - case m_con of - Just con -> return con - Nothing -> impossible "Datatype does not contain one of its own constructors." - - where - get_con_name (NormalC name _) = [name] - get_con_name (RecC name _) = [name] - get_con_name (InfixC _ name _) = [name] - get_con_name (ForallC _ _ con) = get_con_name con -#if __GLASGOW_HASKELL__ > 710 - get_con_name (GadtC names _ _) = names - get_con_name (RecGadtC names _ _) = names -#endif - --------------------------------------------------- --- DsMonad --------------------------------------------------- - --- | A 'DsMonad' stores some list of declarations that should be considered --- in scope. 'DsM' is the prototypical inhabitant of 'DsMonad'. -class Quasi m => DsMonad m where - -- | Produce a list of local declarations. - localDeclarations :: m [Dec] - -instance DsMonad Q where - localDeclarations = return [] -instance DsMonad IO where - localDeclarations = return [] - --- | A convenient implementation of the 'DsMonad' class. Use by calling --- 'withLocalDeclarations'. -newtype DsM q a = DsM (ReaderT [Dec] q a) - deriving ( Functor, Applicative, Monad, MonadTrans, Quasi -#if __GLASGOW_HASKELL__ >= 800 - , Fail.MonadFail -#endif - ) - -instance Quasi q => DsMonad (DsM q) where - localDeclarations = DsM ask - -instance DsMonad m => DsMonad (ReaderT r m) where - localDeclarations = lift localDeclarations - -instance DsMonad m => DsMonad (StateT s m) where - localDeclarations = lift localDeclarations - -instance (DsMonad m, Monoid w) => DsMonad (WriterT w m) where - localDeclarations = lift localDeclarations - -instance (DsMonad m, Monoid w) => DsMonad (RWST r w s m) where - localDeclarations = lift localDeclarations - --- | Add a list of declarations to be considered when reifying local --- declarations. -withLocalDeclarations :: DsMonad q => [Dec] -> DsM q a -> q a -withLocalDeclarations new_decs (DsM x) = do - orig_decs <- localDeclarations - runReaderT x (orig_decs ++ new_decs) - ---------------------------- --- Reifying local declarations ---------------------------- - --- | Look through a list of declarations and possibly return a relevant 'Info' -reifyInDecs :: Name -> [Dec] -> Maybe Info -reifyInDecs n decs = firstMatch (reifyInDec n decs) decs - --- | Look through a list of declarations and possibly return a fixity. -reifyFixityInDecs :: Name -> [Dec] -> Maybe Fixity -reifyFixityInDecs n = firstMatch match_fixity - where - match_fixity (InfixD fixity n') | n `nameMatches` n' = Just fixity - match_fixity _ = Nothing - - -reifyInDec :: Name -> [Dec] -> Dec -> Maybe Info -reifyInDec n decs (FunD n' _) | n `nameMatches` n' = Just $ mkVarI n decs -reifyInDec n decs (ValD pat _ _) - | any (nameMatches n) (S.elems (extractBoundNamesPat pat)) = Just $ mkVarI n decs -#if __GLASGOW_HASKELL__ > 710 -reifyInDec n _ dec@(DataD _ n' _ _ _ _) | n `nameMatches` n' = Just $ TyConI dec -reifyInDec n _ dec@(NewtypeD _ n' _ _ _ _) | n `nameMatches` n' = Just $ TyConI dec -#else -reifyInDec n _ dec@(DataD _ n' _ _ _) | n `nameMatches` n' = Just $ TyConI dec -reifyInDec n _ dec@(NewtypeD _ n' _ _ _) | n `nameMatches` n' = Just $ TyConI dec -#endif -reifyInDec n _ dec@(TySynD n' _ _) | n `nameMatches` n' = Just $ TyConI dec -reifyInDec n decs dec@(ClassD _ n' _ _ _) | n `nameMatches` n' - = Just $ ClassI (stripClassDec dec) (findInstances n decs) -reifyInDec n decs (ForeignD (ImportF _ _ _ n' ty)) | n `nameMatches` n' - = Just $ mkVarITy n decs ty -reifyInDec n decs (ForeignD (ExportF _ _ n' ty)) | n `nameMatches` n' - = Just $ mkVarITy n decs ty -#if __GLASGOW_HASKELL__ > 710 -reifyInDec n decs dec@(OpenTypeFamilyD (TypeFamilyHead n' _ _ _)) | n `nameMatches` n' - = Just $ FamilyI (handleBug8884 dec) (findInstances n decs) -reifyInDec n decs dec@(DataFamilyD n' _ _) | n `nameMatches` n' - = Just $ FamilyI (handleBug8884 dec) (findInstances n decs) -reifyInDec n _ dec@(ClosedTypeFamilyD (TypeFamilyHead n' _ _ _) _) | n `nameMatches` n' - = Just $ FamilyI dec [] -#else -reifyInDec n decs dec@(FamilyD _ n' _ _) | n `nameMatches` n' - = Just $ FamilyI (handleBug8884 dec) (findInstances n decs) -#if __GLASGOW_HASKELL__ >= 707 -reifyInDec n _ dec@(ClosedTypeFamilyD n' _ _ _) | n `nameMatches` n' - = Just $ FamilyI dec [] -#endif -#endif - -#if __GLASGOW_HASKELL__ > 710 -reifyInDec n decs (DataD _ ty_name tvbs _mk cons _) - | Just info <- maybeReifyCon n decs ty_name (map tvbToType tvbs) cons - = Just info -reifyInDec n decs (NewtypeD _ ty_name tvbs _mk con _) - | Just info <- maybeReifyCon n decs ty_name (map tvbToType tvbs) [con] - = Just info -#else -reifyInDec n decs (DataD _ ty_name tvbs cons _) - | Just info <- maybeReifyCon n decs ty_name (map tvbToType tvbs) cons - = Just info -reifyInDec n decs (NewtypeD _ ty_name tvbs con _) - | Just info <- maybeReifyCon n decs ty_name (map tvbToType tvbs) [con] - = Just info -#endif -#if __GLASGOW_HASKELL__ > 710 -reifyInDec n _decs (ClassD _ ty_name tvbs _ sub_decs) - | Just ty <- findType n sub_decs - = Just $ ClassOpI n (addClassCxt ty_name tvbs ty) ty_name -#else -reifyInDec n decs (ClassD _ ty_name tvbs _ sub_decs) - | Just ty <- findType n sub_decs - = Just $ ClassOpI n (addClassCxt ty_name tvbs ty) - ty_name (fromMaybe defaultFixity $ - reifyFixityInDecs n $ sub_decs ++ decs) -#endif -reifyInDec n decs (ClassD _ _ _ _ sub_decs) - | Just info <- firstMatch (reifyInDec n (sub_decs ++ decs)) sub_decs - = Just info -#if __GLASGOW_HASKELL__ >= 711 -reifyInDec n decs (InstanceD _ _ _ sub_decs) -#else -reifyInDec n decs (InstanceD _ _ sub_decs) -#endif - | Just info <- firstMatch reify_in_instance sub_decs - = Just info - where - reify_in_instance dec@(DataInstD {}) = reifyInDec n (sub_decs ++ decs) dec - reify_in_instance dec@(NewtypeInstD {}) = reifyInDec n (sub_decs ++ decs) dec - reify_in_instance _ = Nothing -#if __GLASGOW_HASKELL__ > 710 -reifyInDec n decs (DataInstD _ ty_name tys _ cons _) - | Just info <- maybeReifyCon n decs ty_name tys cons - = Just info -reifyInDec n decs (NewtypeInstD _ ty_name tys _ con _) - | Just info <- maybeReifyCon n decs ty_name tys [con] - = Just info -#else -reifyInDec n decs (DataInstD _ ty_name tys cons _) - | Just info <- maybeReifyCon n decs ty_name tys cons - = Just info -reifyInDec n decs (NewtypeInstD _ ty_name tys con _) - | Just info <- maybeReifyCon n decs ty_name tys [con] - = Just info -#endif - -reifyInDec _ _ _ = Nothing - -maybeReifyCon :: Name -> [Dec] -> Name -> [Type] -> [Con] -> Maybe Info -#if __GLASGOW_HASKELL__ > 710 -maybeReifyCon n _decs ty_name ty_args cons - | Just con <- findCon n cons - = Just $ DataConI n (maybeForallT tvbs [] $ con_to_type con) ty_name -#else -maybeReifyCon n decs ty_name ty_args cons - | Just con <- findCon n cons - = Just $ DataConI n (maybeForallT tvbs [] $ con_to_type con) - ty_name fixity -#endif - - | Just ty <- findRecSelector n cons - -- we don't try to ferret out naughty record selectors. -#if __GLASGOW_HASKELL__ > 710 - = Just $ VarI n (maybeForallT tvbs [] $ mkArrows [result_ty] ty) Nothing -#else - = Just $ VarI n (maybeForallT tvbs [] $ mkArrows [result_ty] ty) Nothing fixity -#endif - where - result_ty = foldl AppT (ConT ty_name) ty_args - - con_to_type (NormalC _ stys) = mkArrows (map snd stys) result_ty - con_to_type (RecC _ vstys) = mkArrows (map thdOf3 vstys) result_ty - con_to_type (InfixC t1 _ t2) = mkArrows (map snd [t1, t2]) result_ty - con_to_type (ForallC bndrs cxt c) = ForallT bndrs cxt (con_to_type c) -#if __GLASGOW_HASKELL__ > 710 - con_to_type (GadtC _ stys rty) = mkArrows (map snd stys) rty - con_to_type (RecGadtC _ vstys rty) = mkArrows (map thdOf3 vstys) rty -#endif -#if __GLASGOW_HASKELL__ < 711 - fixity = fromMaybe defaultFixity $ reifyFixityInDecs n decs -#endif - tvbs = map PlainTV $ S.elems $ freeNamesOfTypes ty_args -maybeReifyCon _ _ _ _ _ = Nothing - -mkVarI :: Name -> [Dec] -> Info -mkVarI n decs = mkVarITy n decs (fromMaybe no_type $ findType n decs) - where - no_type = error $ "No type information found in local declaration for " - ++ show n - -mkVarITy :: Name -> [Dec] -> Type -> Info -#if __GLASGOW_HASKELL__ > 710 -mkVarITy n _decs ty = VarI n ty Nothing -#else -mkVarITy n decs ty = VarI n ty Nothing (fromMaybe defaultFixity $ - reifyFixityInDecs n decs) -#endif - -findType :: Name -> [Dec] -> Maybe Type -findType n = firstMatch match_type - where - match_type (SigD n' ty) | n `nameMatches` n' = Just ty - match_type _ = Nothing - -findInstances :: Name -> [Dec] -> [Dec] -findInstances n = map stripInstanceDec . concatMap match_instance - where -#if __GLASGOW_HASKELL__ >= 711 - match_instance d@(InstanceD _ _ ty _) -#else - match_instance d@(InstanceD _ ty _) -#endif - | ConT n' <- ty_head ty - , n `nameMatches` n' = [d] -#if __GLASGOW_HASKELL__ > 710 - match_instance d@(DataInstD _ n' _ _ _ _) | n `nameMatches` n' = [d] - match_instance d@(NewtypeInstD _ n' _ _ _ _) | n `nameMatches` n' = [d] -#else - match_instance d@(DataInstD _ n' _ _ _) | n `nameMatches` n' = [d] - match_instance d@(NewtypeInstD _ n' _ _ _) | n `nameMatches` n' = [d] -#endif -#if __GLASGOW_HASKELL__ >= 707 - match_instance d@(TySynInstD n' _) | n `nameMatches` n' = [d] -#else - match_instance d@(TySynInstD n' _ _) | n `nameMatches` n' = [d] -#endif - -#if __GLASGOW_HASKELL__ >= 711 - match_instance (InstanceD _ _ _ decs) -#else - match_instance (InstanceD _ _ decs) -#endif - = concatMap match_instance decs - match_instance _ = [] - - ty_head (ForallT _ _ ty) = ty_head ty - ty_head (AppT ty _) = ty_head ty - ty_head (SigT ty _) = ty_head ty - ty_head ty = ty - -stripClassDec :: Dec -> Dec -stripClassDec (ClassD cxt name tvbs fds sub_decs) - = ClassD cxt name tvbs fds sub_decs' - where - sub_decs' = mapMaybe go sub_decs - go (SigD n ty) = Just $ SigD n $ addClassCxt name tvbs ty -#if __GLASGOW_HASKELL__ > 710 - go d@(OpenTypeFamilyD {}) = Just d - go d@(DataFamilyD {}) = Just d -#endif - go _ = Nothing -stripClassDec dec = dec - -addClassCxt :: Name -> [TyVarBndr] -> Type -> Type -addClassCxt class_name tvbs ty = ForallT tvbs class_cxt ty - where -#if __GLASGOW_HASKELL__ < 709 - class_cxt = [ClassP class_name (map tvbToType tvbs)] -#else - class_cxt = [foldl AppT (ConT class_name) (map tvbToType tvbs)] -#endif - -stripInstanceDec :: Dec -> Dec -#if __GLASGOW_HASKELL__ >= 711 -stripInstanceDec (InstanceD over cxt ty _) = InstanceD over cxt ty [] -#else -stripInstanceDec (InstanceD cxt ty _) = InstanceD cxt ty [] -#endif -stripInstanceDec dec = dec - -mkArrows :: [Type] -> Type -> Type -mkArrows [] res_ty = res_ty -mkArrows (t:ts) res_ty = AppT (AppT ArrowT t) $ mkArrows ts res_ty - -maybeForallT :: [TyVarBndr] -> Cxt -> Type -> Type -maybeForallT tvbs cxt ty - | null tvbs && null cxt = ty - | ForallT tvbs2 cxt2 ty2 <- ty = ForallT (tvbs ++ tvbs2) (cxt ++ cxt2) ty2 - | otherwise = ForallT tvbs cxt ty - -findCon :: Name -> [Con] -> Maybe Con -findCon n = find match_con - where - match_con (NormalC n' _) = n `nameMatches` n' - match_con (RecC n' _) = n `nameMatches` n' - match_con (InfixC _ n' _) = n `nameMatches` n' - match_con (ForallC _ _ c) = match_con c -#if __GLASGOW_HASKELL__ > 710 - match_con (GadtC nms _ _) = any (n `nameMatches`) nms - match_con (RecGadtC nms _ _) = any (n `nameMatches`) nms -#endif - -findRecSelector :: Name -> [Con] -> Maybe Type -findRecSelector n = firstMatch match_con - where - match_con (RecC _ vstys) = firstMatch match_rec_sel vstys - match_con (ForallC _ _ c) = match_con c - match_con _ = Nothing - - match_rec_sel (n', _, ty) | n `nameMatches` n' = Just ty - match_rec_sel _ = Nothing - -handleBug8884 :: Dec -> Dec -#if __GLASGOW_HASKELL__ >= 707 -handleBug8884 = id -#else -handleBug8884 (FamilyD flav name tvbs m_kind) - = FamilyD flav name tvbs (Just stupid_kind) - where - kind_from_maybe = fromMaybe StarT - tvb_kind (PlainTV _) = Nothing - tvb_kind (KindedTV _ k) = Just k - - result_kind = kind_from_maybe m_kind - args_kinds = map (kind_from_maybe . tvb_kind) tvbs - - stupid_kind = mkArrows args_kinds result_kind -handleBug8884 dec = dec -#endif - ---------------------------------- --- Reifying fixities ---------------------------------- --- --- This section allows GHC 7.x to call reifyFixity - -#if __GLASGOW_HASKELL__ < 711 -qReifyFixity :: Quasi m => Name -> m (Maybe Fixity) -qReifyFixity name = do - info <- qReify name - return $ case info of - ClassOpI _ _ _ fixity -> Just fixity - DataConI _ _ _ fixity -> Just fixity - VarI _ _ _ fixity -> Just fixity - _ -> Nothing - -{- | @reifyFixity nm@ attempts to find a fixity declaration for @nm@. For -example, if the function @foo@ has the fixity declaration @infixr 7 foo@, then -@reifyFixity 'foo@ would return @'Just' ('Fixity' 7 'InfixR')@. If the function -@bar@ does not have a fixity declaration, then @reifyFixity 'bar@ returns -'Nothing', so you may assume @bar@ has 'defaultFixity'. --} -reifyFixity :: Name -> Q (Maybe Fixity) -reifyFixity = qReifyFixity -#endif - --- | Like 'reifyWithLocals_maybe', but for fixities. Note that a return of --- @Nothing@ might mean that the name is not in scope, or it might mean --- that the name has no assigned fixity. (Use 'reifyWithLocals_maybe' if --- you really need to tell the difference.) -reifyFixityWithLocals :: DsMonad q => Name -> q (Maybe Fixity) -reifyFixityWithLocals name = qRecover - (return . reifyFixityInDecs name =<< localDeclarations) - (qReifyFixity name) +rae@cs.brynmawr.edu + +Allows for reification from a list of declarations, without looking a name +up in the environment. +-} + +{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, ScopedTypeVariables #-} + +module Language.Haskell.TH.Desugar.Reify ( + -- * Reification + reifyWithLocals_maybe, reifyWithLocals, reifyWithWarning, reifyInDecs, + + -- ** Fixity reification + qReifyFixity, reifyFixity, reifyFixityWithLocals, reifyFixityInDecs, + + -- ** Type reification + qReifyType, reifyType, + reifyTypeWithLocals_maybe, reifyTypeWithLocals, reifyTypeInDecs, + + -- * Datatype lookup + getDataD, dataConNameToCon, dataConNameToDataName, + + -- * Value and type lookup + lookupValueNameWithLocals, lookupTypeNameWithLocals, + mkDataNameWithLocals, mkTypeNameWithLocals, + reifyNameSpace, + + -- * Monad support + DsMonad(..), DsM, withLocalDeclarations + ) where + +import Control.Applicative +import qualified Control.Monad.Fail as Fail +import Control.Monad.Reader +import Control.Monad.State +import Control.Monad.Writer +import Control.Monad.RWS +import Control.Monad.Trans.Instances () +import qualified Data.Foldable as F +import Data.Function (on) +import qualified Data.List as List +import qualified Data.Map as Map +import Data.Map (Map) +import Data.Maybe +import qualified Data.Set as Set +import Data.Set (Set) + +import Language.Haskell.TH.Datatype ( freeVariables, freeVariablesWellScoped + , quantifyType, resolveTypeSynonyms ) +import Language.Haskell.TH.Datatype.TyVarBndr +import Language.Haskell.TH.Instances () +import Language.Haskell.TH.Syntax hiding ( lift ) +import qualified Language.Haskell.TH.Syntax.Compat as Compat ( Quote ) + +import Language.Haskell.TH.Desugar.Util as Util + +#if __GLASGOW_HASKELL__ >= 907 +import qualified Language.Haskell.TH as LangExt (Extension(..)) +#endif + +-- | Like @reify@ from Template Haskell, but looks also in any not-yet-typechecked +-- declarations. To establish this list of not-yet-typechecked declarations, +-- use 'withLocalDeclarations'. Returns 'Nothing' if reification fails. +-- Note that no inferred type information is available from local declarations; +-- bottoms may be used if necessary. +reifyWithLocals_maybe :: DsMonad q => Name -> q (Maybe Info) +reifyWithLocals_maybe name = qRecover + (return . reifyInDecs name =<< localDeclarations) + (Just `fmap` qReify name) + +-- | Like 'reifyWithLocals_maybe', but throws an exception upon failure, +-- warning the user about separating splices. +reifyWithLocals :: DsMonad q => Name -> q Info +reifyWithLocals name = do + m_info <- reifyWithLocals_maybe name + case m_info of + Nothing -> reifyFail name + Just i -> return i + +-- | Reify a declaration, warning the user about splices if the reify fails. +-- The warning says that reification can fail if you try to reify a type in +-- the same splice as it is declared. +reifyWithWarning :: (Quasi q, Fail.MonadFail q) => Name -> q Info +reifyWithWarning name = qRecover (reifyFail name) (qReify name) + +-- | Print out a warning about separating splices and fail. +reifyFail :: Fail.MonadFail m => Name -> m a +reifyFail name = + Fail.fail $ "Looking up " ++ (show name) ++ " in the list of available " ++ + "declarations failed.\nThis lookup fails if the declaration " ++ + "referenced was made in the same Template\nHaskell splice as the use " ++ + "of the declaration. If this is the case, put\nthe reference to " ++ + "the declaration in a new splice." + +--------------------------------- +-- Utilities +--------------------------------- + +-- | Extract the 'DataFlavor', 'TyVarBndr's and constructors given the 'Name' +-- of a type. +getDataD :: DsMonad q + => String -- ^ Print this out on failure + -> Name -- ^ Name of the datatype (@data@ or @newtype@) of interest + -> q (DataFlavor, [TyVarBndrVis], [Con]) +getDataD err name = do + info <- reifyWithLocals name + dec <- case info of + TyConI dec -> return dec + _ -> badDeclaration + case dec of + DataD _cxt _name tvbs mk cons _derivings -> go Data tvbs mk cons + NewtypeD _cxt _name tvbs mk con _derivings -> go Newtype tvbs mk [con] +#if __GLASGOW_HASKELL__ >= 906 + TypeDataD _name tvbs mk cons -> go Util.TypeData tvbs mk cons +#endif + _ -> badDeclaration + where + go df tvbs mk cons = do + let k = fromMaybe (ConT typeKindName) mk + extra_tvbs <- mkExtraKindBinders k + let all_tvbs = tvbs ++ extra_tvbs + return (df, all_tvbs, cons) + + badDeclaration = + fail $ "The name (" ++ (show name) ++ ") refers to something " ++ + "other than a datatype. " ++ err + +-- | Create new kind variable binder names corresponding to the return kind of +-- a data type. This is useful when you have a data type like: +-- +-- @ +-- data Foo :: forall k. k -> Type -> Type where ... +-- @ +-- +-- But you want to be able to refer to the type @Foo a b@. +-- 'mkExtraKindBinders' will take the kind @forall k. k -> Type -> Type@, +-- discover that is has two visible argument kinds, and return as a result +-- two new kind variable binders @[a :: k, b :: Type]@, where @a@ and @b@ +-- are fresh type variable names. +-- +-- This expands kind synonyms if necessary. +mkExtraKindBinders :: forall q. Quasi q => Kind -> q [TyVarBndrVis] +mkExtraKindBinders k = do + k' <- runQ $ resolveTypeSynonyms k + let (fun_args, _) = unravelType k' + vis_fun_args = filterVisFunArgs fun_args + mapM mk_tvb vis_fun_args + where + mk_tvb :: VisFunArg -> q TyVarBndrVis + mk_tvb (VisFADep tvb) = return $ mapTVFlag (const BndrReq) tvb + mk_tvb (VisFAAnon ki) = do + name <- qNewName "a" + pure $ kindedTVFlag name BndrReq ki + +-- | From the name of a data constructor, retrive the datatype definition it +-- is a part of. +dataConNameToDataName :: DsMonad q => Name -> q Name +dataConNameToDataName con_name = do + info <- reifyWithLocals con_name + case info of + DataConI _name _type parent_name -> return parent_name + _ -> fail $ "The name " ++ show con_name ++ " does not appear to be " ++ + "a data constructor." + +-- | From the name of a data constructor, retrieve its definition as a @Con@ +dataConNameToCon :: DsMonad q => Name -> q Con +dataConNameToCon con_name = do + -- we need to get the field ordering from the constructor. We must reify + -- the constructor to get the tycon, and then reify the tycon to get the `Con`s + type_name <- dataConNameToDataName con_name + (_, _, cons) <- getDataD "This seems to be an error in GHC." type_name + let m_con = List.find (any (con_name ==) . get_con_name) cons + case m_con of + Just con -> return con + Nothing -> impossible "Datatype does not contain one of its own constructors." + + where + get_con_name (NormalC name _) = [name] + get_con_name (RecC name _) = [name] + get_con_name (InfixC _ name _) = [name] + get_con_name (ForallC _ _ con) = get_con_name con + get_con_name (GadtC names _ _) = names + get_con_name (RecGadtC names _ _) = names + +-------------------------------------------------- +-- DsMonad +-------------------------------------------------- + +-- | A 'DsMonad' stores some list of declarations that should be considered +-- in scope. 'DsM' is the prototypical inhabitant of 'DsMonad'. +class (Quasi m, Fail.MonadFail m) => DsMonad m where + -- | Produce a list of local declarations. + localDeclarations :: m [Dec] + +instance DsMonad Q where + localDeclarations = return [] +instance DsMonad IO where + localDeclarations = return [] + +-- | A convenient implementation of the 'DsMonad' class. Use by calling +-- 'withLocalDeclarations'. +newtype DsM q a = DsM (ReaderT [Dec] q a) + deriving ( Functor, Applicative, Monad, MonadTrans, Fail.MonadFail + , Quasi, Compat.Quote +#if __GLASGOW_HASKELL__ >= 803 + , MonadIO +#endif + ) + +instance (Quasi q, Fail.MonadFail q) => DsMonad (DsM q) where + localDeclarations = DsM ask + +instance DsMonad m => DsMonad (ReaderT r m) where + localDeclarations = lift localDeclarations + +instance DsMonad m => DsMonad (StateT s m) where + localDeclarations = lift localDeclarations + +instance (DsMonad m, Monoid w) => DsMonad (WriterT w m) where + localDeclarations = lift localDeclarations + +instance (DsMonad m, Monoid w) => DsMonad (RWST r w s m) where + localDeclarations = lift localDeclarations + +-- | Add a list of declarations to be considered when reifying local +-- declarations. +withLocalDeclarations :: DsMonad q => [Dec] -> DsM q a -> q a +withLocalDeclarations new_decs (DsM x) = do + orig_decs <- localDeclarations + runReaderT x (orig_decs ++ new_decs) + +--------------------------- +-- Reifying local declarations +--------------------------- + +-- | Look through a list of declarations and possibly return a relevant 'Info' +reifyInDecs :: Name -> [Dec] -> Maybe Info +reifyInDecs n decs = snd `fmap` firstMatch (reifyInDec n decs) decs + +-- | Look through a list of declarations and possibly return a fixity. +reifyFixityInDecs :: Name -> [Dec] -> Maybe Fixity +reifyFixityInDecs n = firstMatch match_fixity + where + match_fixity (InfixD fixity +#if __GLASGOW_HASKELL__ >= 909 + _ +#endif + n') | n `nameMatches` n' + = Just fixity + match_fixity (ClassD _ _ _ _ sub_decs) = firstMatch match_fixity sub_decs + match_fixity _ = Nothing + +-- | A reified thing along with the name of that thing. +type Named a = (Name, a) + +reifyInDec :: Name -> [Dec] -> Dec -> Maybe (Named Info) +reifyInDec n decs (FunD n' _) | n `nameMatches` n' = Just (n', mkVarI n decs) +reifyInDec n decs (ValD pat _ _) + | Just n' <- List.find (nameMatches n) (F.toList (extractBoundNamesPat pat)) + = Just (n', mkVarI n decs) +reifyInDec n _ dec@(DataD _ n' _ _ _ _) | n `nameMatches` n' = Just (n', TyConI dec) +reifyInDec n _ dec@(NewtypeD _ n' _ _ _ _) | n `nameMatches` n' = Just (n', TyConI dec) +reifyInDec n _ dec@(TySynD n' _ _) | n `nameMatches` n' = Just (n', TyConI dec) +reifyInDec n decs dec@(ClassD _ n' _ _ _) | n `nameMatches` n' + = Just (n', ClassI (quantifyClassDecMethods dec) (findInstances n decs)) +reifyInDec n _ (ForeignD (ImportF _ _ _ n' ty)) | n `nameMatches` n' + = Just (n', mkVarITy n ty) +reifyInDec n _ (ForeignD (ExportF _ _ n' ty)) | n `nameMatches` n' + = Just (n', mkVarITy n ty) +reifyInDec n decs dec@(OpenTypeFamilyD (TypeFamilyHead n' _ _ _)) | n `nameMatches` n' + = Just (n', FamilyI dec (findInstances n decs)) +reifyInDec n decs dec@(DataFamilyD n' _ _) | n `nameMatches` n' + = Just (n', FamilyI dec (findInstances n decs)) +reifyInDec n _ dec@(ClosedTypeFamilyD (TypeFamilyHead n' _ _ _) _) | n `nameMatches` n' + = Just (n', FamilyI dec []) +#if __GLASGOW_HASKELL__ >= 801 +reifyInDec n decs (PatSynD n' _ _ _) | n `nameMatches` n' + = Just (n', mkPatSynI n decs) +#endif +#if __GLASGOW_HASKELL__ >= 906 +reifyInDec n _ dec@(TypeDataD n' _ _ _) | n `nameMatches` n' = Just (n', TyConI dec) +#endif + +reifyInDec n decs (DataD _ ty_name tvbs _mk cons _) + | Just info <- maybeReifyCon n decs ty_name + (matchUpSAKWithTvbsSpec decs ty_name tvbs) + (applyType (ConT ty_name) (map tyVarBndrVisToTypeArg tvbs)) + cons + = Just info +reifyInDec n decs (NewtypeD _ ty_name tvbs _mk con _) + | Just info <- maybeReifyCon n decs ty_name + (matchUpSAKWithTvbsSpec decs ty_name tvbs) + (applyType (ConT ty_name) (map tyVarBndrVisToTypeArg tvbs)) + [con] + = Just info +reifyInDec n decs (ClassD _ cls_name cls_tvbs _ sub_decs) + | Just (n', ty) <- findType n sub_decs + = Just (n', ClassOpI n + (quantifyClassMethodType + (matchUpSAKWithTvbsSpec decs cls_name cls_tvbs) + (applyType (ConT cls_name) (map tyVarBndrVisToTypeArg cls_tvbs)) + True ty) + cls_name) +reifyInDec n decs (ClassD _ _ _ _ sub_decs) + | Just info <- firstMatch (reifyInDec n decs) sub_decs + -- Important: don't pass (sub_decs ++ decs) to reifyInDec + -- above, or else type family defaults can be confused for + -- actual instances. See #134. + = Just info +reifyInDec n decs (InstanceD _ _ _ sub_decs) + | Just info <- firstMatch reify_in_instance sub_decs + = Just info + where + reify_in_instance dec@(DataInstD {}) = reifyInDec n (sub_decs ++ decs) dec + reify_in_instance dec@(NewtypeInstD {}) = reifyInDec n (sub_decs ++ decs) dec + reify_in_instance _ = Nothing +#if __GLASGOW_HASKELL__ >= 801 +reifyInDec n decs (PatSynD pat_syn_name args _ _) + | Just (n', full_sel_ty) <- maybeReifyPatSynRecSelector n decs pat_syn_name args + = Just (n', VarI n full_sel_ty Nothing) +#endif +#if __GLASGOW_HASKELL__ >= 807 +reifyInDec n decs (DataInstD _ mtvbs lhs _ cons _) + | (ConT ty_name, tys) <- unfoldType lhs + , Just info <- maybeReifyCon n decs ty_name + (dataFamInstH98ConTvbs mtvbs tys) + -- Why do we reapply `ty_name` to `tys` here instead of just + -- reusing `lhs`? See Note [Apply data family type + -- constructors in prefix form in local reification]. + (applyType (ConT ty_name) tys) + cons + = Just info +reifyInDec n decs (NewtypeInstD _ mtvbs lhs _ con _) + | (ConT ty_name, tys) <- unfoldType lhs + , Just info <- maybeReifyCon n decs ty_name + (dataFamInstH98ConTvbs mtvbs tys) + -- Why do we reapply `ty_name` to `tys` here instead of just + -- reusing `lhs`? See Note [Apply data family type + -- constructors in prefix form in local reification]. + (applyType (ConT ty_name) tys) + [con] + = Just info +#else +reifyInDec n decs (DataInstD _ ty_name tys _ cons _) + | Just info <- maybeReifyCon n decs ty_name + (dataFamInstH98ConTvbsNoInstTvbs tys) + (applyType (ConT ty_name) (map TANormal tys)) + cons + = Just info +reifyInDec n decs (NewtypeInstD _ ty_name tys _ con _) + | Just info <- maybeReifyCon n decs ty_name + (dataFamInstH98ConTvbsNoInstTvbs tys) + (applyType (ConT ty_name) (map TANormal tys)) + [con] + = Just info +#endif +#if __GLASGOW_HASKELL__ >= 906 +reifyInDec n decs (TypeDataD ty_name tvbs _mk cons) + | Just info <- maybeReifyCon n decs ty_name + (matchUpSAKWithTvbsSpec decs ty_name tvbs) + (applyType (ConT ty_name) (map tyVarBndrVisToTypeArg tvbs)) + cons + = Just info +#endif + +reifyInDec _ _ _ = Nothing + +maybeReifyCon :: + Name + -> [Dec] + -> Name + -> [TyVarBndrSpec] + -- ^ The universally quantified type variables, derived from the parent + -- data declaration. This is only used if reifying a Haskell98-style data + -- constructor. + -> Type + -- ^ The data constructor's return type, derived from the parent data + -- declaration. This is only used if reifying a Haskell98-style data + -- constructor. + -> [Con] + -> Maybe (Named Info) +maybeReifyCon n _decs ty_name h98_tvbs h98_res_ty cons + | Just (n', con) <- findCon n cons + -- See Note [Use unSigType in maybeReifyCon] + , let full_con_ty = unSigType $ con_to_type h98_tvbs h98_res_ty con + = Just (n', DataConI n full_con_ty ty_name) + + | Just (n', rec_sel_info) <- findRecSelector n cons + , let (tvbs, sel_ty, con_res_ty) = extract_rec_sel_info rec_sel_info + -- See Note [Use unSigType in maybeReifyCon] + full_sel_ty = unSigType $ maybeForallT tvbs [] $ mkArrows [con_res_ty] sel_ty + -- we don't try to ferret out naughty record selectors. + = Just (n', VarI n full_sel_ty Nothing) + where + extract_rec_sel_info :: RecSelInfo -> ([TyVarBndrSpec], Type, Type) + -- Returns ( Selector type variable binders + -- , Record field type + -- , constructor result type ) + extract_rec_sel_info rec_sel_info = + case rec_sel_info of + RecSelH98 sel_ty -> + let -- All of the type variables bound by the data type, with any + -- implicitly quantified kind variables made explicit. + all_h98_tvbs = quantifyAllTvbsSpec h98_tvbs in + ( all_h98_tvbs + , sel_ty + , h98_res_ty + ) + RecSelGADT mb_con_tvbs sel_ty con_res_ty -> + let -- If the GADT constructor type signature explicitly quantifies + -- its type variables, make sure to use that same order in the + -- record selector's type. + con_tvbs' = + case mb_con_tvbs of + Just con_tvbs -> con_tvbs + Nothing -> + changeTVFlags SpecifiedSpec $ + freeVariablesWellScoped [con_res_ty, sel_ty] in + ( con_tvbs' + , sel_ty + , con_res_ty + ) + +maybeReifyCon _ _ _ _ _ _ = Nothing + +#if __GLASGOW_HASKELL__ >= 801 +-- | Attempt to reify the type of a pattern synonym record selector @n@. +-- The algorithm for computing this type works as follows: +-- +-- 1. Reify the type of the parent pattern synonym. Broadly speaking, this +-- will look something like: +-- +-- @ +-- pattern P :: forall . req_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. + +Note [Apply data family type constructors in prefix form in local reification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we wish to locally reify the type of `MkD` below: + + data family a :&: b + data instance a :&: b = MkD a b + +You might be tempted to think that the return type should be: + + MkD :: a -> b -> a :&: b + +However, keep in mind that local reification tries its best to mimic GHC's +behavior when reifying global declarations using Template Haskell. As it turns +out, if `MkD` were defined globally, then Template Haskell would reify it as: + + MkD :: a -> b -> (:&:) a b + +Note that `(:&:)` is applied prefix, not infix! This is somewhat surprising, +but nevertheless valid code. We mimic this surprising behavior when locally +reifying data family instances such as (:&:). This means that we cannot just +reuse the type `a :&: b` in the return type of `MkD`. Instead, we must +decompose `a :&: b` into its type arguments and apply (:&:) (in prefix form) to +the type arguments. + +The R40 test case checks for this property. +-} + +-- Reverse-engineer the type of a data constructor. +con_to_type :: [TyVarBndrSpec] -- The type variables bound by a data type head. + -- Only used for Haskell98-style constructors. + -> Type -- The constructor result type. + -- Only used for Haskell98-style constructors. + -> Con -> Type +con_to_type h98_tvbs h98_result_ty con = + case go con of + (is_gadt, ty) | is_gadt -> ty + | otherwise -> maybeForallT all_h98_tvbs [] ty + where + -- Note that we deliberately ignore linear types and use (->) everywhere. + -- See [Gracefully handling linear types] in L.H.TH.Desugar.Core. + go :: Con -> (Bool, Type) -- The Bool is True when dealing with a GADT + go (NormalC _ stys) = (False, mkArrows (map snd stys) h98_result_ty) + go (RecC _ vstys) = (False, mkArrows (map thdOf3 vstys) h98_result_ty) + go (InfixC t1 _ t2) = (False, mkArrows (map snd [t1, t2]) h98_result_ty) + go (ForallC bndrs cxt c) = liftSnd (ForallT bndrs cxt) (go c) + go (GadtC _ stys rty) = (True, mkArrows (map snd stys) rty) + go (RecGadtC _ vstys rty) = (True, mkArrows (map thdOf3 vstys) rty) + + -- All of the type variables bound by the data type, with any implicitly + -- quantified kind variables made explicit. + all_h98_tvbs :: [TyVarBndrSpec] + all_h98_tvbs = quantifyAllTvbsSpec h98_tvbs + +mkVarI :: Name -> [Dec] -> Info +mkVarI n decs = mkVarITy n (maybe (no_type n) snd $ findType n decs) + +mkVarITy :: Name -> Type -> Info +mkVarITy n ty = VarI n ty Nothing + +findType :: Name -> [Dec] -> Maybe (Named Type) +findType n = firstMatch match_type + where + match_type (SigD n' ty) | n `nameMatches` n' = Just (n', ty) + match_type _ = Nothing + +#if __GLASGOW_HASKELL__ >= 801 +mkPatSynI :: Name -> [Dec] -> Info +mkPatSynI n decs = PatSynI n (fromMaybe (no_type n) $ findPatSynType n decs) + +findPatSynType :: Name -> [Dec] -> Maybe PatSynType +findPatSynType n = firstMatch match_pat_syn_type + where + match_pat_syn_type (PatSynSigD n' psty) | n `nameMatches` n' = Just psty + match_pat_syn_type _ = Nothing +#endif + +no_type :: Name -> Type +no_type n = error $ "No type information found in local declaration for " + ++ show n + +findInstances :: Name -> [Dec] -> [Dec] +findInstances n = map stripInstanceDec . concatMap match_instance + where + match_instance d@(InstanceD _ _ ty _) | ConT n' <- ty_head ty + , n `nameMatches` n' = [d] +#if __GLASGOW_HASKELL__ >= 807 + match_instance (DataInstD ctxt _ lhs mk cons derivs) + | ConT n' <- ty_head lhs + , n `nameMatches` n' = [d] + where + mtvbs = rejig_data_inst_tvbs ctxt lhs mk + d = DataInstD ctxt mtvbs lhs mk cons derivs + match_instance (NewtypeInstD ctxt _ lhs mk con derivs) + | ConT n' <- ty_head lhs + , n `nameMatches` n' = [d] + where + mtvbs = rejig_data_inst_tvbs ctxt lhs mk + d = NewtypeInstD ctxt mtvbs lhs mk con derivs +#else + match_instance d@(DataInstD _ n' _ _ _ _) | n `nameMatches` n' = [d] + match_instance d@(NewtypeInstD _ n' _ _ _ _) | n `nameMatches` n' = [d] +#endif +#if __GLASGOW_HASKELL__ >= 807 + match_instance (TySynInstD (TySynEqn _ lhs rhs)) + | ConT n' <- ty_head lhs + , n `nameMatches` n' = [d] + where + mtvbs = rejig_tvbs [lhs, rhs] + d = TySynInstD (TySynEqn mtvbs lhs rhs) +#else + match_instance d@(TySynInstD n' _) | n `nameMatches` n' = [d] +#endif + + match_instance (InstanceD _ _ _ decs) + = concatMap match_instance decs + match_instance _ = [] + +#if __GLASGOW_HASKELL__ >= 807 + -- See Note [Rejigging reified type family equations variable binders] + -- for why this is necessary. + rejig_tvbs :: [Type] -> Maybe [TyVarBndrUnit] + rejig_tvbs ts = + let tvbs = freeVariablesWellScoped ts + in if null tvbs + then Nothing + else Just tvbs + + rejig_data_inst_tvbs :: Cxt -> Type -> Maybe Kind -> Maybe [TyVarBndrUnit] + rejig_data_inst_tvbs cxt lhs mk = + rejig_tvbs $ cxt ++ [lhs] ++ maybeToList mk +#endif + + ty_head = fst . unfoldType + +{- +Note [Rejigging reified type family equations variable binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When reifying a type family instance (on GHC 8.8 or later), which quantified +type variables do you use? This might seem like a strange question to ask since +these instances already come equipped with a field of type `Maybe [TyVarBndr]`, +but it's not always the case that you want to use exactly that field. Here is +an example to better explain it: + + class C a where + type T b a + instance C (Maybe a) where + type forall b. T b (Maybe a) = a + +If the above instance were quoted, it would give you `Just [PlainTV b]`. But if +you were to reify ''T (and therefore retrieve the instance for T), you wouldn't +want to use that as your list of type variable binders! This is because +reifiying any type family always presents the information as though the type +family were top-level. Therefore, reifying T (in GHC, at least) would yield: + + type family T b a + type instance forall b a. T b (Maybe a) = a + +Note that we quantify over `b` *and* `a` here, not just `b`. To emulate this +GHC quirk, whenever we reify any type family instance, we just ignore the field +of type `Maybe [TyVarBndr]` and quantify over the instance afresh. It's a bit +tedious, but it gets the job done. (This is accomplished by the rejig_tvbs +function.) +-} + +-- Consider the following class declaration: +-- +-- [d| class C a where +-- method :: a -> b -> a |] +-- +-- When reifying C locally, quantifyClassDecMethods serves two purposes: +-- +-- 1. It quantifies the class method's local type variables. To illustrate this +-- point, this is how GHC would reify C: +-- +-- class C a where +-- method :: forall b. a -> b -> a +-- +-- Notice the presence of the explicit `forall b.`. quantifyClassDecMethods +-- performs this explicit quantification if necessary (as in the case in the +-- local C declaration, where `b` is implicitly quantified.) +-- 2. It emulates a quirk in the way old versions of GHC would reify class +-- declarations (Trac #15551). On versions of GHC older than 8.8, it would +-- reify C like so: +-- +-- class C a where +-- method :: forall a. C a => forall b. a -> b -> a +-- +-- Notice how GHC has added the (totally extraneous) `forall a. C a =>` +-- part! This is weird, but our primary goal in this module is to mimic +-- GHC's reification, so we play the part by adding the `forall`/class +-- context to each class method in quantifyClassDecMethods. +-- +-- Since Trac #15551 was fixed in GHC 8.8, this function doesn't perform +-- this step on 8.7 or later. +quantifyClassDecMethods :: Dec -> Dec +quantifyClassDecMethods (ClassD cxt cls_name cls_tvbs fds sub_decs) + = ClassD cxt cls_name cls_tvbs fds sub_decs' + where + sub_decs' = mapMaybe go sub_decs + go (SigD n ty) = + Just $ SigD n + $ quantifyClassMethodType + (changeTVFlags SpecifiedSpec cls_tvbs) + (applyType (ConT cls_name) (map tyVarBndrVisToTypeArg cls_tvbs)) + prepend_cls + ty + go d@(TySynInstD {}) = Just d + go d@(OpenTypeFamilyD {}) = Just d + go d@(DataFamilyD {}) = Just d + go _ = Nothing + + -- See (2) in the comments for quantifyClassDecMethods. + prepend_cls :: Bool +#if __GLASGOW_HASKELL__ >= 807 + prepend_cls = False +#else + prepend_cls = True +#endif +quantifyClassDecMethods dec = dec + +-- Add explicit quantification to a class method's type if necessary. In this +-- example: +-- +-- [d| class C a where +-- method :: a -> b -> a |] +-- +-- If one invokes `quantifyClassMethodType [a] (C a) prepend (a -> b -> a)`, +-- then the output will be: +-- +-- 1. `forall a. C a => forall b. a -> b -> a` (if `prepend` is True) +-- 2. `forall b. a -> b -> a` (if `prepend` is False) +-- +-- Whether you want `prepend` to be True or False depends on the situation. +-- When reifying an entire type class, like C, one does not need to prepend a +-- class context to each of the bundled method types (see the comments for +-- quantifyClassDecMethods), so False is appropriate. When one is only reifying +-- a single class method, like `method`, then one needs the class context to +-- appear in the reified type, so `True` is appropriate. +quantifyClassMethodType + :: [TyVarBndrSpec] -- ^ The class's type variable binders. + -> Pred -- ^ The class context. + -> Bool -- ^ If 'True', prepend a class predicate. + -> Type -- ^ The method type. + -> Type +quantifyClassMethodType cls_tvbs cls_pred prepend meth_ty = + add_cls_cxt quantified_meth_ty + where + add_cls_cxt :: Type -> Type + add_cls_cxt + | prepend = ForallT all_cls_tvbs [cls_pred] + | otherwise = id + + quantified_meth_ty :: Type + quantified_meth_ty + | null meth_tvbs + = meth_ty + | ForallT meth_tvbs' meth_ctxt meth_tau <- meth_ty + = ForallT (meth_tvbs ++ meth_tvbs') meth_ctxt meth_tau + | otherwise + = ForallT meth_tvbs [] meth_ty + + meth_tvbs :: [TyVarBndrSpec] + meth_tvbs = List.deleteFirstsBy ((==) `on` tvName) + (changeTVFlags SpecifiedSpec + (freeVariablesWellScoped [meth_ty])) + all_cls_tvbs + + -- All of the type variables bound by the class, with any implicitly + -- quantified kind variables made explicit. + all_cls_tvbs :: [TyVarBndrSpec] + all_cls_tvbs = quantifyAllTvbsSpec cls_tvbs + +stripInstanceDec :: Dec -> Dec +stripInstanceDec (InstanceD over cxt ty _) = InstanceD over cxt ty [] +stripInstanceDec dec = dec + +mkArrows :: [Type] -> Type -> Type +mkArrows [] res_ty = res_ty +mkArrows (t:ts) res_ty = AppT (AppT ArrowT t) $ mkArrows ts res_ty + +maybeForallT :: [TyVarBndrSpec] -> Cxt -> Type -> Type +maybeForallT tvbs cxt ty + | null tvbs && null cxt = ty + | ForallT tvbs2 cxt2 ty2 <- ty = ForallT (tvbs ++ tvbs2) (cxt ++ cxt2) ty2 + | otherwise = ForallT tvbs cxt ty + +findCon :: Name -> [Con] -> Maybe (Named Con) +findCon n = firstMatch match_con + where + match_con :: Con -> Maybe (Named Con) + match_con con = + case con of + NormalC n' _ | n `nameMatches` n' -> Just (n', con) + RecC n' _ | n `nameMatches` n' -> Just (n', con) + InfixC _ n' _ | n `nameMatches` n' -> Just (n', con) + ForallC _ _ c -> case match_con c of + Just (n', _) -> Just (n', con) + Nothing -> Nothing + GadtC nms _ _ -> gadt_case con nms + RecGadtC nms _ _ -> gadt_case con nms + _ -> Nothing + + gadt_case :: Con -> [Name] -> Maybe (Named Con) + gadt_case con nms = case List.find (n `nameMatches`) nms of + Just n' -> Just (n', con) + Nothing -> Nothing + +data RecSelInfo + = RecSelH98 Type -- The record field's type + | RecSelGADT (Maybe [TyVarBndrSpec]) + -- If the data constructor explicitly quantifies its type + -- variables with a forall, this will be Just. Otherwise, + -- this will be Nothing. + Type -- The record field's type + Type -- The GADT return type + +findRecSelector :: Name -> [Con] -> Maybe (Named RecSelInfo) +findRecSelector n = firstMatch (match_con Nothing) + where + match_con :: Maybe [TyVarBndrSpec] -> Con -> Maybe (Named RecSelInfo) + match_con mb_tvbs con = + case con of + RecC _ vstys -> + fmap (liftSnd RecSelH98) $ + firstMatch match_rec_sel vstys + RecGadtC _ vstys ret_ty -> + fmap (liftSnd (\field_ty -> + RecSelGADT (fmap (filter_ret_tvs ret_ty) mb_tvbs) field_ty ret_ty)) $ + firstMatch match_rec_sel vstys + ForallC tvbs _ c -> + -- This is the only recursive case, and it is also the place where + -- the type variable binders are determined (hence the use of Just + -- below). Note that GHC forbids nested foralls in GADT constructor + -- type signatures, so it is guaranteed that if a type variable in + -- the rest of the type signature appears free, then its binding site + -- can be found in one of these binders found in this case. + match_con (Just tvbs) c + _ -> Nothing + + match_rec_sel (n', _, sel_ty) + | n `nameMatches` n' = Just (n', sel_ty) + match_rec_sel _ = Nothing + + -- There may be type variables in the type of a GADT constructor that do + -- not appear in the type of a record selector. For example, consider: + -- + -- data G a where + -- MkG :: forall a b. { x :: a, y :: b } -> G a + -- + -- The type of `x` will only quantify `a` and not `b`: + -- + -- x :: forall a. G a -> a + -- + -- Accordingly, we must filter out any type variables in the GADT + -- constructor type that do not appear free in the return type. Note that + -- this implies that we cannot support reifying the type of `y`, as `b` + -- does not appear free in `G a`. This does not bother us, however, as we + -- make no attempt to support naughty record selectors. (See the Haddocks + -- for getRecordSelectors in L.H.TH.Desugar for more on this point.) + -- + -- This mirrors the implementation of mkOneRecordSelector in GHC: + -- https://gitlab.haskell.org/ghc/ghc/-/blob/37cfe3c0f4fb16189bbe3bb735f758cd6e3d9157/compiler/GHC/Tc/TyCl/Utils.hs#L908-909 + filter_ret_tvs :: Type -> [TyVarBndrSpec] -> [TyVarBndrSpec] + filter_ret_tvs ret_ty = + filter (\tvb -> tvName tvb `Set.member` ret_fvs) + where + ret_fvs = Set.fromList $ freeVariables [ret_ty] + +-- | Match up the type variable binders from a data type or class declaration +-- with its standalone kind signature (if any) to produce a list of +-- 'TyVarBndrSpec's, which can then be used in the types of data constructors or +-- class methods. This makes the kinds more precise. +matchUpSAKWithTvbsSpec :: + [Dec] + -- ^ The local declarations currently in scope. + -> Name + -- ^ The name of the data type or class declaration. + -> [TyVarBndrVis] + -- ^ The data type or class declaration's type variable binders. + -> [TyVarBndrSpec] +matchUpSAKWithTvbsSpec decs ty_name tvbs = + fromMaybe (changeTVFlags SpecifiedSpec tvbs) $ do + sak <- findKind False ty_name decs + tvbForAllTyFlagsToSpecs <$> matchUpSAKWithDecl sak tvbs + +-- | Compute the type variable binders to use in the type of a Haskell98-style +-- data constructor for a data family instance. If the data family instance +-- comes equipped with explicit type variable binders, this is easy. If not, +-- we must compute the type variable binders from the list of type arguments to +-- the data family instance. +dataFamInstH98ConTvbs :: Maybe [TyVarBndrUnit] -> [TypeArg] -> [TyVarBndrSpec] +dataFamInstH98ConTvbs mtvbs tys = + case mtvbs of + Just tvbs -> + changeTVFlags SpecifiedSpec tvbs + Nothing -> + dataFamInstH98ConTvbsNoInstTvbs $ + map probablyWrongUnTypeArg tys + +-- | Compute the type variable binders to use in the type of a Haskell98-style +-- data constructor for a data family instance where the instance lacks explicit +-- type variable binders. To compute these binders, we must reverse engineer +-- them from the list of type arguments to the data family instance. +dataFamInstH98ConTvbsNoInstTvbs :: [Type] -> [TyVarBndrSpec] +dataFamInstH98ConTvbsNoInstTvbs tys = + changeTVFlags SpecifiedSpec $ + freeVariablesWellScoped tys + +-- | Explicitly quantify all type variable binders in the type of a +-- Haskell98-style data constructor or class method. This is sometimes required +-- in order to ensure that kind variables are all explicitly quantified, e.g., +-- +-- @ +-- -- NB: No standalone kind signature for `T` +-- data T (a :: k) = MkT +-- @ +-- +-- We want the type of @MkT@ to be @forall k (a :: k). T a@, but we are only +-- given @(a :: k)@. We must call 'quantifyAllTvbsSpec' on @(a :: k)@ to obtain +-- @[k, a :: k]@. If we don't, we might accidentally end up with +-- @forall (a :: k). T a@ as the type of @MkT@, which is ill-scoped. +quantifyAllTvbsSpec :: [TyVarBndrSpec] -> [TyVarBndrSpec] +quantifyAllTvbsSpec h98_tvbs = + let h98_kvbs = freeKindVariablesWellScoped h98_tvbs in + changeTVFlags SpecifiedSpec h98_kvbs ++ h98_tvbs + +--------------------------------- +-- Reifying fixities +--------------------------------- + +-- | Like 'reifyWithLocals_maybe', but for fixities. Note that a return value +-- of @Nothing@ might mean that the name is not in scope, or it might mean +-- that the name has no assigned fixity. (Use 'reifyWithLocals_maybe' if +-- you really need to tell the difference.) +reifyFixityWithLocals :: DsMonad q => Name -> q (Maybe Fixity) +reifyFixityWithLocals name = qRecover + (return . reifyFixityInDecs name =<< localDeclarations) + (qReifyFixity name) + +-------------------------------------- +-- Reifying types +-------------------------------------- +-- +-- This section allows GHC <8.9 to call reifyFixity + +#if __GLASGOW_HASKELL__ < 809 +qReifyType :: forall m. Quasi m => Name -> m Type +qReifyType name = do + info <- qReify name + case infoType info <|> info_kind info of + Just t -> return t + Nothing -> fail $ "Could not reify the full type of " ++ nameBase name + where + info_kind :: Info -> Maybe Kind + info_kind info = do + dec <- case info of + ClassI d _ -> Just d + TyConI d -> Just d + FamilyI d _ -> Just d + _ -> Nothing + match_cusk name dec + +{- | @reifyType nm@ attempts to find the type or kind of @nm@. For example, +@reifyType 'not@ returns @Bool -> Bool@, and +@reifyType ''Bool@ returns @Type@. +This works even if there's no explicit signature and the type or kind is inferred. +-} +reifyType :: Name -> Q Type +reifyType = qReifyType +#endif + +-- | Like 'reifyTypeWithLocals_maybe', but throws an exception upon failure, +-- warning the user about separating splices. +reifyTypeWithLocals :: DsMonad q => Name -> q Type +reifyTypeWithLocals name = do + m_info <- reifyTypeWithLocals_maybe name + case m_info of + Nothing -> reifyFail name + Just i -> return i + +-- | Like 'reifyWithLocals_maybe' but for types and kinds. Note that a return +-- value of @Nothing@ might mean that the name is not in scope, or it might +-- mean that the full type of the name cannot be determined. (Use +-- 'reifyWithLocals_maybe' if you really need to tell the difference.) +reifyTypeWithLocals_maybe :: DsMonad q => Name -> q (Maybe Type) +reifyTypeWithLocals_maybe name = do +#if __GLASGOW_HASKELL__ >= 809 + cusks <- qIsExtEnabled CUSKs +#else + -- On earlier GHCs, the behavior of -XCUSKs was the norm. + let cusks = True +#endif + qRecover (return . reifyTypeInDecs cusks name =<< localDeclarations) + (Just `fmap` qReifyType name) + +-- | Look through a list of declarations and return its full type, if +-- available. +reifyTypeInDecs :: Bool -> Name -> [Dec] -> Maybe Type +reifyTypeInDecs cusks name decs = + (reifyInDecs name decs >>= infoType) <|> findKind cusks name decs + +-- Extract the type information (if any) contained in an Info. +infoType :: Info -> Maybe Type +infoType info = + case info of + ClassOpI _ t _ -> Just t + DataConI _ t _ -> Just t + VarI _ t _ -> Just t + TyVarI _ t -> Just t +#if __GLASGOW_HASKELL__ >= 802 + PatSynI _ t -> Just t +#endif + _ -> Nothing + +-- Like findType, but instead searching for kind signatures. +-- This mostly searches through `KiSigD`s, but if the -XCUSKs extension is +-- enabled, this also retrieves kinds for declarations with CUSKs. +findKind :: Bool -- Is -XCUSKs enabled? + -> Name -> [Dec] -> Maybe Kind +findKind cusks name decls = + firstMatch (match_kind_sig name decls) decls + <|> whenAlt cusks (firstMatch (match_cusk name) decls) + +-- Look for a declaration's kind by searching for its standalone kind +-- signature, if available. +match_kind_sig :: Name -> [Dec] -> Dec -> Maybe Kind +match_kind_sig n decs (ClassD _ n' tvbs _ sub_decs) + -- If a class has a standalone kind signature, then we can determine the + -- full kind of its associated types in 99% of cases. + -- See Note [The limitations of standalone kind signatures] for what + -- happens in the other 1% of cases. + | Just ki <- firstMatch (find_kind_sig n') decs + , let (arg_kis, _res_ki) = unravelType ki + mb_vis_arg_kis = map vis_arg_kind_maybe $ filterVisFunArgs arg_kis + cls_tvb_kind_map = + Map.fromList [ (tvName tvb, tvb_kind) + | (tvb, mb_vis_arg_ki) <- zip tvbs mb_vis_arg_kis + , Just tvb_kind <- [mb_vis_arg_ki <|> extractTvbKind_maybe tvb] + ] + = firstMatch (find_assoc_type_kind n cls_tvb_kind_map) sub_decs +match_kind_sig n _ dec = find_kind_sig n dec + +find_kind_sig :: Name -> Dec -> Maybe Kind +#if __GLASGOW_HASKELL__ >= 809 +find_kind_sig n (KiSigD n' ki) + | n `nameMatches` n' = Just ki +#endif +find_kind_sig _ _ = Nothing + +-- Compute a declaration's kind by retrieving its CUSK, if it has one. +-- This is only done when -XCUSKs is enabled, or on older GHCs where +-- CUSKs were the only means of specifying this information. +match_cusk :: Name -> Dec -> Maybe Kind +match_cusk n (DataD _ n' tvbs m_ki _ _) + | n `nameMatches` n' + = datatype_kind tvbs m_ki +match_cusk n (NewtypeD _ n' tvbs m_ki _ _) + | n `nameMatches` n' + = datatype_kind tvbs m_ki +match_cusk n (DataFamilyD n' tvbs m_ki) + | n `nameMatches` n' + = open_ty_fam_kind tvbs m_ki +match_cusk n (OpenTypeFamilyD (TypeFamilyHead n' tvbs res_sig _)) + | n `nameMatches` n' + = open_ty_fam_kind tvbs (res_sig_to_kind res_sig) +match_cusk n (ClosedTypeFamilyD (TypeFamilyHead n' tvbs res_sig _) _) + | n `nameMatches` n' + = closed_ty_fam_kind tvbs (res_sig_to_kind res_sig) +match_cusk n (TySynD n' tvbs rhs) + | n `nameMatches` n' + = ty_syn_kind tvbs rhs +match_cusk n (ClassD _ n' tvbs _ sub_decs) + | n `nameMatches` n' + = class_kind tvbs + | -- An associated type family can only have a CUSK if its parent class + -- also has a CUSK. + all tvb_is_kinded tvbs + , let cls_tvb_kind_map = Map.fromList [ (tvName tvb, tvb_kind) + | tvb <- tvbs + , Just tvb_kind <- [extractTvbKind_maybe tvb] + ] + = firstMatch (find_assoc_type_kind n cls_tvb_kind_map) sub_decs +#if __GLASGOW_HASKELL__ >= 906 +match_cusk n (TypeDataD n' tvbs m_ki _) + | n `nameMatches` n' + = datatype_kind tvbs m_ki +#endif +match_cusk _ _ = Nothing + +-- Uncover the kind of an associated type family. There is an invariant +-- that this function should only ever be called when the kind of the +-- parent class is known (i.e., if it has a standalone kind signature or a +-- CUSK). Despite this, it is possible for this function to return Nothing. +-- See Note [The limitations of standalone kind signatures]. +find_assoc_type_kind :: Name -> Map Name Kind -> Dec -> Maybe Kind +find_assoc_type_kind n cls_tvb_kind_map sub_dec = + case sub_dec of + DataFamilyD n' tf_tvbs m_ki + | n `nameMatches` n' + -> build_kind (map ascribe_tf_tvb_kind tf_tvbs) (default_res_ki m_ki) + OpenTypeFamilyD (TypeFamilyHead n' tf_tvbs res_sig _) + | n `nameMatches` n' + -> build_kind (map ascribe_tf_tvb_kind tf_tvbs) + (default_res_ki $ res_sig_to_kind res_sig) + _ -> Nothing + where + ascribe_tf_tvb_kind :: TyVarBndrVis -> TyVarBndrVis + ascribe_tf_tvb_kind tvb = + elimTVFlag + (\tvn flag -> kindedTVFlag tvn flag $ fromMaybe StarT $ Map.lookup tvn cls_tvb_kind_map) + (\_ _ _ -> tvb) + tvb + +-- Data types have CUSKs when: +-- +-- 1. All of their type variables have explicit kinds. +-- 2. All kind variables in the result kind are explicitly quantified. +datatype_kind :: [TyVarBndrVis] -> Maybe Kind -> Maybe Kind +datatype_kind tvbs m_ki = + whenAlt (all tvb_is_kinded tvbs && ki_fvs_are_bound) $ + build_kind tvbs (default_res_ki m_ki) + where + ki_fvs_are_bound :: Bool + ki_fvs_are_bound = + let ki_fvs = Set.fromList $ foldMap freeVariables m_ki + tvb_vars = Set.fromList $ freeVariables $ map tvbToTypeWithSig tvbs + in ki_fvs `Set.isSubsetOf` tvb_vars + +-- Classes have CUSKs when all of their type variables have explicit kinds. +class_kind :: [TyVarBndrVis] -> Maybe Kind +class_kind tvbs = whenAlt (all tvb_is_kinded tvbs) $ + build_kind tvbs ConstraintT + +-- Open type families and data families always have CUSKs. Type variables +-- without explicit kinds default to Type, as does the return kind if it +-- is not specified. +open_ty_fam_kind :: [TyVarBndrVis] -> Maybe Kind -> Maybe Kind +open_ty_fam_kind tvbs m_ki = + build_kind (map default_tvb tvbs) (default_res_ki m_ki) + +-- Closed type families have CUSKs when: +-- +-- 1. All of their type variables have explicit kinds. +-- 2. An explicit return kind is supplied. +closed_ty_fam_kind :: [TyVarBndrVis] -> Maybe Kind -> Maybe Kind +closed_ty_fam_kind tvbs m_ki = + case m_ki of + Just ki -> whenAlt (all tvb_is_kinded tvbs) $ + build_kind tvbs ki + Nothing -> Nothing + +-- Type synonyms have CUSKs when: +-- +-- 1. All of their type variables have explicit kinds. +-- 2. The right-hand-side type is annotated with an explicit kind. +ty_syn_kind :: [TyVarBndrVis] -> Type -> Maybe Kind +ty_syn_kind tvbs rhs = + case rhs of + SigT _ ki -> whenAlt (all tvb_is_kinded tvbs) $ + build_kind tvbs ki + _ -> Nothing + +-- Attempt to construct the full kind of a type-level declaration from its +-- type variable binders and return kind. Do note that the result type of +-- this function is `Maybe Kind` because there are situations where even +-- this amount of information is not sufficient to determine the full kind. +-- See Note [The limitations of standalone kind signatures]. +build_kind :: [TyVarBndrVis] -> Kind -> Maybe Kind +build_kind arg_kinds res_kind = + fmap quantifyType $ fst $ + foldr go (Just res_kind, Set.fromList (freeVariables res_kind)) arg_kinds + where + go :: TyVarBndrVis -> (Maybe Kind, Set Name) -> (Maybe Kind, Set Name) + go tvb (res, res_fvs) = + elimTV (\n -> + ( if n `Set.member` res_fvs + then forall_ tvb res + else Nothing -- We have a type variable binder without an + -- explicit kind that is not used dependently, so + -- we cannot build a kind from it. This is the + -- only case where we return Nothing. + , res_fvs + )) + (\n k -> + ( if n `Set.member` res_fvs + then forall_ tvb res + else fmap (ArrowT `AppT` k `AppT`) res + , Set.fromList (freeVariables k) `Set.union` res_fvs + )) + tvb + + forall_ :: TyVarBndrVis -> Maybe Kind -> Maybe Kind +#if __GLASGOW_HASKELL__ >= 809 + forall_ tvb m_ki = fmap forallT m_ki + where + bndrVis :: BndrVis + bndrVis = elimTVFlag (\_ flag -> flag) (\_ flag _ -> flag) tvb + forallT :: Kind -> Kind + forallT = case bndrVis of + BndrReq -> ForallVisT (changeTVFlags () [tvb]) + BndrInvis -> ForallT (changeTVFlags SpecifiedSpec [tvb]) [] + -- One downside of this approach is that we generate kinds like this: + -- + -- forall a -> forall b -> forall c -> (a, b, c) + -- + -- Instead of this more compact kind: + -- + -- forall a b c -> (a, b, c) + -- + -- Thankfully, the difference is only cosmetic. +#else + forall_ _ _ = Nothing +#endif + +tvb_is_kinded :: TyVarBndr_ flag -> Bool +tvb_is_kinded = isJust . extractTvbKind_maybe + +vis_arg_kind_maybe :: VisFunArg -> Maybe Kind +vis_arg_kind_maybe (VisFADep tvb) = extractTvbKind_maybe tvb +vis_arg_kind_maybe (VisFAAnon k) = Just k + +default_tvb :: TyVarBndr_ flag -> TyVarBndr_ flag +default_tvb tvb = elimTVFlag (\n flag -> kindedTVFlag n flag StarT) (\_ _ _ -> tvb) tvb + +default_res_ki :: Maybe Kind -> Kind +default_res_ki = fromMaybe StarT + +res_sig_to_kind :: FamilyResultSig -> Maybe Kind +res_sig_to_kind NoSig = Nothing +res_sig_to_kind (KindSig k) = Just k +res_sig_to_kind (TyVarSig tvb) = extractTvbKind_maybe tvb + +whenAlt :: Alternative f => Bool -> f a -> f a +whenAlt b fa = if b then fa else empty + +{- +Note [The limitations of standalone kind signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A current limitation of StandaloneKindSignatures is that they cannot be applied +to associated type families. This can have some surprising consequences. +Consider the following code, taken from +https://gitlab.haskell.org/ghc/ghc/issues/17072#note_221324: + + type C :: forall a -> a -> Constraint + class C a b where + type T a :: Type + +The parent class C has a standalone kind signature, so GHC treats its +associated types as if they had CUSKs. Can th-desugar figure out the kind +that GHC gives to T? + +Unfortunately, the answer is "not easily". This is because `type T a` says +nothing about the kind of `a`, so th-desugar's only other option is to inspect +the kind signature for C. Even this is for naught, as the `forall a -> ...` +part doesn't state the kind of `a` either! The only way to know that the kind +of `a` should be Type is to infer that from the rest of the kind +(`a -> Constraint`), but this gets perilously close to requiring full kind +inference, which is rather unwieldy in Template Haskell. + +In cases like T, we simply give up and return Nothing when trying to reify +its kind. It's not ideal, but them's the breaks when you try to extract kinds +from syntax. There is a rather simple workaround available: just write +`type C :: forall (a :: Type) -> a -> Constraint` instead. +-} + +-------------------------------------- +-- Looking up name value and type names +-------------------------------------- + +-- | Like 'lookupValueName' from Template Haskell, but looks also in 'Names' of +-- not-yet-typechecked declarations. To establish this list of not-yet-typechecked +-- declarations, use 'withLocalDeclarations'. Returns 'Nothing' if no value +-- with the same name can be found. +lookupValueNameWithLocals :: DsMonad q => String -> q (Maybe Name) +lookupValueNameWithLocals = lookupNameWithLocals False + +-- | Like 'lookupTypeName' from Template Haskell, but looks also in 'Names' of +-- not-yet-typechecked declarations. To establish this list of not-yet-typechecked +-- declarations, use 'withLocalDeclarations'. Returns 'Nothing' if no type +-- with the same name can be found. +lookupTypeNameWithLocals :: DsMonad q => String -> q (Maybe Name) +lookupTypeNameWithLocals = lookupNameWithLocals True + +lookupNameWithLocals :: forall q. DsMonad q => Bool -> String -> q (Maybe Name) +lookupNameWithLocals ns s = do + mb_name <- qLookupName ns s + case mb_name of + j_name@(Just{}) -> return j_name + Nothing -> consult_locals + where + built_name = mkName s + + consult_locals = do + decs <- localDeclarations + let mb_infos = map (reifyInDec built_name decs) decs + infos = catMaybes mb_infos + firstMatchM (if ns then find_type_name + else find_value_name) infos + + -- These functions work over Named Infos so we can avoid performing + -- tiresome pattern-matching to retrieve the name associated with each Info. + find_type_name, find_value_name :: Named Info -> q (Maybe Name) + find_type_name (n, info) = do + name_space <- lookupInfoNameSpace info + pure $ case name_space of + TcClsName -> Just n + VarName -> Nothing + DataName -> Nothing +#if __GLASGOW_HASKELL__ >= 907 + FldName{} -> Nothing +#endif + + find_value_name (n, info) = do + name_space <- lookupInfoNameSpace info + case name_space of + VarName -> pure $ Just n + DataName -> pure $ Just n + TcClsName -> pure Nothing +#if __GLASGOW_HASKELL__ >= 907 + FldName{} -> do + fieldSels <- qIsExtEnabled LangExt.FieldSelectors + pure $ if fieldSels then Just n else Nothing +#endif + +-- | Like TH's @lookupValueName@, but if this name is not bound, then we assume +-- it is declared in the current module. +-- +-- Unlike 'mkDataName', this also consults the local declarations in scope when +-- determining if the name is currently bound. +mkDataNameWithLocals :: DsMonad q => String -> q Name +mkDataNameWithLocals = mkNameWith lookupValueNameWithLocals mkNameG_d + +-- | Like TH's @lookupTypeName@, but if this name is not bound, then we assume +-- it is declared in the current module. +-- +-- Unlike 'mkTypeName', this also consults the local declarations in scope when +-- determining if the name is currently bound. +mkTypeNameWithLocals :: DsMonad q => String -> q Name +mkTypeNameWithLocals = mkNameWith lookupTypeNameWithLocals mkNameG_tc + +-- | Determines a `Name`'s 'NameSpace'. If the 'NameSpace' is attached to +-- the 'Name' itself (i.e., it is unambiguous), then that 'NameSpace' is +-- immediately returned. Otherwise, reification is used to lookup up the +-- 'NameSpace' (consulting local declarations if necessary). +-- +-- Note that if a 'Name' lives in two different 'NameSpaces' (which can +-- genuinely happen--for instance, @'mkName' \"==\"@, where @==@ is both +-- a function and a type family), then this function will simply return +-- whichever 'NameSpace' is discovered first via reification. If you wish +-- to find a 'Name' in a particular 'NameSpace', use the +-- 'lookupValueNameWithLocals' or 'lookupTypeNameWithLocals' functions. +reifyNameSpace :: DsMonad q => Name -> q (Maybe NameSpace) +reifyNameSpace n@(Name _ nf) = + case nf of + -- NameGs are simple, as they have a NameSpace attached. + NameG ns _ _ -> pure $ Just ns + + -- For other names, we must use reification to determine what NameSpace + -- it lives in (if any). + _ -> do mb_info <- reifyWithLocals_maybe n + traverse lookupInfoNameSpace mb_info + +-- | Look up a name's 'NameSpace' from its 'Info'. +lookupInfoNameSpace :: DsMonad q => Info -> q NameSpace +lookupInfoNameSpace info = + case info of + ClassI{} -> pure TcClsName + TyConI{} -> pure TcClsName + FamilyI{} -> pure TcClsName + PrimTyConI{} -> pure TcClsName + TyVarI{} -> pure TcClsName + + ClassOpI{} -> pure VarName +#if __GLASGOW_HASKELL__ >= 907 + -- A VarI might correspond to a top-level value (i.e., a VarName) or a + -- record field (i.e., a FldName). The only way to distinguish them is to + -- check if the VarI's Name and Type correspond to a data type with a + -- corresponding record field Name. + VarI n ty _ -> do + -- First, check to see if `ty` is of the form `D -> T`, where `D` is + -- headed by a data type. We can safely ignore `forall`s here by using + -- `filterVisFunArgs`, as we only care about the first visible argument. + let (ty_args, _ty_res) = unravelType ty + ty_vis_args = filterVisFunArgs ty_args + case ty_vis_args of + [VisFAAnon ty_anon_arg] + | (ConT parent_name, _) <- unfoldType ty_anon_arg + -> -- If we find the data type constructor `parent_name`, then check + -- if one of the data constructors for `parent_name` contains a + -- record field named `n`. + do mb_parent_info <- reifyWithLocals_maybe parent_name + pure $ case mb_parent_info of + Just (TyConI (DataD _cxt _name _tvbs _mk cons _derivings)) + | isJust $ findRecSelector n cons + -> FldName $ nameBase parent_name + Just (TyConI (NewtypeD _cxt _name _tvbs _mk con _derivings)) + | isJust $ findRecSelector n [con] + -> FldName $ nameBase parent_name + _ -> VarName + _ -> pure VarName +#else + VarI{} -> pure VarName +#endif + + DataConI _dc_name _dc_ty parent_name -> do + -- DataConI usually refers to a value-level Name, but it could also refer + -- to a type-level 'Name' if the data constructor corresponds to a + -- @type data@ declaration. In order to know for sure, we must perform + -- some additional reification. + mb_parent_info <- reifyWithLocals_maybe parent_name + pure $ case mb_parent_info of +#if __GLASGOW_HASKELL__ >= 906 + Just (TyConI (TypeDataD {})) + -> TcClsName +#endif + _ -> DataName +#if __GLASGOW_HASKELL__ >= 801 + PatSynI{} -> pure DataName +#endif diff --git a/Language/Haskell/TH/Desugar/Subst.hs b/Language/Haskell/TH/Desugar/Subst.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/TH/Desugar/Subst.hs @@ -0,0 +1,165 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Language.Haskell.TH.Desugar.Subst +-- Copyright : (C) 2018 Richard Eisenberg +-- License : BSD-style (see LICENSE) +-- Maintainer : Ryan Scott +-- Stability : experimental +-- Portability : non-portable +-- +-- Capture-avoiding substitutions on 'DType's. (For non–capture-avoiding +-- substitution functions, use "Language.Haskell.TH.Desugar.Subst.Capturing" +-- instead.) +-- +---------------------------------------------------------------------------- + +module Language.Haskell.TH.Desugar.Subst ( + DSubst, + + -- * Capture-avoiding substitution + substTy, substForallTelescope, substTyVarBndrs, substTyVarBndr, + unionSubsts, unionMaybeSubsts, + + -- * Matching a type template against a type + IgnoreKinds(..), matchTy + ) where + +import qualified Data.List as L +import qualified Data.Map as M +import qualified Data.Set as S + +import Language.Haskell.TH.Desugar.AST +import Language.Haskell.TH.Desugar.Util +import Language.Haskell.TH.Syntax + +-- | A substitution is just a map from names to types. +type DSubst = M.Map Name DType + +-- | Capture-avoiding substitution on 'DType's. This function requires a 'Quasi' +-- constraint because it may need to create fresh names in order to avoid +-- capture when substituting into a @forall@ type (see 'substTyVarBndr'). +substTy :: Quasi q => DSubst -> DType -> q DType +substTy vars (DForallT tele ty) = do + (vars', tele') <- substForallTelescope vars tele + ty' <- substTy vars' ty + return $ DForallT tele' ty' +substTy vars (DConstrainedT cxt ty) = + DConstrainedT <$> mapM (substTy vars) cxt <*> substTy vars ty +substTy vars (DAppT t1 t2) = + DAppT <$> substTy vars t1 <*> substTy vars t2 +substTy vars (DAppKindT t k) = + DAppKindT <$> substTy vars t <*> substTy vars k +substTy vars (DSigT ty ki) = + DSigT <$> substTy vars ty <*> substTy vars ki +substTy vars (DVarT n) + | Just ty <- M.lookup n vars + = return ty + | otherwise + = return $ DVarT n +substTy _ ty@(DConT _) = return ty +substTy _ ty@DArrowT = return ty +substTy _ ty@(DLitT _) = return ty +substTy _ ty@DWildCardT = return ty + +-- | Capture-avoiding substitution on 'DForallTelescope's. This returns a pair +-- containing the new 'DSubst' as well as a new 'DForallTelescope' value, where +-- the names have been renamed to avoid capture and the kinds have been +-- substituted. +substForallTelescope :: Quasi q => DSubst -> DForallTelescope + -> q (DSubst, DForallTelescope) +substForallTelescope vars tele = + case tele of + DForallVis tvbs -> do + (vars', tvbs') <- substTyVarBndrs vars tvbs + return (vars', DForallVis tvbs') + DForallInvis tvbs -> do + (vars', tvbs') <- substTyVarBndrs vars tvbs + return (vars', DForallInvis tvbs') + +-- | Capture-avoiding substitution on a telescope of 'DTyVarBndr's. This returns +-- a pair containing the new 'DSubst' as well as a new telescope of +-- 'DTyVarBndr's, where the names have been renamed to avoid capture and the +-- kinds have been substituted. +substTyVarBndrs :: Quasi q => DSubst -> [DTyVarBndr flag] + -> q (DSubst, [DTyVarBndr flag]) +substTyVarBndrs = mapAccumLM substTyVarBndr + +-- | Capture-avoiding substitution on a 'DTyVarBndr'. This uses the 'Quasi' +-- constraint to create a new, fresh name (based on the name of the supplied +-- 'DTyVarBndr'), update the 'DSubst' to map from the old name to the new name, +-- and this also returns a 'DTyVarBndr' containing the new name and the kind of +-- the supplied 'DTyVarBndr' (with the substitution applied). +substTyVarBndr :: Quasi q => DSubst -> DTyVarBndr flag + -> q (DSubst, DTyVarBndr flag) +substTyVarBndr vars (DPlainTV n flag) = do + new_n <- qNewName (nameBase n) + return (M.insert n (DVarT new_n) vars, DPlainTV new_n flag) +substTyVarBndr vars (DKindedTV n flag k) = do + new_n <- qNewName (nameBase n) + k' <- substTy vars k + return (M.insert n (DVarT new_n) vars, DKindedTV new_n flag k') + +-- | Computes the union of two substitutions. Fails if both subsitutions map +-- the same variable to different types. +unionSubsts :: DSubst -> DSubst -> Maybe DSubst +unionSubsts a b = + let shared_key_set = M.keysSet a `S.intersection` M.keysSet b + matches_up = S.foldr (\name -> ((a M.! name) == (b M.! name) &&)) + True shared_key_set + in + if matches_up then return (a `M.union` b) else Nothing + +--------------------------- +-- Matching + +-- | Ignore kind annotations in @matchTy@? +data IgnoreKinds = YesIgnore | NoIgnore + +-- | @matchTy ign tmpl targ@ matches a type template @tmpl@ against a type +-- target @targ@. This returns a Map from names of type variables in the +-- type template to types if the types indeed match up, or @Nothing@ otherwise. +-- In the @Just@ case, it is guaranteed that every type variable mentioned +-- in the template is mapped by the returned substitution. +-- +-- The first argument @ign@ tells @matchTy@ whether to ignore kind signatures +-- in the template. A kind signature in the template might mean that a type +-- variable has a more restrictive kind than otherwise possible, and that +-- mapping that type variable to a type of a different kind could be disastrous. +-- So, if we don't ignore kind signatures, this function returns @Nothing@ if +-- the template has a signature anywhere. If we do ignore kind signatures, it's +-- possible the returned map will be ill-kinded. Use at your own risk. +matchTy :: IgnoreKinds -> DType -> DType -> Maybe DSubst +matchTy _ (DVarT var_name) arg = Just $ M.singleton var_name arg + -- if a pattern has a kind signature, it's really easy to get + -- the following two cases wrong. +matchTy ign (DSigT ty _ki) arg = case ign of + YesIgnore -> matchTy ign ty arg + NoIgnore -> Nothing +matchTy ign (DAppKindT ty _ki) arg = case ign of + YesIgnore -> matchTy ign ty arg + NoIgnore -> Nothing + -- but we can safely ignore kind signatures on the target, + -- as in the following two cases. +matchTy ign pat (DSigT ty _ki) = matchTy ign pat ty +matchTy ign pat (DAppKindT ty _ki) = matchTy ign pat ty +matchTy _ (DForallT {}) _ = + error "Cannot match a forall in a pattern" +matchTy _ _ (DForallT {}) = + error "Cannot match a forall in a target" +matchTy ign (DAppT pat1 pat2) (DAppT arg1 arg2) = + unionMaybeSubsts [matchTy ign pat1 arg1, matchTy ign pat2 arg2] +matchTy _ (DConT pat_con) (DConT arg_con) + | pat_con == arg_con = Just M.empty +matchTy _ DArrowT DArrowT = Just M.empty +matchTy _ (DLitT pat_lit) (DLitT arg_lit) + | pat_lit == arg_lit = Just M.empty +matchTy _ _ _ = Nothing + +unionMaybeSubsts :: [Maybe DSubst] -> Maybe DSubst +unionMaybeSubsts = L.foldl' union_subst1 (Just M.empty) + where + union_subst1 :: Maybe DSubst -> Maybe DSubst -> Maybe DSubst + union_subst1 ma mb = do + a <- ma + b <- mb + unionSubsts a b diff --git a/Language/Haskell/TH/Desugar/Subst/Capturing.hs b/Language/Haskell/TH/Desugar/Subst/Capturing.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/TH/Desugar/Subst/Capturing.hs @@ -0,0 +1,77 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Language.Haskell.TH.Desugar.Subst.Capturing +-- Copyright : (C) 2024 Ryan Scott +-- License : BSD-style (see LICENSE) +-- Maintainer : Ryan Scott +-- Stability : experimental +-- Portability : non-portable +-- +-- Substitutions on 'DType's that do /not/ avoid capture. (For capture-avoiding +-- substitution functions, use "Language.Haskell.TH.Desugar.Subst" instead.) +-- +---------------------------------------------------------------------------- + +module Language.Haskell.TH.Desugar.Subst.Capturing ( + DSubst, + + -- * Non–capture-avoiding substitution + substTy, substForallTelescope, substTyVarBndrs, substTyVarBndr, + unionSubsts, unionMaybeSubsts, + + -- * Matching a type template against a type + IgnoreKinds(..), matchTy + ) where + +import Data.Bifunctor (second) +import qualified Data.List as L +import qualified Data.Map as M + +import Language.Haskell.TH.Desugar.AST +import Language.Haskell.TH.Desugar.Subst + (DSubst, unionSubsts, unionMaybeSubsts, IgnoreKinds(..), matchTy) + +-- | Non–capture-avoiding substitution on 'DType's. Unlike the @substTy@ +-- function in "Language.Haskell.TH.Desugar.Subst", this 'substTy' function is +-- pure, as it never needs to create fresh names. +substTy :: DSubst -> DType -> DType +substTy subst ty | M.null subst = ty +substTy subst (DForallT tele inner_ty) + = DForallT tele' inner_ty' + where + (subst', tele') = substForallTelescope subst tele + inner_ty' = substTy subst' inner_ty +substTy subst (DConstrainedT cxt inner_ty) = + DConstrainedT (map (substTy subst) cxt) (substTy subst inner_ty) +substTy subst (DAppT ty1 ty2) = substTy subst ty1 `DAppT` substTy subst ty2 +substTy subst (DAppKindT ty ki) = substTy subst ty `DAppKindT` substTy subst ki +substTy subst (DSigT ty ki) = substTy subst ty `DSigT` substTy subst ki +substTy subst (DVarT n) = + case M.lookup n subst of + Just ki -> ki + Nothing -> DVarT n +substTy _ ty@(DConT {}) = ty +substTy _ ty@(DArrowT) = ty +substTy _ ty@(DLitT {}) = ty +substTy _ ty@DWildCardT = ty + +-- | Non–capture-avoiding substitution on 'DForallTelescope's. This returns a +-- pair containing the new 'DSubst' as well as a new 'DForallTelescope' value, +-- where the kinds have been substituted. +substForallTelescope :: DSubst -> DForallTelescope -> (DSubst, DForallTelescope) +substForallTelescope s (DForallInvis tvbs) = second DForallInvis $ substTyVarBndrs s tvbs +substForallTelescope s (DForallVis tvbs) = second DForallVis $ substTyVarBndrs s tvbs + +-- | Non–capture-avoiding substitution on a telescope of 'DTyVarBndr's. This +-- returns a pair containing the new 'DSubst' as well as a new telescope of +-- 'DTyVarBndr's, where the kinds have been substituted. +substTyVarBndrs :: DSubst -> [DTyVarBndr flag] -> (DSubst, [DTyVarBndr flag]) +substTyVarBndrs = L.mapAccumL substTyVarBndr + +-- | Non–capture-avoiding substitution on a 'DTyVarBndr'. This updates the +-- 'DSubst' to remove the 'DTyVarBndr' name from the domain (as that name is now +-- bound by the 'DTyVarBndr') and applies the substitution to the kind of the +-- 'DTyVarBndr'. +substTyVarBndr :: DSubst -> DTyVarBndr flag -> (DSubst, DTyVarBndr flag) +substTyVarBndr s tvb@(DPlainTV n _) = (M.delete n s, tvb) +substTyVarBndr s (DKindedTV n f k) = (M.delete n s, DKindedTV n f (substTy s k)) 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,20 +1,20 @@ {- Language/Haskell/TH/Desugar/Sweeten.hs (c) Richard Eisenberg 2013 -eir@cis.upenn.edu +rae@cs.brynmawr.edu Converts desugared TH back into real TH. -} {-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskellQuotes #-} ----------------------------------------------------------------------------- -- | -- Module : Language.Haskell.TH.Desugar.Sweeten -- Copyright : (C) 2014 Richard Eisenberg -- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (eir@cis.upenn.edu) +-- Maintainer : Ryan Scott -- Stability : experimental -- Portability : non-portable -- @@ -28,301 +28,504 @@ letDecToTH, typeToTH, conToTH, foreignToTH, pragmaToTH, ruleBndrToTH, - clauseToTH, tvbToTH, cxtToTH, predToTH + clauseToTH, tvbToTH, cxtToTH, predToTH, derivClauseToTH, +#if __GLASGOW_HASKELL__ >= 801 + patSynDirToTH, +#endif + + typeArgToTH ) where import Prelude hiding (exp) import Control.Arrow -import Language.Haskell.TH hiding (cxt) +import Language.Haskell.TH hiding (Extension(..), cxt) +import Language.Haskell.TH.Datatype.TyVarBndr -import Language.Haskell.TH.Desugar.Core +import Language.Haskell.TH.Desugar.AST +import Language.Haskell.TH.Desugar.Core (DTypeArg(..)) import Language.Haskell.TH.Desugar.Util -import Data.Maybe ( maybeToList ) - expToTH :: DExp -> Exp expToTH (DVarE n) = VarE n expToTH (DConE n) = ConE n expToTH (DLitE l) = LitE l expToTH (DAppE e1 e2) = AppE (expToTH e1) (expToTH e2) -expToTH (DLamE names exp) = LamE (map VarP names) (expToTH exp) -expToTH (DCaseE exp matches) = CaseE (expToTH exp) (map matchToTH matches) expToTH (DLetE decs exp) = LetE (map letDecToTH decs) (expToTH exp) expToTH (DSigE exp ty) = SigE (expToTH exp) (typeToTH ty) -#if __GLASGOW_HASKELL__ < 709 -expToTH (DStaticE _) = error "Static expressions supported only in GHC 7.10+" -#else expToTH (DStaticE exp) = StaticE (expToTH exp) +#if __GLASGOW_HASKELL__ >= 801 +expToTH (DAppTypeE exp ty) = AppTypeE (expToTH exp) (typeToTH ty) +#else +-- In the event that we're on a version of Template Haskell without support for +-- type applications, we will simply drop the applied type. +expToTH (DAppTypeE exp _) = expToTH exp #endif +expToTH (DLamCasesE clauses) + -- In the source language, `\cases` expressions must have at least one clause. + -- As such, we adopt the convention that a DLamCasesE value with no clauses + -- shall sweeten to a `\case{}` expression. Unlike `\cases`, it is legal for + -- `\case` to have no clauses, and `\case{}` is assumed to have a single + -- argument. + | null clauses + = LamCaseE [] +#if __GLASGOW_HASKELL__ >= 904 + -- If building with GHC 9.4 or later, sweetening a DLamCasesE value is as + -- simple as using LamCasesE... + | otherwise + = LamCasesE (map clauseToTH clauses) +#else + -- ...but if we are building with a pre-9.4 version of GHC, we do not have + -- access to LamCasesE, making our life harder. We want to have at least + -- /some/ support for sweetening DLamCasesE values, since we desugar simpler + -- language constructs like lambda, `case`, and `\case` expressions to + -- DLamCasesE, and we'd like to be able to sweeten them back. + -- + -- Therefore, we add special treatment for DLamCasesE values that look simpler + -- language constructs and sweeten these back to LamE, LamCaseE, etc. If we + -- encounter anything more complicated, we give up and raise an error. + -- Special case: if a DLamCasesE value has exactly one clause, we can sweeten + -- the DLamCasesE value as though it were a lambda expression (LamE). + | [DClause pats exp] <- clauses + = LamE (map patToTH pats) (expToTH exp) + -- Special case: if a DLamCasesE value's clauses each have exactly one + -- pattern, we can sweeten the DLamCasesE value as though it were a `\case` + -- expression (LamCaseE). + | Just matches <- traverse dMatch_maybe clauses + = LamCaseE (map matchToTH matches) + -- NB: You might wonder why there is not another special case that returns + -- CaseE for things that look like `case` expressions. This is because the + -- special case for LamCaseE above already suffices. Note that we desugar + -- `case` expressions to code that looks like this: + -- + -- (\cases + -- pat_1 -> rhs_1 + -- ... + -- pat_n -> rhs_n) scrut + -- + -- That is, a value that looks like `DAppE (DLamCasesE ...) scrut`. Each + -- clause in the DLamCasesE value has exactly one pattern, however. Therefore, + -- because of the special treatment for LamCaseE above, this code would + -- sweeten to `AppE (LamCaseE ...) scrut`. + + -- If we lack a special case for the DLamCasesE value, then we raise an error. + | otherwise + = error $ unlines + [ "Non-trivial \\cases expressions supported only in GHC 9.4+." + , "Here, \"non-trivial\" means that the \\cases expression cannot easily" + , "be rewritten to a lambda, case, or \\case expression without" + , "significantly rewriting the expression. Either rewrite the expression" + , "yourself or upgrade to a later version of GHC." + ] +#endif +#if __GLASGOW_HASKELL__ >= 907 +expToTH (DTypedBracketE exp) = TypedBracketE (expToTH exp) +expToTH (DTypedSpliceE exp) = TypedSpliceE (expToTH exp) +#else +expToTH (DTypedBracketE {}) = + error "Typed Template Haskell brackets supported only in GHC 9.8+" +expToTH (DTypedSpliceE {}) = + error "Typed Template Haskell splices supported only in GHC 9.8+" +#endif +#if __GLASGOW_HASKELL__ >= 909 +expToTH (DTypeE ty) = TypeE (typeToTH ty) +#else +expToTH (DTypeE {}) = + error "Embedded type expressions supported only in GHC 9.10+" +#endif +#if __GLASGOW_HASKELL__ >= 911 +expToTH (DForallE tele exp) = + case tele of + DForallInvis tvbs -> ForallE (map tvbToTH tvbs) exp' + DForallVis tvbs -> ForallVisE (map tvbToTH tvbs) exp' + where + exp' = expToTH exp +expToTH (DConstrainedE cxt exp) = ConstrainedE (map expToTH cxt) (expToTH exp) +#else +expToTH (DForallE {}) = + error "Embedded `forall`s supported only in GHC 9.12+" +expToTH (DConstrainedE {}) = + error "Embedded constraints supported only in GHC 9.12+" +#endif + matchToTH :: DMatch -> Match matchToTH (DMatch pat exp) = Match (patToTH pat) (NormalB (expToTH exp)) [] patToTH :: DPat -> Pat -patToTH (DLitPa lit) = LitP lit -patToTH (DVarPa n) = VarP n -patToTH (DConPa n pats) = ConP n (map patToTH pats) -patToTH (DTildePa pat) = TildeP (patToTH pat) -patToTH (DBangPa pat) = BangP (patToTH pat) -patToTH DWildPa = WildP +patToTH (DLitP lit) = LitP lit +patToTH (DVarP n) = VarP n +patToTH (DConP n _tys pats) = ConP n +#if __GLASGOW_HASKELL__ >= 901 + (map typeToTH _tys) +#endif + (map patToTH pats) +patToTH (DTildeP pat) = TildeP (patToTH pat) +patToTH (DBangP pat) = BangP (patToTH pat) +patToTH (DSigP pat ty) = SigP (patToTH pat) (typeToTH ty) +patToTH DWildP = WildP +#if __GLASGOW_HASKELL__ >= 909 +patToTH (DTypeP ty) = TypeP (typeToTH ty) +patToTH (DInvisP ty) = InvisP (typeToTH ty) +#else +patToTH (DTypeP {}) = + error "Embedded type patterns supported only in GHC 9.10+" +patToTH (DInvisP {}) = + error "Invisible type patterns supported only in GHC 9.10+" +#endif decsToTH :: [DDec] -> [Dec] -decsToTH = concatMap decToTH +decsToTH = map decToTH -- | This returns a list of @Dec@s because GHC 7.6.3 does not have -- a one-to-one mapping between 'DDec' and @Dec@. -decToTH :: DDec -> [Dec] -decToTH (DLetDec d) = [letDecToTH d] -decToTH (DDataD Data cxt n tvbs cons derivings) = -#if __GLASGOW_HASKELL__ > 710 - [DataD (cxtToTH cxt) n (map tvbToTH tvbs) Nothing (map conToTH cons) - (cxtToTH derivings)] -#else - [DataD (cxtToTH cxt) n (map tvbToTH tvbs) (map conToTH cons) - (map derivingToTH derivings)] -#endif -decToTH (DDataD Newtype cxt n tvbs [con] derivings) = -#if __GLASGOW_HASKELL__ > 710 - [NewtypeD (cxtToTH cxt) n (map tvbToTH tvbs) Nothing (conToTH con) - (cxtToTH derivings)] -#else - [NewtypeD (cxtToTH cxt) n (map tvbToTH tvbs) (conToTH con) - (map derivingToTH derivings)] -#endif -decToTH (DTySynD n tvbs ty) = [TySynD n (map tvbToTH tvbs) (typeToTH ty)] +decToTH :: DDec -> Dec +decToTH (DLetDec d) = letDecToTH d +decToTH (DDataD Data cxt n tvbs _mk cons derivings) = + DataD (cxtToTH cxt) n (map tvbToTH tvbs) (fmap typeToTH _mk) (map conToTH cons) + (concatMap derivClauseToTH derivings) +decToTH (DDataD Newtype cxt n tvbs _mk [con] derivings) = + NewtypeD (cxtToTH cxt) n (map tvbToTH tvbs) (fmap typeToTH _mk) (conToTH con) + (concatMap derivClauseToTH derivings) +decToTH (DDataD Newtype _cxt _n _tvbs _mk _cons _derivings) = + error "Newtype declaration without exactly 1 constructor." +decToTH (DTySynD n tvbs ty) = TySynD n (map tvbToTH tvbs) (typeToTH ty) decToTH (DClassD cxt n tvbs fds decs) = - [ClassD (cxtToTH cxt) n (map tvbToTH tvbs) fds (decsToTH decs)] -#if __GLASGOW_HASKELL__ >= 711 -decToTH (DInstanceD over cxt ty decs) = - [InstanceD over (cxtToTH cxt) (typeToTH ty) (decsToTH decs)] -#else -decToTH (DInstanceD _ cxt ty decs) = - [InstanceD (cxtToTH cxt) (typeToTH ty) (decsToTH decs)] -#endif -decToTH (DForeignD f) = [ForeignD (foreignToTH f)] -decToTH (DPragmaD prag) = maybeToList $ fmap PragmaD (pragmaToTH prag) -#if __GLASGOW_HASKELL__ > 710 + ClassD (cxtToTH cxt) n (map tvbToTH tvbs) fds (decsToTH decs) +decToTH (DInstanceD over _mtvbs cxt ty decs) = + -- We deliberately avoid sweetening _mtvbs. See #151. + instanceDToTH over cxt ty decs +decToTH (DForeignD f) = ForeignD (foreignToTH f) decToTH (DOpenTypeFamilyD (DTypeFamilyHead n tvbs frs ann)) = - [OpenTypeFamilyD (TypeFamilyHead n (map tvbToTH tvbs) (frsToTH frs) ann)] + OpenTypeFamilyD (TypeFamilyHead n (map tvbToTH tvbs) (frsToTH frs) ann) +decToTH (DDataFamilyD n tvbs mk) = + DataFamilyD n (map tvbToTH tvbs) (fmap typeToTH mk) +decToTH (DDataInstD nd cxt mtvbs lhs mk cons derivings) = + let ndc = case (nd, cons) of + (Newtype, [con]) -> DNewtypeCon con + (Newtype, _) -> error "Newtype that doesn't have only one constructor" + (Data, _) -> DDataCons cons + (TypeData, _) -> error "Data family instance that is combined with `type data`" + in dataInstDecToTH ndc cxt mtvbs lhs mk derivings +#if __GLASGOW_HASKELL__ >= 807 +decToTH (DTySynInstD eqn) = TySynInstD (snd $ tySynEqnToTH eqn) #else -decToTH (DOpenTypeFamilyD (DTypeFamilyHead n tvbs frs _ann)) = - [FamilyD TypeFam n (map tvbToTH tvbs) (frsToTH frs)] +decToTH (DTySynInstD eqn) = + let (n, eqn') = tySynEqnToTH eqn in + TySynInstD n eqn' #endif -decToTH (DDataFamilyD n tvbs) = -#if __GLASGOW_HASKELL__ > 710 - [DataFamilyD n (map tvbToTH tvbs) Nothing] +decToTH (DClosedTypeFamilyD (DTypeFamilyHead n tvbs frs ann) eqns) = + ClosedTypeFamilyD (TypeFamilyHead n (map tvbToTH tvbs) (frsToTH frs) ann) + (map (snd . tySynEqnToTH) eqns) +decToTH (DRoleAnnotD n roles) = RoleAnnotD n roles +decToTH (DStandaloneDerivD mds _mtvbs cxt ty) = + -- We deliberately avoid sweetening _mtvbs. See #151. + standaloneDerivDToTH mds cxt ty +decToTH (DDefaultSigD n ty) = DefaultSigD n (typeToTH ty) +#if __GLASGOW_HASKELL__ >= 801 +decToTH (DPatSynD n args dir pat) = PatSynD n args (patSynDirToTH dir) (patToTH pat) +decToTH (DPatSynSigD n ty) = PatSynSigD n (typeToTH ty) #else - [FamilyD DataFam n (map tvbToTH tvbs) Nothing] +decToTH DPatSynD{} = patSynErr +decToTH DPatSynSigD{} = patSynErr #endif -decToTH (DDataInstD Data cxt n tys cons derivings) = -#if __GLASGOW_HASKELL__ > 710 - [DataInstD (cxtToTH cxt) n (map typeToTH tys) Nothing (map conToTH cons) - (cxtToTH derivings) - ] +#if __GLASGOW_HASKELL__ >= 809 +decToTH (DKiSigD n ki) = KiSigD n (typeToTH ki) #else - [DataInstD (cxtToTH cxt) n (map typeToTH tys) (map conToTH cons) - (map derivingToTH derivings) - ] +decToTH (DKiSigD {}) = + error "Standalone kind signatures supported only in GHC 8.10+" #endif -decToTH (DDataInstD Newtype cxt n tys [con] derivings) = -#if __GLASGOW_HASKELL__ > 710 - [NewtypeInstD (cxtToTH cxt) n (map typeToTH tys) Nothing (conToTH con) - (cxtToTH derivings) - ] +#if __GLASGOW_HASKELL__ >= 903 +decToTH (DDefaultD tys) = DefaultD (map typeToTH tys) #else - [NewtypeInstD (cxtToTH cxt) n (map typeToTH tys) (conToTH con) - (map derivingToTH derivings) - ] +decToTH (DDefaultD{}) = + error "Default declarations supported only in GHC 9.4+" #endif -#if __GLASGOW_HASKELL__ < 707 -decToTH (DTySynInstD n eqn) = [tySynEqnToTHDec n eqn] -decToTH (DClosedTypeFamilyD (DTypeFamilyHead n tvbs frs _ann) eqns) = - (FamilyD TypeFam n (map tvbToTH tvbs) (frsToTH frs)) : - (map (tySynEqnToTHDec n) eqns) -decToTH (DRoleAnnotD {}) = [] -#else -decToTH (DTySynInstD n eqn) = [TySynInstD n (tySynEqnToTH eqn)] -#if __GLASGOW_HASKELL__ > 710 -decToTH (DClosedTypeFamilyD (DTypeFamilyHead n tvbs frs ann) eqns) = - [ClosedTypeFamilyD (TypeFamilyHead n (map tvbToTH tvbs) (frsToTH frs) ann) - (map tySynEqnToTH eqns) - ] +#if __GLASGOW_HASKELL__ >= 906 +decToTH (DDataD TypeData _cxt n tvbs mk cons _derivings) = + -- NB: Due to the invariants on 'DDataD' and 'TypeData', _cxt and _derivings + -- will be empty. + TypeDataD n (map tvbToTH tvbs) (fmap typeToTH mk) (map conToTH cons) #else -decToTH (DClosedTypeFamilyD (DTypeFamilyHead n tvbs frs _ann) eqns) = - [ClosedTypeFamilyD n (map tvbToTH tvbs) (frsToTH frs) (map tySynEqnToTH eqns)] +decToTH (DDataD TypeData _cxt _n _tvbs _mk _cons _derivings) = + error "`type data` declarations supported only in GHC 9.6+" #endif -decToTH (DRoleAnnotD n roles) = [RoleAnnotD n roles] + +#if __GLASGOW_HASKELL__ < 801 +patSynErr :: a +patSynErr = error "Pattern synonyms supported only in GHC 8.2+" #endif -#if __GLASGOW_HASKELL__ < 709 -decToTH (DStandaloneDerivD {}) = - error "Standalone deriving supported only in GHC 7.10+" -decToTH (DDefaultSigD {}) = - error "Default method signatures supported only in GHC 7.10+" + +-- | Indicates whether something is a newtype or data type, bundling its +-- constructor(s) along with it. +data DNewOrDataCons + = DNewtypeCon DCon + | DDataCons [DCon] + +-- | Sweeten a 'DDataInstD'. +dataInstDecToTH :: DNewOrDataCons -> DCxt -> Maybe [DTyVarBndrUnit] -> DType + -> Maybe DKind -> [DDerivClause] -> Dec +dataInstDecToTH ndc cxt _mtvbs lhs _mk derivings = + case ndc of + DNewtypeCon con -> +#if __GLASGOW_HASKELL__ >= 807 + NewtypeInstD (cxtToTH cxt) (fmap (fmap tvbToTH) _mtvbs) (typeToTH lhs) + (fmap typeToTH _mk) (conToTH con) + (concatMap derivClauseToTH derivings) #else -decToTH (DStandaloneDerivD cxt ty) = - [StandaloneDerivD (cxtToTH cxt) (typeToTH ty)] -decToTH (DDefaultSigD n ty) = [DefaultSigD n (typeToTH ty)] + NewtypeInstD (cxtToTH cxt) _n _lhs_args (fmap typeToTH _mk) (conToTH con) + (concatMap derivClauseToTH derivings) #endif -decToTH _ = error "Newtype declaration without exactly 1 constructor." -#if __GLASGOW_HASKELL__ > 710 + DDataCons cons -> +#if __GLASGOW_HASKELL__ >= 807 + DataInstD (cxtToTH cxt) (fmap (fmap tvbToTH) _mtvbs) (typeToTH lhs) + (fmap typeToTH _mk) (map conToTH cons) + (concatMap derivClauseToTH derivings) +#else + DataInstD (cxtToTH cxt) _n _lhs_args (fmap typeToTH _mk) (map conToTH cons) + (concatMap derivClauseToTH derivings) +#endif + where + _lhs' = typeToTH lhs + (_n, _lhs_args) = + case unfoldType _lhs' of + (ConT n, lhs_args) -> (n, filterTANormals lhs_args) + (_, _) -> error $ "Illegal data instance LHS: " ++ pprint _lhs' + frsToTH :: DFamilyResultSig -> FamilyResultSig frsToTH DNoSig = NoSig frsToTH (DKindSig k) = KindSig (typeToTH k) frsToTH (DTyVarSig tvb) = TyVarSig (tvbToTH tvb) -#else -frsToTH :: DFamilyResultSig -> Maybe Kind -frsToTH DNoSig = Nothing -frsToTH (DKindSig k) = Just (typeToTH k) -frsToTH (DTyVarSig (DPlainTV _)) = Nothing -frsToTH (DTyVarSig (DKindedTV _ k)) = Just (typeToTH k) -#endif -#if __GLASGOW_HASKELL__ <= 710 -derivingToTH :: DPred -> Name -derivingToTH (DConPr nm) = nm -derivingToTH p = - error ("Template Haskell in GHC < 8.0 only allows simple derivings: " ++ show p) -#endif - +-- | Sweeten a 'DLetDec'. letDecToTH :: DLetDec -> Dec letDecToTH (DFunD name clauses) = FunD name (map clauseToTH clauses) letDecToTH (DValD pat exp) = ValD (patToTH pat) (NormalB (expToTH exp)) [] letDecToTH (DSigD name ty) = SigD name (typeToTH ty) -letDecToTH (DInfixD f name) = InfixD f name +letDecToTH (DInfixD f _ns_spec name) = + InfixD f +#if __GLASGOW_HASKELL__ >= 909 + _ns_spec +#endif + name +letDecToTH (DPragmaD prag) = PragmaD (pragmaToTH prag) conToTH :: DCon -> Con -#if __GLASGOW_HASKELL__ > 710 -conToTH (DCon [] [] n (DNormalC stys) (Just rty)) = +conToTH (DCon [] [] n (DNormalC _ stys) rty) = GadtC [n] (map (second typeToTH) stys) (typeToTH rty) -conToTH (DCon [] [] n (DRecC vstys) (Just rty)) = +conToTH (DCon [] [] n (DRecC vstys) rty) = RecGadtC [n] (map (thirdOf3 typeToTH) vstys) (typeToTH rty) -#endif -conToTH (DCon [] [] n (DNormalC stys) _) = -#if __GLASGOW_HASKELL__ > 710 - NormalC n (map (second typeToTH) stys) -#else - NormalC n (map (bangToStrict *** typeToTH) stys) -#endif -conToTH (DCon [] [] n (DRecC vstys) _) = -#if __GLASGOW_HASKELL__ > 710 - RecC n (map (thirdOf3 typeToTH) vstys) -#else - RecC n (map (\(v,b,t) -> (v,bangToStrict b,typeToTH t)) vstys) -#endif +-- On GHC 8.0 or later, we sweeten every constructor to GADT syntax, so it is +-- perfectly OK to put all of the quantified type variables +-- (both universal and existential) in a ForallC. conToTH (DCon tvbs cxt n fields rty) = ForallC (map tvbToTH tvbs) (cxtToTH cxt) (conToTH $ DCon [] [] n fields rty) +instanceDToTH :: Maybe Overlap -> DCxt -> DType -> [DDec] -> Dec +instanceDToTH over cxt ty decs = + InstanceD over (cxtToTH cxt) (typeToTH ty) (decsToTH decs) + +standaloneDerivDToTH :: Maybe DDerivStrategy -> DCxt -> DType -> Dec +standaloneDerivDToTH _mds cxt ty = + StandaloneDerivD +#if __GLASGOW_HASKELL__ >= 802 + (fmap derivStrategyToTH _mds) +#endif + (cxtToTH cxt) (typeToTH ty) + foreignToTH :: DForeign -> Foreign foreignToTH (DImportF cc safety str n ty) = ImportF cc safety str n (typeToTH ty) foreignToTH (DExportF cc str n ty) = ExportF cc str n (typeToTH ty) -pragmaToTH :: DPragma -> Maybe Pragma -pragmaToTH (DInlineP n inl rm phases) = Just $ InlineP n inl rm phases +pragmaToTH :: DPragma -> Pragma +pragmaToTH (DInlineP n inl rm phases) = InlineP n inl rm phases pragmaToTH (DSpecialiseP n ty m_inl phases) = - Just $ SpecialiseP n (typeToTH ty) m_inl phases -pragmaToTH (DSpecialiseInstP ty) = Just $ SpecialiseInstP (typeToTH ty) -pragmaToTH (DRuleP str rbs lhs rhs phases) = - Just $ RuleP str (map ruleBndrToTH rbs) (expToTH lhs) (expToTH rhs) phases -#if __GLASGOW_HASKELL__ < 707 -pragmaToTH (DAnnP {}) = Nothing + SpecialiseP n (typeToTH ty) m_inl phases +pragmaToTH (DSpecialiseInstP ty) = SpecialiseInstP (typeToTH ty) +#if __GLASGOW_HASKELL__ >= 807 +pragmaToTH (DRuleP str mtvbs rbs lhs rhs phases) = + RuleP str (fmap (fmap tvbToTH) mtvbs) (map ruleBndrToTH rbs) + (expToTH lhs) (expToTH rhs) phases #else -pragmaToTH (DAnnP target exp) = Just $ AnnP target (expToTH exp) +pragmaToTH (DRuleP str _ rbs lhs rhs phases) = + RuleP str (map ruleBndrToTH rbs) (expToTH lhs) (expToTH rhs) phases #endif -#if __GLASGOW_HASKELL__ < 709 -pragmaToTH (DLineP {}) = Nothing +pragmaToTH (DAnnP target exp) = AnnP target (expToTH exp) +pragmaToTH (DLineP n str) = LineP n str +#if __GLASGOW_HASKELL__ < 801 +pragmaToTH (DCompleteP {}) = error "COMPLETE pragmas only supported in GHC 8.2+" #else -pragmaToTH (DLineP n str) = Just $ LineP n str +pragmaToTH (DCompleteP cls mty) = CompleteP cls mty #endif +#if __GLASGOW_HASKELL__ >= 903 +pragmaToTH (DOpaqueP n) = OpaqueP n +#else +pragmaToTH (DOpaqueP {}) = error "OPAQUE pragmas only supported in GHC 9.4+" +#endif +#if __GLASGOW_HASKELL__ >= 909 +pragmaToTH (DSCCP nm mstr) = SCCP nm mstr +#else +pragmaToTH (DSCCP {}) = error "SCCP pragmas only supported in GHC 9.10+" +#endif +#if __GLASGOW_HASKELL__ >= 913 +pragmaToTH (DSpecialiseEP mTyBndrs tmBndrs specE mInline phases) = + SpecialiseEP + (fmap (fmap tvbToTH) mTyBndrs) + (map ruleBndrToTH tmBndrs) + (expToTH specE) + mInline + phases +#else +pragmaToTH (DSpecialiseEP {}) = error "DSpecialiseEP pragmas only supported in GHC 9.14+" +#endif ruleBndrToTH :: DRuleBndr -> RuleBndr ruleBndrToTH (DRuleVar n) = RuleVar n ruleBndrToTH (DTypedRuleVar n ty) = TypedRuleVar n (typeToTH ty) -#if __GLASGOW_HASKELL__ < 707 --- | GHC 7.6.3 doesn't have TySynEqn, so we sweeten to a Dec in GHC 7.6.3; --- GHC 7.8+ does not use this function -tySynEqnToTHDec :: Name -> DTySynEqn -> Dec -tySynEqnToTHDec n (DTySynEqn lhs rhs) = - TySynInstD n (map typeToTH lhs) (typeToTH rhs) +#if __GLASGOW_HASKELL__ >= 807 +-- | It's convenient to also return a 'Name' here, since some call sites make +-- use of it. +tySynEqnToTH :: DTySynEqn -> (Name, TySynEqn) +tySynEqnToTH (DTySynEqn tvbs lhs rhs) = + let lhs' = typeToTH lhs in + case unfoldType lhs' of + (ConT n, _lhs_args) -> (n, TySynEqn (fmap (fmap tvbToTH) tvbs) lhs' (typeToTH rhs)) + (_, _) -> error $ "Illegal type instance LHS: " ++ pprint lhs' #else -tySynEqnToTH :: DTySynEqn -> TySynEqn -tySynEqnToTH (DTySynEqn lhs rhs) = TySynEqn (map typeToTH lhs) (typeToTH rhs) +tySynEqnToTH :: DTySynEqn -> (Name, TySynEqn) +tySynEqnToTH (DTySynEqn _ lhs rhs) = + let lhs' = typeToTH lhs in + case unfoldType lhs' of + (ConT n, lhs_args) -> (n, TySynEqn (filterTANormals lhs_args) (typeToTH rhs)) + (_, _) -> error $ "Illegal type instance LHS: " ++ pprint lhs' #endif clauseToTH :: DClause -> Clause clauseToTH (DClause pats exp) = Clause (map patToTH pats) (NormalB (expToTH exp)) [] typeToTH :: DType -> Type -typeToTH (DForallT tvbs cxt ty) = ForallT (map tvbToTH tvbs) (map predToTH cxt) (typeToTH ty) +-- We need a special case for DForallT ForallInvis followed by DConstrainedT +-- so that we may collapse them into a single ForallT when sweetening. +-- See Note [Desugaring and sweetening ForallT] in L.H.T.Desugar.Core. +typeToTH (DForallT (DForallInvis tvbs) (DConstrainedT ctxt ty)) = + ForallT (map tvbToTH tvbs) (map predToTH ctxt) (typeToTH ty) +typeToTH (DForallT tele ty) = + case tele of + DForallInvis tvbs -> ForallT (map tvbToTH tvbs) [] ty' + DForallVis _tvbs -> +#if __GLASGOW_HASKELL__ >= 809 + ForallVisT (map tvbToTH _tvbs) ty' +#else + error "Visible dependent quantification supported only in GHC 8.10+" +#endif + where + ty' = typeToTH ty +typeToTH (DConstrainedT cxt ty) = ForallT [] (map predToTH cxt) (typeToTH ty) typeToTH (DAppT t1 t2) = AppT (typeToTH t1) (typeToTH t2) typeToTH (DSigT ty ki) = SigT (typeToTH ty) (typeToTH ki) typeToTH (DVarT n) = VarT n typeToTH (DConT n) = tyconToTH n typeToTH DArrowT = ArrowT typeToTH (DLitT lit) = LitT lit -#if __GLASGOW_HASKELL__ > 710 typeToTH DWildCardT = WildCardT +#if __GLASGOW_HASKELL__ >= 807 +typeToTH (DAppKindT t k) = AppKindT (typeToTH t) (typeToTH k) #else -typeToTH DWildCardT = error "Wildcards supported only in GHC 8.0+" +-- In the event that we're on a version of Template Haskell without support for +-- kind applications, we will simply drop the applied kind. +typeToTH (DAppKindT t _) = typeToTH t #endif -typeToTH DStarT = StarT -tvbToTH :: DTyVarBndr -> TyVarBndr -tvbToTH (DPlainTV n) = PlainTV n -tvbToTH (DKindedTV n k) = KindedTV n (typeToTH k) +tvbToTH :: DTyVarBndr flag -> TyVarBndr_ flag +tvbToTH (DPlainTV n flag) = plainTVFlag n flag +tvbToTH (DKindedTV n flag k) = kindedTVFlag n flag (typeToTH k) cxtToTH :: DCxt -> Cxt cxtToTH = map predToTH -predToTH :: DPred -> Pred -#if __GLASGOW_HASKELL__ < 709 -predToTH = go [] - where - go acc (DAppPr p t) = go (typeToTH t : acc) p - go acc (DSigPr p _) = go acc p -- this shouldn't happen. - go _ (DVarPr _) - = error "Template Haskell in GHC <= 7.8 does not support variable constraints." - go acc (DConPr n) - | nameBase n == "~" - , [t1, t2] <- acc - = EqualP t1 t2 - | otherwise - = ClassP n acc - go _ DWildCardPr - = error "Wildcards supported only in GHC 8.0+" +#if __GLASGOW_HASKELL__ >= 801 +derivClauseToTH :: DDerivClause -> [DerivClause] +derivClauseToTH (DDerivClause mds cxt) = + [DerivClause (fmap derivStrategyToTH mds) (cxtToTH cxt)] #else -predToTH (DAppPr p t) = AppT (predToTH p) (typeToTH t) -predToTH (DSigPr p k) = SigT (predToTH p) (typeToTH k) -predToTH (DVarPr n) = VarT n -predToTH (DConPr n) = typeToTH (DConT n) -#if __GLASGOW_HASKELL__ > 710 -predToTH DWildCardPr = WildCardT +derivClauseToTH :: DDerivClause -> Cxt +derivClauseToTH (DDerivClause _ cxt) = cxtToTH cxt +#endif + +#if __GLASGOW_HASKELL__ >= 801 +derivStrategyToTH :: DDerivStrategy -> DerivStrategy +derivStrategyToTH DStockStrategy = StockStrategy +derivStrategyToTH DAnyclassStrategy = AnyclassStrategy +derivStrategyToTH DNewtypeStrategy = NewtypeStrategy +#if __GLASGOW_HASKELL__ >= 805 +derivStrategyToTH (DViaStrategy ty) = ViaStrategy (typeToTH ty) #else -predToTH DWildCardPr = error "Wildcards supported only in GHC 8.0+" +derivStrategyToTH (DViaStrategy _) = error "DerivingVia supported only in GHC 8.6+" #endif #endif +#if __GLASGOW_HASKELL__ >= 801 +patSynDirToTH :: DPatSynDir -> PatSynDir +patSynDirToTH DUnidir = Unidir +patSynDirToTH DImplBidir = ImplBidir +patSynDirToTH (DExplBidir clauses) = ExplBidir (map clauseToTH clauses) +#endif + +predToTH :: DPred -> Pred +predToTH (DAppT p t) = AppT (predToTH p) (typeToTH t) +predToTH (DSigT p k) = SigT (predToTH p) (typeToTH k) +predToTH (DVarT n) = VarT n +predToTH (DConT n) = typeToTH (DConT n) +predToTH DArrowT = ArrowT +predToTH (DLitT lit) = LitT lit +predToTH DWildCardT = WildCardT +#if __GLASGOW_HASKELL__ >= 805 +-- We need a special case for DForallT ForallInvis followed by DConstrainedT +-- so that we may collapse them into a single ForallT when sweetening. +-- See Note [Desugaring and sweetening ForallT] in L.H.T.Desugar.Core. +predToTH (DForallT (DForallInvis tvbs) (DConstrainedT ctxt p)) = + ForallT (map tvbToTH tvbs) (map predToTH ctxt) (predToTH p) +predToTH (DForallT tele p) = + case tele of + DForallInvis tvbs -> ForallT (map tvbToTH tvbs) [] (predToTH p) + DForallVis _ -> error "Visible dependent quantifier spotted at head of a constraint" +predToTH (DConstrainedT cxt p) = ForallT [] (map predToTH cxt) (predToTH p) +#else +predToTH (DForallT {}) = error "Quantified constraints supported only in GHC 8.6+" +predToTH (DConstrainedT {}) = error "Quantified constraints supported only in GHC 8.6+" +#endif +#if __GLASGOW_HASKELL__ >= 807 +predToTH (DAppKindT p k) = AppKindT (predToTH p) (typeToTH k) +#else +-- In the event that we're on a version of Template Haskell without support for +-- kind applications, we will simply drop the applied kind. +predToTH (DAppKindT p _) = predToTH p +#endif + tyconToTH :: Name -> Type tyconToTH n + | n == ''(->) = ArrowT -- Work around Trac #14888 | n == ''[] = ListT -#if __GLASGOW_HASKELL__ >= 709 | n == ''(~) = EqualityT -#endif | n == '[] = PromotedNilT | n == '(:) = PromotedConsT - | Just deg <- tupleNameDegree_maybe n = if isDataName n - then PromotedTupleT deg - else TupleT deg + | Just deg <- tupleNameDegree_maybe n + = if isDataName n +#if __GLASGOW_HASKELL__ >= 805 + then PromotedTupleT deg +#else + then PromotedT n -- Work around Trac #14843 +#endif + else TupleT deg | Just deg <- unboxedTupleNameDegree_maybe n = UnboxedTupleT deg +#if __GLASGOW_HASKELL__ >= 801 + | Just deg <- unboxedSumNameDegree_maybe n = UnboxedSumT deg +#endif | otherwise = ConT n -#if __GLASGOW_HASKELL__ <= 710 --- | Convert a 'Bang' to a 'Strict' -bangToStrict :: Bang -> Strict -bangToStrict (Bang SourceUnpack _) = Unpacked -bangToStrict (Bang _ SourceStrict) = IsStrict -bangToStrict (Bang _ _) = NotStrict -#endif +typeArgToTH :: DTypeArg -> TypeArg +typeArgToTH (DTANormal t) = TANormal (typeToTH t) +typeArgToTH (DTyArg k) = TyArg (typeToTH k) 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,264 +1,1243 @@ {- Language/Haskell/TH/Desugar/Util.hs (c) Richard Eisenberg 2013 -eir@cis.upenn.edu - -Utility functions for th-desugar package. --} - -{-# LANGUAGE CPP, TupleSections #-} - -module Language.Haskell.TH.Desugar.Util ( - newUniqueName, - impossible, - nameOccursIn, allNamesIn, mkTypeName, mkDataName, isDataName, - stripVarP_maybe, extractBoundNamesStmt, - concatMapM, mapMaybeM, expectJustM, - stripPlainTV_maybe, - thirdOf3, splitAtList, extractBoundNamesDec, - extractBoundNamesPat, - tvbName, tvbToType, nameMatches, freeNamesOfTypes, thdOf3, firstMatch, - tupleDegree_maybe, tupleNameDegree_maybe, unboxedTupleDegree_maybe, - unboxedTupleNameDegree_maybe, splitTuple_maybe - ) where - -import Prelude hiding (mapM, foldl, concatMap, any) - -import Language.Haskell.TH hiding ( cxt ) -import Language.Haskell.TH.Syntax - -import qualified Data.Set as S -import Data.Foldable -import Data.Generics hiding ( Fixity ) -import Data.Traversable -import Data.Maybe -import Data.Monoid - ----------------------------------------- --- TH manipulations ----------------------------------------- - --- | Like newName, but even more unique (unique across different splices), --- and with unique @nameBase@s. Precondition: the string is a valid Haskell --- alphanumeric identifier (could be upper- or lower-case). -newUniqueName :: Quasi q => String -> q Name -newUniqueName str = do - n <- qNewName str - qNewName $ show n - --- | Like TH's @lookupTypeName@, but if this name is not bound, then we assume --- it is declared in the current module. -mkTypeName :: Quasi q => String -> q Name -mkTypeName str = do - m_name <- qLookupName True str - case m_name of - Just name -> return name - Nothing -> do - Loc { loc_package = pkg, loc_module = modu } <- qLocation - return $ mkNameG_tc pkg modu str - --- | Like TH's @lookupDataName@, but if this name is not bound, then we assume --- it is declared in the current module. -mkDataName :: Quasi q => String -> q Name -mkDataName str = do - m_name <- qLookupName False str - case m_name of - Just name -> return name - Nothing -> do - Loc { loc_package = pkg, loc_module = modu } <- qLocation - return $ mkNameG_d pkg modu str - --- | Is this name a data constructor name? A 'False' answer means "unsure". -isDataName :: Name -> Bool -isDataName (Name _ (NameG DataName _ _)) = True -isDataName _ = False - --- | Extracts the name out of a variable pattern, or returns @Nothing@ -stripVarP_maybe :: Pat -> Maybe Name -stripVarP_maybe (VarP name) = Just name -stripVarP_maybe _ = Nothing - --- | Extracts the name out of a @PlainTV@, or returns @Nothing@ -stripPlainTV_maybe :: TyVarBndr -> Maybe Name -stripPlainTV_maybe (PlainTV n) = Just n -stripPlainTV_maybe _ = Nothing - --- | Report that a certain TH construct is impossible -impossible :: Monad q => String -> q a -impossible err = fail (err ++ "\n This should not happen in Haskell.\n Please email eir@cis.upenn.edu with your code if you see this.") - --- | Extract a 'Name' from a 'TyVarBndr' -tvbName :: TyVarBndr -> Name -tvbName (PlainTV n) = n -tvbName (KindedTV n _) = n - --- | Convert a 'TyVarBndr' into a 'Type' -tvbToType :: TyVarBndr -> Type -tvbToType = VarT . tvbName - --- | Do two names name the same thing? -nameMatches :: Name -> Name -> Bool -nameMatches n1@(Name occ1 flav1) n2@(Name occ2 flav2) - | NameS <- flav1 = occ1 == occ2 - | NameS <- flav2 = occ1 == occ2 - | NameQ mod1 <- flav1 - , NameQ mod2 <- flav2 - = mod1 == mod2 && occ1 == occ2 - | NameQ mod1 <- flav1 - , NameG _ _ mod2 <- flav2 - = mod1 == mod2 && occ1 == occ2 - | NameG _ _ mod1 <- flav1 - , NameQ mod2 <- flav2 - = mod1 == mod2 && occ1 == occ2 - | otherwise - = n1 == n2 - --- | Extract the degree of a tuple -tupleDegree_maybe :: String -> Maybe Int -tupleDegree_maybe s = do - '(' : s1 <- return s - (commas, ")") <- return $ span (== ',') s1 - let degree - | "" <- commas = 0 - | otherwise = length commas + 1 - return degree - --- | Extract the degree of a tuple name -tupleNameDegree_maybe :: Name -> Maybe Int -tupleNameDegree_maybe = tupleDegree_maybe . nameBase - --- | Extract the degree of an unboxed tuple -unboxedTupleDegree_maybe :: String -> Maybe Int -unboxedTupleDegree_maybe s = do - '(' : '#' : s1 <- return s - (commas, "#)") <- return $ span (== ',') s1 - let degree - | "" <- commas = 0 - | otherwise = length commas + 1 - return degree - --- | Extract the degree of a tuple name -unboxedTupleNameDegree_maybe :: Name -> Maybe Int -unboxedTupleNameDegree_maybe = unboxedTupleDegree_maybe . nameBase - --- | If the argument is a tuple type, return the components -splitTuple_maybe :: Type -> Maybe [Type] -splitTuple_maybe t = go [] t - where go args (t1 `AppT` t2) = go (t2:args) t1 - go args (t1 `SigT` _k) = go args t1 - go args (ConT con_name) - | Just degree <- tupleNameDegree_maybe con_name - , length args == degree - = Just args - go args (TupleT degree) - | length args == degree - = Just args - go _ _ = Nothing - ----------------------------------------- --- Free names, etc. ----------------------------------------- - --- | Check if a name occurs anywhere within a TH tree. -nameOccursIn :: Data a => Name -> a -> Bool -nameOccursIn n = everything (||) $ mkQ False (== n) - --- | Extract all Names mentioned in a TH tree. -allNamesIn :: Data a => a -> [Name] -allNamesIn = everything (++) $ mkQ [] (:[]) - --- | Extract the names bound in a @Stmt@ -extractBoundNamesStmt :: Stmt -> S.Set Name -extractBoundNamesStmt (BindS pat _) = extractBoundNamesPat pat -extractBoundNamesStmt (LetS decs) = foldMap extractBoundNamesDec decs -extractBoundNamesStmt (NoBindS _) = S.empty -extractBoundNamesStmt (ParS stmtss) = foldMap (foldMap extractBoundNamesStmt) stmtss - --- | Extract the names bound in a @Dec@ that could appear in a @let@ expression. -extractBoundNamesDec :: Dec -> S.Set Name -extractBoundNamesDec (FunD name _) = S.singleton name -extractBoundNamesDec (ValD pat _ _) = extractBoundNamesPat pat -extractBoundNamesDec _ = S.empty - --- | Extract the names bound in a @Pat@ -extractBoundNamesPat :: Pat -> S.Set Name -extractBoundNamesPat (LitP _) = S.empty -extractBoundNamesPat (VarP name) = S.singleton name -extractBoundNamesPat (TupP pats) = foldMap extractBoundNamesPat pats -extractBoundNamesPat (UnboxedTupP pats) = foldMap extractBoundNamesPat pats -extractBoundNamesPat (ConP _ pats) = foldMap extractBoundNamesPat pats -extractBoundNamesPat (InfixP p1 _ p2) = extractBoundNamesPat p1 `S.union` - extractBoundNamesPat p2 -extractBoundNamesPat (UInfixP p1 _ p2) = extractBoundNamesPat p1 `S.union` - extractBoundNamesPat p2 -extractBoundNamesPat (ParensP pat) = extractBoundNamesPat pat -extractBoundNamesPat (TildeP pat) = extractBoundNamesPat pat -extractBoundNamesPat (BangP pat) = extractBoundNamesPat pat -extractBoundNamesPat (AsP name pat) = S.singleton name `S.union` extractBoundNamesPat pat -extractBoundNamesPat WildP = S.empty -extractBoundNamesPat (RecP _ field_pats) = let (_, pats) = unzip field_pats in - foldMap extractBoundNamesPat pats -extractBoundNamesPat (ListP pats) = foldMap extractBoundNamesPat pats -extractBoundNamesPat (SigP pat _) = extractBoundNamesPat pat -extractBoundNamesPat (ViewP _ pat) = extractBoundNamesPat pat - -freeNamesOfTypes :: [Type] -> S.Set Name -freeNamesOfTypes = mconcat . map go - where - go (ForallT tvbs cxt ty) = (go ty <> mconcat (map go_pred cxt)) - S.\\ S.fromList (map tvbName tvbs) - go (AppT t1 t2) = go t1 <> go t2 - go (SigT ty _) = go ty - go (VarT n) = S.singleton n - go _ = S.empty - -#if __GLASGOW_HASKELL__ >= 709 - go_pred = go -#else - go_pred (ClassP _ tys) = freeNamesOfTypes tys - go_pred (EqualP t1 t2) = go t1 <> go t2 -#endif - ----------------------------------------- --- General utility ----------------------------------------- - --- like GHC's -splitAtList :: [a] -> [b] -> ([b], [b]) -splitAtList [] x = ([], x) -splitAtList (_ : t) (x : xs) = - let (as, bs) = splitAtList t xs in - (x : as, bs) -splitAtList (_ : _) [] = ([], []) - -thdOf3 :: (a,b,c) -> c -thdOf3 (_,_,c) = c - -thirdOf3 :: (a -> b) -> (c, d, a) -> (c, d, b) -thirdOf3 f (c, d, a) = (c, d, f a) - --- lift concatMap into a monad --- could this be more efficient? --- | Concatenate the result of a @mapM@ -concatMapM :: (Monad monad, Monoid monoid, Traversable t) - => (a -> monad monoid) -> t a -> monad monoid -concatMapM fn list = do - bss <- mapM fn list - return $ fold bss - --- like GHC's -mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b] -mapMaybeM _ [] = return [] -mapMaybeM f (x:xs) = do - y <- f x - ys <- mapMaybeM f xs - return $ case y of - Nothing -> ys - Just z -> z : ys - -expectJustM :: Monad m => String -> Maybe a -> m a -expectJustM _ (Just x) = return x -expectJustM err Nothing = fail err - -firstMatch :: (a -> Maybe b) -> [a] -> Maybe b -firstMatch f xs = listToMaybe $ mapMaybe f xs +rae@cs.brynmawr.edu + +Utility functions for th-desugar package. +-} + +{-# LANGUAGE CPP, DeriveDataTypeable, DeriveGeneric, DeriveLift, RankNTypes, + ScopedTypeVariables, TupleSections, AllowAmbiguousTypes, + TemplateHaskellQuotes, TypeApplications, MagicHash #-} + +module Language.Haskell.TH.Desugar.Util ( + newUniqueName, + impossible, + nameOccursIn, allNamesIn, mkTypeName, mkDataName, mkNameWith, isDataName, + stripVarP_maybe, extractBoundNamesStmt, + concatMapM, mapAccumLM, mapMaybeM, expectJustM, + stripPlainTV_maybe, extractTvbKind_maybe, + thirdOf3, splitAtList, extractBoundNamesDec, + extractBoundNamesPat, + tvbToType, tvbToTypeWithSig, + nameMatches, thdOf3, liftFst, liftSnd, firstMatch, firstMatchM, + tupleNameDegree_maybe, + unboxedSumNameDegree_maybe, unboxedTupleNameDegree_maybe, splitTuple_maybe, + topEverywhereM, isInfixDataCon, + isTypeKindName, typeKindName, + unSigType, unfoldType, ForallTelescope(..), FunArgs(..), VisFunArg(..), + filterVisFunArgs, ravelType, unravelType, + TypeArg(..), applyType, filterTANormals, probablyWrongUnTypeArg, + tyVarBndrVisToTypeArg, tyVarBndrVisToTypeArgWithSig, + bindIP, + DataFlavor(..), + freeKindVariablesWellScoped, + ForAllTyFlag(..), tvbForAllTyFlagsToSpecs, tvbForAllTyFlagsToBndrVis, + matchUpSAKWithDecl + ) where + +import Prelude hiding (mapM, foldl, concatMap, any) + +import Language.Haskell.TH hiding ( cxt ) +import Language.Haskell.TH.Datatype +import Language.Haskell.TH.Datatype.TyVarBndr +import qualified Language.Haskell.TH.Desugar.OSet as OS +import Language.Haskell.TH.Desugar.OSet (OSet) +import Language.Haskell.TH.Instances () +import Language.Haskell.TH.Syntax + +import qualified Control.Monad.Fail as Fail +import Data.Foldable +import Data.Function ( on ) +import Data.Generics ( Data, Typeable, everything, extM, gmapM, mkQ ) +import qualified Data.Kind as Kind +import qualified Data.List as List +import qualified Data.Map as Map +import Data.Map ( Map ) +import Data.Maybe +import qualified Data.Set as Set +import Data.Traversable +import GHC.Classes ( IP ) +import GHC.Generics ( Generic ) +import Unsafe.Coerce ( unsafeCoerce ) + +#if __GLASGOW_HASKELL__ >= 900 +import Language.Haskell.TH.Ppr ( PprFlag(..) ) +import qualified Language.Haskell.TH.PprLib as Ppr +#endif + +#if __GLASGOW_HASKELL__ >= 906 +import GHC.Tuple ( Solo(MkSolo) ) +#elif __GLASGOW_HASKELL__ >= 900 +import GHC.Tuple ( Solo(Solo) ) +#endif + +#if __GLASGOW_HASKELL__ >= 908 +import GHC.Tuple ( Tuple0, Unit ) +import Text.Read ( readMaybe ) +#endif + +#if __GLASGOW_HASKELL__ >= 910 +import GHC.Types ( Solo#, Sum2#, Tuple0#, Unit# ) +#endif + +---------------------------------------- +-- TH manipulations +---------------------------------------- + +-- | Like newName, but even more unique (unique across different splices), +-- and with unique @nameBase@s. Precondition: the string is a valid Haskell +-- alphanumeric identifier (could be upper- or lower-case). +newUniqueName :: Quasi q => String -> q Name +newUniqueName str = do + n <- qNewName str + qNewName $ show n + +-- | @mkNameWith lookup_fun mkName_fun str@ looks up the exact 'Name' of @str@ +-- using the function @lookup_fun@. If it finds 'Just' the 'Name', meaning +-- that it is bound in the current scope, then it is returned. If it finds +-- 'Nothing', it assumes that @str@ is declared in the current module, and +-- uses @mkName_fun@ to construct the appropriate 'Name' to return. +mkNameWith :: Quasi q => (String -> q (Maybe Name)) + -> (String -> String -> String -> Name) + -> String -> q Name +mkNameWith lookup_fun mkName_fun str = do + m_name <- lookup_fun str + case m_name of + Just name -> return name + Nothing -> do + Loc { loc_package = pkg, loc_module = modu } <- qLocation + return $ mkName_fun pkg modu str + +-- | Like TH's @lookupTypeName@, but if this name is not bound, then we assume +-- it is declared in the current module. +mkTypeName :: Quasi q => String -> q Name +mkTypeName = mkNameWith (qLookupName True) mkNameG_tc + +-- | Like TH's @lookupDataName@, but if this name is not bound, then we assume +-- it is declared in the current module. +mkDataName :: Quasi q => String -> q Name +mkDataName = mkNameWith (qLookupName False) mkNameG_d + +-- | Is this name a data constructor name? A 'False' answer means "unsure". +isDataName :: Name -> Bool +isDataName (Name _ (NameG DataName _ _)) = True +isDataName _ = False + +-- | Extracts the name out of a variable pattern, or returns @Nothing@ +stripVarP_maybe :: Pat -> Maybe Name +stripVarP_maybe (VarP name) = Just name +stripVarP_maybe _ = Nothing + +-- | Extracts the name out of a @PlainTV@, or returns @Nothing@ +stripPlainTV_maybe :: TyVarBndr_ flag -> Maybe Name +stripPlainTV_maybe = elimTV Just (\_ _ -> Nothing) + +-- | Extracts the kind from a 'TyVarBndr'. Returns @'Just' k@ if the 'TyVarBndr' +-- is a 'KindedTV' and returns 'Nothing' if it is a 'PlainTV'. +extractTvbKind_maybe :: TyVarBndr_ flag -> Maybe Kind +extractTvbKind_maybe = elimTV (\_ -> Nothing) (\_ k -> Just k) + +-- | Report that a certain TH construct is impossible +impossible :: Fail.MonadFail q => String -> q a +impossible err = Fail.fail (err ++ "\n This should not happen in Haskell.\n Please email rae@cs.brynmawr.edu with your code if you see this.") + +-- | Convert a 'TyVarBndr' into a 'Type', dropping the kind signature +-- (if it has one). +tvbToType :: TyVarBndr_ flag -> Type +tvbToType = VarT . tvName + +-- | Convert a 'TyVarBndr' into a 'Type', preserving the kind signature +-- (if it has one). +tvbToTypeWithSig :: TyVarBndr_ flag -> Type +tvbToTypeWithSig = elimTV VarT (\n k -> SigT (VarT n) k) + +-- | Do two names name the same thing? +nameMatches :: Name -> Name -> Bool +nameMatches n1@(Name occ1 flav1) n2@(Name occ2 flav2) + | NameS <- flav1 = occ1 == occ2 + | NameS <- flav2 = occ1 == occ2 + | NameQ mod1 <- flav1 + , NameQ mod2 <- flav2 + = mod1 == mod2 && occ1 == occ2 + | NameQ mod1 <- flav1 + , NameG _ _ mod2 <- flav2 + = mod1 == mod2 && occ1 == occ2 + | NameG _ _ mod1 <- flav1 + , NameQ mod2 <- flav2 + = mod1 == mod2 && occ1 == occ2 + | otherwise + = n1 == n2 + +-- | Extract the degree of a tuple 'Name'. +-- +-- In addition to recognizing tuple syntax (e.g., @''(,,)@), this also +-- recognizes the following: +-- +-- * @''Unit@ (for 0-tuples) +-- +-- * @''Solo@/@'MkSolo@ (for 1-tuples) +-- +-- * @''Tuple@ (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'. +-- +-- In addition to recognizing unboxed sum syntax (e.g., @''(#||#)@), this also +-- recognizes @''Sum#@ (for unboxed -ary sum type constructors). In recent +-- versions of GHC, @''Sum2#@ is a synonym for @''(#|#)@, @''Sum3#@ is a synonym +-- for @''(#||#)@, and so on. As a result, we must check for @''Sum#@ in +-- 'unboxedSumNameDegree_maybe' to be thorough. +unboxedSumNameDegree_maybe :: Name -> Maybe Int +unboxedSumNameDegree_maybe name +#if __GLASGOW_HASKELL__ >= 910 + -- Check for Sum#. It is theoretically possible for the supplied + -- Name to be a user-defined data type named Sum#, rather than the actual + -- unboxed sum types defined in GHC.Types. As such, we check that the package + -- and module for the supplied Name does in fact come from ghc-prim:GHC.Types + -- as a sanity check. + | -- We use Sum2# here simply because it is a convenient identifier from + -- GHC.Types. We could just as well use any other identifier from GHC.Types, + -- however. + namePackage name == namePackage ''Sum2# + , nameModule name == nameModule ''Sum2# + , 'S':'u':'m':n:"#" <- nameBase name + -- This relies on the Read Int instance. This is more permissive than what + -- we need, since there are valid Int strings (e.g., "-1") that do not have + -- corresponding Sum# names (e.g., "Sum-1#" is not a data type in + -- GHC.Types). As such, we depend on the assumption that the input string + -- does in fact come from GHC.Types, which we check above. + = readMaybe [n] +#endif + -- ...otherwise, fall back on unboxed sum syntax. + | otherwise + = unboxedSumDegree_maybe (nameBase name) + +-- | Extract the degree of an unboxed tuple +unboxedTupleDegree_maybe :: String -> Maybe Int +unboxedTupleDegree_maybe = unboxedSumTupleDegree_maybe ',' + +-- | Extract the degree of an unboxed sum or tuple +unboxedSumTupleDegree_maybe :: Char -> String -> Maybe Int +unboxedSumTupleDegree_maybe sep s = do + '(' : '#' : s1 <- return s + (seps, "#)") <- return $ span (== sep) s1 + let degree + | "" <- seps = 0 + | otherwise = length seps + 1 + return degree + +-- | Extract the degree of an unboxed tuple 'Name'. +-- +-- In addition to recognizing unboxed tuple syntax (e.g., @''(#,,#)@), this also +-- recognizes the following: +-- +-- * @''Unit#@ (for unboxed 0-tuples) +-- +-- * @''Solo#@/@'Solo#@ (for unboxed 1-tuples) +-- +-- * @''Tuple#@ (for unboxed -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 'unboxedTupleNameDegree_maybe' to be thorough. +-- (There is no special unboxed tuple type constructor for @''Solo#@/@'Solo#@, +-- but we check them here as well for the sake of completeness.) +unboxedTupleNameDegree_maybe :: Name -> Maybe Int +unboxedTupleNameDegree_maybe name +#if __GLASGOW_HASKELL__ >= 910 + -- First, check for Solo#... + | name == ''Solo# = Just 1 + -- ...then, check for Unit#... + | name == ''Unit# = Just 0 + -- ...then, check for Tuple#. It is theoretically possible for the supplied + -- Name to be a user-defined data type named Tuple#, rather than the actual + -- unboxed tuple types defined in GHC.Types. As such, we check that the + -- package and module for the supplied Name does in fact come from + -- ghc-prim:GHC.Types as a sanity check. + | -- We use Tuple0# here simply because it is a convenient identifier from + -- GHC.Types. We could just as well use any other identifier from GHC.Types, + -- however. + namePackage name == namePackage ''Tuple0# + , nameModule name == nameModule ''Tuple0# + , 'T':'u':'p':'l':'e':n:"#" <- nameBase name + -- This relies on the Read Int instance. This is more permissive than what + -- we need, since there are valid Int strings (e.g., "-1") that do not have + -- corresponding Tuple# names (e.g., "Tuple-1#" is not a data type in + -- GHC.Types). As such, we depend on the assumption that the input string + -- does in fact come from GHC.Types, which we check above. + = readMaybe [n] +#endif + -- ...otherwise, fall back on unboxed tuple syntax. + | otherwise + = unboxedTupleDegree_maybe (nameBase name) + +-- | If the argument is a tuple type, return the components +splitTuple_maybe :: Type -> Maybe [Type] +splitTuple_maybe t = go [] t + where go args (t1 `AppT` t2) = go (t2:args) t1 + go args (t1 `SigT` _k) = go args t1 + go args (ConT con_name) + | Just degree <- tupleNameDegree_maybe con_name + , length args == degree + = Just args + go args (TupleT degree) + | length args == degree + = Just args + go _ _ = Nothing + +-- | The type variable binders in a @forall@. This is not used by the TH AST +-- itself, but this is used as an intermediate data type in 'FAForalls'. +data ForallTelescope + = ForallVis [TyVarBndrUnit] + -- ^ A visible @forall@ (e.g., @forall a -> {...}@). + -- These do not have any notion of specificity, so we use + -- '()' as a placeholder value in the 'TyVarBndr's. + | ForallInvis [TyVarBndrSpec] + -- ^ An invisible @forall@ (e.g., @forall a {b} c -> {...}@), + -- where each binder has a 'Specificity'. + deriving (Eq, Show, Data) + +-- | The list of arguments in a function 'Type'. +data FunArgs + = FANil + -- ^ No more arguments. + | FAForalls ForallTelescope FunArgs + -- ^ A series of @forall@ed type variables followed by a dot (if + -- 'ForallInvis') or an arrow (if 'ForallVis'). For example, + -- the type variables @a1 ... an@ in @forall a1 ... an. r@. + | FACxt Cxt FunArgs + -- ^ A series of constraint arguments followed by @=>@. For example, + -- the @(c1, ..., cn)@ in @(c1, ..., cn) => r@. + | FAAnon Type FunArgs + -- ^ An anonymous argument followed by an arrow. For example, the @a@ + -- in @a -> r@. + deriving (Eq, Show, Data) + +-- | A /visible/ function argument type (i.e., one that must be supplied +-- explicitly in the source code). This is in contrast to /invisible/ +-- arguments (e.g., the @c@ in @c => r@), which are instantiated without +-- the need for explicit user input. +data VisFunArg + = VisFADep TyVarBndrUnit + -- ^ A visible @forall@ (e.g., @forall a -> a@). + | VisFAAnon Type + -- ^ An anonymous argument followed by an arrow (e.g., @a -> r@). + deriving (Eq, Show, Data) + +-- | Filter the visible function arguments from a list of 'FunArgs'. +filterVisFunArgs :: FunArgs -> [VisFunArg] +filterVisFunArgs FANil = [] +filterVisFunArgs (FAForalls tele args) = + case tele of + ForallVis tvbs -> map VisFADep tvbs ++ args' + ForallInvis _ -> args' + where + args' = filterVisFunArgs args +filterVisFunArgs (FACxt _ args) = + filterVisFunArgs args +filterVisFunArgs (FAAnon t args) = + VisFAAnon t:filterVisFunArgs args + +-- | Reconstruct an arrow 'Type' from its argument and result types. +ravelType :: FunArgs -> Type -> Type +ravelType FANil res = res +-- We need a special case for FAForalls ForallInvis followed by FACxt so that we may +-- collapse them into a single ForallT when raveling. +-- See Note [Desugaring and sweetening ForallT] in L.H.T.Desugar.Core. +ravelType (FAForalls (ForallInvis tvbs) (FACxt p args)) res = + ForallT tvbs p (ravelType args res) +ravelType (FAForalls (ForallInvis tvbs) args) res = ForallT tvbs [] (ravelType args res) +ravelType (FAForalls (ForallVis _tvbs) _args) _res = +#if __GLASGOW_HASKELL__ >= 809 + ForallVisT _tvbs (ravelType _args _res) +#else + error "Visible dependent quantification supported only on GHC 8.10+" +#endif +ravelType (FACxt cxt args) res = ForallT [] cxt (ravelType args res) +ravelType (FAAnon t args) res = AppT (AppT ArrowT t) (ravelType args res) + +-- | Decompose a function 'Type' into its arguments (the 'FunArgs') and its +-- result type (the 'Type). +unravelType :: Type -> (FunArgs, Type) +unravelType (ForallT tvbs cxt ty) = + let (args, res) = unravelType ty in + (FAForalls (ForallInvis tvbs) (FACxt cxt args), res) +unravelType (AppT (AppT ArrowT t1) t2) = + let (args, res) = unravelType t2 in + (FAAnon t1 args, res) +#if __GLASGOW_HASKELL__ >= 809 +unravelType (ForallVisT tvbs ty) = + let (args, res) = unravelType ty in + (FAForalls (ForallVis tvbs) args, res) +#endif +unravelType t = (FANil, t) + +-- | Remove all of the explicit kind signatures from a 'Type'. +unSigType :: Type -> Type +unSigType (SigT t _) = t +unSigType (AppT f x) = AppT (unSigType f) (unSigType x) +unSigType (ForallT tvbs ctxt t) = + ForallT tvbs (map unSigPred ctxt) (unSigType t) +unSigType (InfixT t1 n t2) = InfixT (unSigType t1) n (unSigType t2) +unSigType (UInfixT t1 n t2) = UInfixT (unSigType t1) n (unSigType t2) +unSigType (ParensT t) = ParensT (unSigType t) +#if __GLASGOW_HASKELL__ >= 807 +unSigType (AppKindT t k) = AppKindT (unSigType t) (unSigType k) +unSigType (ImplicitParamT n t) = ImplicitParamT n (unSigType t) +#endif +unSigType t = t + +-- | Remove all of the explicit kind signatures from a 'Pred'. +unSigPred :: Pred -> Pred +unSigPred = unSigType + +-- | Decompose an applied type into its individual components. For example, this: +-- +-- @ +-- Proxy \@Type Char +-- @ +-- +-- would be unfolded to this: +-- +-- @ +-- ('ConT' ''Proxy, ['TyArg' ('ConT' ''Type), 'TANormal' ('ConT' ''Char)]) +-- @ +-- +-- This process forgets about infix application, so both of these types: +-- +-- @ +-- Int :++: Int +-- (:++:) Int Int +-- @ +-- +-- will be unfolded to this: +-- +-- @ +-- ('ConT' ''(:+:), ['TANormal' ('ConT' ''Int), 'TANormal' ('ConT' ''Int)]) +-- @ +-- +-- This function should only be used after all 'UInfixT' and 'PromotedUInfixT' +-- types have been resolved (e.g., via @th-abstraction@'s +-- @@ +-- function). +unfoldType :: Type -> (Type, [TypeArg]) +unfoldType = go [] + where + go :: [TypeArg] -> Type -> (Type, [TypeArg]) + go acc (ForallT _ _ ty) = go acc ty + go acc (AppT ty1 ty2) = go (TANormal ty2:acc) ty1 + go acc (SigT ty _) = go acc ty + go acc (ParensT ty) = go acc ty + go acc (InfixT ty1 n ty2) = go (TANormal ty1:TANormal ty2:acc) (ConT n) +#if __GLASGOW_HASKELL__ >= 807 + go acc (AppKindT ty ki) = go (TyArg ki:acc) ty +#endif +#if __GLASGOW_HASKELL__ >= 904 + go acc (PromotedInfixT ty1 n ty2) = go (TANormal ty1:TANormal ty2:acc) (PromotedT n) +#endif + go acc ty = (ty, acc) + +-- | An argument to a type, either a normal type ('TANormal') or a visible +-- kind application ('TyArg'). +-- +-- 'TypeArg' is useful when decomposing an application of a 'Type' to its +-- arguments (e.g., in 'unfoldType'). +data TypeArg + = TANormal Type + | TyArg Kind + deriving (Eq, Show, Data) + +-- | Apply one 'Type' to a list of arguments. +applyType :: Type -> [TypeArg] -> Type +applyType = foldl apply + where + apply :: Type -> TypeArg -> Type + apply f (TANormal x) = f `AppT` x + apply f (TyArg _x) = +#if __GLASGOW_HASKELL__ >= 807 + f `AppKindT` _x +#else + -- VKA isn't supported, so + -- conservatively drop the argument + f +#endif + +-- | Filter the normal type arguments from a list of 'TypeArg's. +filterTANormals :: [TypeArg] -> [Type] +filterTANormals = mapMaybe getTANormal + where + getTANormal :: TypeArg -> Maybe Type + getTANormal (TANormal t) = Just t + getTANormal (TyArg {}) = Nothing + +-- | Convert a 'TyVarBndrVis' to a 'TypeArg'. That is, convert a binder with a +-- 'BndrReq' visibility to a 'TANormal' and a binder with 'BndrInvis' +-- visibility to a 'TyArg'. +-- +-- If given a 'KindedTV', the resulting 'TypeArg' will omit the kind signature. +-- Use 'tyVarBndrVisToTypeArgWithSig' if you want to preserve the kind +-- signature. +tyVarBndrVisToTypeArg :: TyVarBndrVis -> TypeArg +tyVarBndrVisToTypeArg bndr = + case tvFlag bndr of + BndrReq -> TANormal bndr_ty + BndrInvis -> TyArg bndr_ty + where + bndr_ty = tvbToType bndr + +-- | Convert a 'TyVarBndrVis' to a 'TypeArg'. That is, convert a binder with a +-- 'BndrReq' visibility to a 'TANormal' and a binder with 'BndrInvis' +-- visibility to a 'TyArg'. +-- +-- If given a 'KindedTV', the resulting 'TypeArg' will preserve the kind +-- signature. Use 'tyVarBndrVisToTypeArg' if you want to omit the kind +-- signature. +tyVarBndrVisToTypeArgWithSig :: TyVarBndrVis -> TypeArg +tyVarBndrVisToTypeArgWithSig bndr = + case tvFlag bndr of + BndrReq -> TANormal bndr_ty + BndrInvis -> TyArg bndr_ty + where + bndr_ty = tvbToTypeWithSig bndr + +-- | Extract the underlying 'Type' or 'Kind' from a 'TypeArg'. This forgets +-- information about whether a type is a normal argument or not, so use with +-- caution. +probablyWrongUnTypeArg :: TypeArg -> Type +probablyWrongUnTypeArg (TANormal t) = t +probablyWrongUnTypeArg (TyArg k) = k + +------------------------------------------------------------------------------- +-- Matching standalone kind signatures with binders in type-level declarations +------------------------------------------------------------------------------- + +-- @'matchUpSAKWithDecl' decl_sak decl_bndrs@ produces @TyVarBndr' +-- 'ForAllTyFlag'@s for a declaration, using the original declaration's +-- standalone kind signature (@decl_sak@) and its user-written binders +-- (@decl_bndrs@) as a template. For this example: +-- +-- @ +-- type D :: forall j k. k -> j -> Type +-- data D \@j \@l (a :: l) b = ... +-- @ +-- +-- We would produce the following @'TyVarBndr' 'ForAllTyFlag'@s: +-- +-- @ +-- \@j \@l (a :: l) (b :: j) +-- @ +-- +-- From here, these @'TyVarBndr' 'ForAllTyFlag'@s can be converted into other +-- forms of 'TyVarBndr's: +-- +-- * They can be converted to 'TyVarBndrSpec's using 'tvbForAllTyFlagsToSpecs'. +-- +-- * They can be converted to 'TyVarBndrVis'es using 'tvbForAllTyFlagsToVis'. +-- +-- Note that: +-- +-- * This function has a precondition that the length of @decl_bndrs@ must +-- always be equal to the number of visible quantifiers (i.e., the number of +-- function arrows plus the number of visible @forall@–bound variables) in +-- @decl_sak@. +-- +-- * Whenever possible, this function reuses type variable names from the +-- declaration's user-written binders. This is why the @'TyVarBndr' +-- 'ForAllTyFlag'@ use @\@j \@l@ instead of @\@j \@k@, since the @(a :: l)@ +-- binder uses @l@ instead of @k@. We could have just as well chose the other +-- way around, but we chose to pick variable names from the user-written +-- binders since they scope over other parts of the declaration. (For example, +-- the user-written binders of a @data@ declaration scope over the type +-- variables mentioned in a @deriving@ clause.) As such, keeping these names +-- avoids having to perform some alpha-renaming. +-- +-- This function's implementation was heavily inspired by parts of GHC's +-- kcCheckDeclHeader_sig function: +-- https://gitlab.haskell.org/ghc/ghc/-/blob/1464a2a8de082f66ae250d63ab9d94dbe2ef8620/compiler/GHC/Tc/Gen/HsType.hs#L2524-2643 +matchUpSAKWithDecl :: + forall q. + Fail.MonadFail q + => Kind + -- ^ The declaration's standalone kind signature + -> [TyVarBndrVis] + -- ^ The user-written binders in the declaration + -> q [TyVarBndr_ ForAllTyFlag] +matchUpSAKWithDecl decl_sak decl_bndrs = do + -- (1) First, explicitly quantify any free kind variables in `decl_sak` using + -- an invisible @forall@. This is done to ensure that precondition (2) in + -- `matchUpSigWithDecl` is upheld. (See the Haddocks for that function). + let decl_sak_free_tvbs = + changeTVFlags SpecifiedSpec $ freeVariablesWellScoped [decl_sak] + decl_sak' = ForallT decl_sak_free_tvbs [] decl_sak + + -- (2) Next, compute type variable binders using `matchUpSigWithDecl`. Note + -- that these can be biased towards type variable names mention in `decl_sak` + -- over names mentioned in `decl_bndrs`, but we will fix that up in the next + -- step. + let (decl_sak_args, _) = unravelType decl_sak' + sing_sak_tvbs <- matchUpSigWithDecl decl_sak_args decl_bndrs + + -- (3) Finally, swizzle the type variable names so that names in `decl_bndrs` + -- are preferred over names in `decl_sak`. + -- + -- This is heavily inspired by similar code in GHC: + -- https://gitlab.haskell.org/ghc/ghc/-/blob/cec903899234bf9e25ea404477ba846ac1e963bb/compiler/GHC/Tc/Gen/HsType.hs#L2607-2616 + let invis_decl_sak_args = filterInvisTvbArgs decl_sak_args + invis_decl_sak_arg_nms = map tvName invis_decl_sak_args + + invis_decl_bndrs = freeKindVariablesWellScoped decl_bndrs + invis_decl_bndr_nms = map tvName invis_decl_bndrs + + swizzle_env = + Map.fromList $ zip invis_decl_sak_arg_nms invis_decl_bndr_nms + (_, swizzled_sing_sak_tvbs) = + List.mapAccumL (swizzleTvb swizzle_env) Map.empty sing_sak_tvbs + pure swizzled_sing_sak_tvbs + +-- Match the quantifiers in a type-level declaration's standalone kind signature +-- with the user-written binders in the declaration. This function assumes the +-- following preconditions: +-- +-- 1. The number of required binders in the declaration's user-written binders +-- is equal to the number of visible quantifiers (i.e., the number of +-- function arrows plus the number of visible @forall@–bound variables) in +-- the standalone kind signature. +-- +-- 2. The number of invisible \@-binders in the declaration's user-written +-- binders is less than or equal to the number of invisible quantifiers +-- (i.e., the number of invisible @forall@–bound variables) in the +-- standalone kind signature. +-- +-- The implementation of this function is heavily based on a GHC function of +-- the same name: +-- https://gitlab.haskell.org/ghc/ghc/-/blob/1464a2a8de082f66ae250d63ab9d94dbe2ef8620/compiler/GHC/Tc/Gen/HsType.hs#L2645-2715 +matchUpSigWithDecl :: + forall q. + Fail.MonadFail q + => FunArgs + -- ^ The quantifiers in the declaration's standalone kind signature + -> [TyVarBndrVis] + -- ^ The user-written binders in the declaration + -> q [TyVarBndr_ ForAllTyFlag] +matchUpSigWithDecl = go_fun_args Map.empty + where + go_fun_args :: + Map Name Type + -- ^ A substitution from the names of @forall@-bound variables in the + -- standalone kind signature to corresponding binder names in the + -- user-written binders. This is because we want to reuse type variable + -- names from the user-written binders whenever possible. For example: + -- + -- @ + -- type T :: forall a. forall b -> Maybe (a, b) -> Type + -- data T @x y z + -- @ + -- + -- After matching up the @a@ in @forall a.@ with @x@ and + -- the @b@ in @forall b ->@ with @y@, this substitution will be + -- extended with @[a :-> x, b :-> y]@. This ensures that we will + -- produce @Maybe (x, y)@ instead of @Maybe (a, b)@ in + -- the kind for @z@. + -> FunArgs -> [TyVarBndrVis] -> q [TyVarBndr_ ForAllTyFlag] + go_fun_args _ FANil [] = + pure [] + -- This should not happen, per precondition (1). + go_fun_args _ FANil decl_bndrs = + fail $ "matchUpSigWithDecl.go_fun_args: Too many binders: " ++ show decl_bndrs + -- GHC now disallows kind-level constraints, per this GHC proposal: + -- https://github.com/ghc-proposals/ghc-proposals/blob/b0687d96ce8007294173b7f628042ac4260cc738/proposals/0547-no-kind-equalities.rst + -- As such, we reject non-empty kind contexts. Empty contexts (which are + -- benign) can sometimes arise due to @ForallT@, so we add a special case + -- to allow them. + go_fun_args subst (FACxt [] args) decl_bndrs = + go_fun_args subst args decl_bndrs + go_fun_args _ (FACxt (_:_) _) _ = + fail "matchUpSigWithDecl.go_fun_args: Unexpected kind-level constraint" + go_fun_args subst (FAForalls (ForallInvis tvbs) sig_args) decl_bndrs = + go_invis_tvbs subst tvbs sig_args decl_bndrs + go_fun_args subst (FAForalls (ForallVis tvbs) sig_args) decl_bndrs = + go_vis_tvbs subst tvbs sig_args decl_bndrs + go_fun_args subst (FAAnon anon sig_args) (decl_bndr:decl_bndrs) = + case tvFlag decl_bndr of + -- If the next decl_bndr is required, then we must match its kind (if + -- one is provided) against the anonymous kind argument. + BndrReq -> do + let decl_bndr_name = tvName decl_bndr + mb_decl_bndr_kind = extractTvbKind_maybe decl_bndr + anon' = applySubstitution subst anon + + anon'' = + case mb_decl_bndr_kind of + Nothing -> anon' + Just decl_bndr_kind -> do + let mb_match_subst = matchTy decl_bndr_kind anon' + maybe decl_bndr_kind (`applySubstitution` decl_bndr_kind) mb_match_subst + sig_args' <- go_fun_args subst sig_args decl_bndrs + pure $ kindedTVFlag decl_bndr_name Required anon'' : sig_args' + -- We have a visible, anonymous argument in the kind, but an invisible + -- @-binder as the next decl_bndr. This is ill kinded, so throw an + -- error. + -- + -- This should not happen, per precondition (2). + BndrInvis -> + fail $ "dMatchUpSigWithDecl.go_fun_args: Expected visible binder, encountered invisible binder: " + ++ show decl_bndr + -- This should not happen, per precondition (1). + go_fun_args _ _ [] = + fail "matchUpSigWithDecl.go_fun_args: Too few binders" + + go_invis_tvbs :: + Map Name Type + -> [TyVarBndrSpec] + -> FunArgs + -> [TyVarBndrVis] + -> q [TyVarBndr_ ForAllTyFlag] + go_invis_tvbs subst [] sig_args decl_bndrs = + go_fun_args subst sig_args decl_bndrs + go_invis_tvbs subst (invis_tvb:invis_tvbs) sig_args decl_bndrss = + case decl_bndrss of + [] -> skip_invis_bndr + decl_bndr:decl_bndrs -> + case tvFlag decl_bndr of + BndrReq -> skip_invis_bndr + -- If the next decl_bndr is an invisible @-binder, then we must match it + -- against the invisible forall–bound variable in the kind. + BndrInvis -> do + let (subst', sig_tvb) = match_tvbs subst invis_tvb decl_bndr + sig_args' <- go_invis_tvbs subst' invis_tvbs sig_args decl_bndrs + pure (mapTVFlag Invisible sig_tvb : sig_args') + where + -- There is an invisible forall in the kind without a corresponding + -- invisible @-binder, which is allowed. In this case, we simply apply + -- the substitution and recurse. + skip_invis_bndr :: q [TyVarBndr_ ForAllTyFlag] + skip_invis_bndr = do + let (subst', invis_tvb') = substTvb subst invis_tvb + sig_args' <- go_invis_tvbs subst' invis_tvbs sig_args decl_bndrss + pure $ mapTVFlag Invisible invis_tvb' : sig_args' + + go_vis_tvbs :: + Map Name Type + -> [TyVarBndrUnit] + -> FunArgs + -> [TyVarBndrVis] + -> q [TyVarBndr_ ForAllTyFlag] + go_vis_tvbs subst [] sig_args decl_bndrs = + go_fun_args subst sig_args decl_bndrs + -- This should not happen, per precondition (1). + go_vis_tvbs _ (_:_) _ [] = + fail "matchUpSigWithDecl.go_vis_tvbs: Too few binders" + go_vis_tvbs subst (vis_tvb:vis_tvbs) sig_args (decl_bndr:decl_bndrs) = do + case tvFlag decl_bndr of + -- If the next decl_bndr is required, then we must match it against the + -- visible forall–bound variable in the kind. + BndrReq -> do + let (subst', sig_tvb) = match_tvbs subst vis_tvb decl_bndr + sig_args' <- go_vis_tvbs subst' vis_tvbs sig_args decl_bndrs + pure (mapTVFlag (const Required) sig_tvb : sig_args') + -- We have a visible forall in the kind, but an invisible @-binder as + -- the next decl_bndr. This is ill kinded, so throw an error. + -- + -- This should not happen, per precondition (2). + BndrInvis -> + fail $ "matchUpSigWithDecl.go_vis_tvbs: Expected visible binder, encountered invisible binder: " + ++ show decl_bndr + + -- @match_tvbs subst sig_tvb decl_bndr@ will match the kind of @decl_bndr@ + -- against the kind of @sig_tvb@ to produce a new kind. This function + -- produces two values as output: + -- + -- 1. A new @subst@ that has been extended such that the name of @sig_tvb@ + -- maps to the name of @decl_bndr@. (See the Haddocks for the @Map Name + -- Type@ argument to @go_fun_args@ for an explanation of why we do this.) + -- + -- 2. A 'TyVarBndrSpec' that has the name of @decl_bndr@, but with the new + -- kind resulting from matching. + match_tvbs :: + Map Name Type + -> TyVarBndr_ flag + -> TyVarBndrVis + -> (Map Name Type, TyVarBndr_ flag) + match_tvbs subst sig_tvb decl_bndr = + let decl_bndr_name = tvName decl_bndr + mb_decl_bndr_kind = extractTvbKind_maybe decl_bndr + + sig_tvb_name = tvName sig_tvb + sig_tvb_flag = tvFlag sig_tvb + mb_sig_tvb_kind = applySubstitution subst <$> extractTvbKind_maybe sig_tvb + + mb_kind :: Maybe Kind + mb_kind = + case (mb_decl_bndr_kind, mb_sig_tvb_kind) of + (Nothing, Nothing) -> Nothing + (Just decl_bndr_kind, Nothing) -> Just decl_bndr_kind + (Nothing, Just sig_tvb_kind) -> Just sig_tvb_kind + (Just decl_bndr_kind, Just sig_tvb_kind) -> do + match_subst <- matchTy decl_bndr_kind sig_tvb_kind + Just $ applySubstitution match_subst decl_bndr_kind + + subst' = Map.insert sig_tvb_name (VarT decl_bndr_name) subst + sig_tvb' = case mb_kind of + Nothing -> plainTVFlag decl_bndr_name sig_tvb_flag + Just kind -> kindedTVFlag decl_bndr_name sig_tvb_flag kind in + + (subst', sig_tvb') + +-- Collect the invisible type variable binders from a sequence of FunArgs. +filterInvisTvbArgs :: FunArgs -> [TyVarBndrSpec] +filterInvisTvbArgs FANil = [] +filterInvisTvbArgs (FACxt _ args) = filterInvisTvbArgs args +filterInvisTvbArgs (FAAnon _ args) = filterInvisTvbArgs args +filterInvisTvbArgs (FAForalls tele args) = + let res = filterInvisTvbArgs args in + case tele of + ForallVis _ -> res + ForallInvis tvbs' -> tvbs' ++ res + +-- | Take a telescope of 'TyVarBndr's, find the free variables in their kinds, +-- and sort them in reverse topological order to ensure that they are well +-- scoped. Because the argument list is assumed to be telescoping, kind +-- variables that are bound earlier in the list are not returned. For example, +-- this: +-- +-- @ +-- 'freeKindVariablesWellScoped' [a :: k, b :: Proxy a] +-- @ +-- +-- Will return @[k]@, not @[k, a]@, since @a@ is bound earlier by @a :: k@. +freeKindVariablesWellScoped :: [TyVarBndr_ flag] -> [TyVarBndrUnit] +freeKindVariablesWellScoped tvbs = + foldr (\tvb kvs -> + foldMap (\t -> freeVariablesWellScoped [t]) (extractTvbKind_maybe tvb) `List.union` + List.deleteBy ((==) `on` tvName) tvb kvs) + [] + (changeTVFlags () tvbs) + +-- | @'matchTy' tmpl targ@ matches a type template @tmpl@ against a type target +-- @targ@. This returns a Map from names of type variables in the type template +-- to types if the types indeed match up, or @Nothing@ otherwise. In the @Just@ +-- case, it is guaranteed that every type variable mentioned in the template is +-- mapped by the returned substitution. +-- +-- Note that this function will always return @Nothing@ if the template contains +-- an explicit kind signature or visible kind application. +-- +-- This is heavily inspired by the function of the same name in +-- "Language.Haskell.TH.Desugar.Subst", which works over 'DType's instead of +-- 'Type's. +matchTy :: Type -> Type -> Maybe (Map Name Type) +matchTy (VarT var_name) arg = Just $ Map.singleton var_name arg +matchTy (SigT {}) _ = Nothing +matchTy pat (SigT ty _ki) = matchTy pat ty +#if __GLASGOW_HASKELL__ >= 807 +matchTy (AppKindT {}) _ = Nothing +matchTy pat (AppKindT ty _ki) = matchTy pat ty +#endif +matchTy (ForallT {}) _ = + error "Cannot match a forall in a pattern" +matchTy _ (ForallT {}) = + error "Cannot match a forall in a target" +matchTy (AppT pat1 pat2) (AppT arg1 arg2) = + unionMaybeSubsts [matchTy pat1 arg1, matchTy pat2 arg2] +matchTy (ConT pat_con) (ConT arg_con) + | pat_con == arg_con + = Just Map.empty + | otherwise + = Nothing +matchTy ArrowT ArrowT = Just Map.empty +matchTy (LitT pat_lit) (LitT arg_lit) + | pat_lit == arg_lit + = Just Map.empty + | otherwise + = Nothing +matchTy _ _ = Nothing + +-- | This is inspired by the function of the same name in +-- "Language.Haskell.TH.Desugar.Subst". +unionMaybeSubsts :: [Maybe (Map Name Type)] -> Maybe (Map Name Type) +unionMaybeSubsts = List.foldl' union_subst1 (Just Map.empty) + where + union_subst1 :: + Maybe (Map Name Type) -> Maybe (Map Name Type) -> Maybe (Map Name Type) + union_subst1 ma mb = do + a <- ma + b <- mb + unionSubsts a b + +-- | Computes the union of two substitutions. Fails if both subsitutions map +-- the same variable to different types. +-- +-- This is inspired by the function of the same name in +-- "Language.Haskell.TH.Desugar.Subst". +unionSubsts :: Map Name Type -> Map Name Type -> Maybe (Map Name Type) +unionSubsts a b = + let shared_key_set = Map.keysSet a `Set.intersection` Map.keysSet b + matches_up = Set.foldr (\name -> ((a Map.! name) == (b Map.! name) &&)) + True shared_key_set + in + if matches_up then return (a `Map.union` b) else Nothing + +-- | This is inspired by the function of the same name in +-- "Language.Haskell.TH.Desugar.Subst.Capturing". +substTvb :: Map Name Kind -> TyVarBndr_ flag -> (Map Name Kind, TyVarBndr_ flag) +substTvb s tvb = (Map.delete (tvName tvb) s, mapTVKind (applySubstitution s) tvb) + +-- This is heavily inspired by the `swizzleTcb` function in GHC: +-- https://gitlab.haskell.org/ghc/ghc/-/blob/cec903899234bf9e25ea404477ba846ac1e963bb/compiler/GHC/Tc/Gen/HsType.hs#L2741-2755 +swizzleTvb :: + Map Name Name + -- ^ A \"swizzle environment\" (i.e., a map from binder names in a + -- standalone kind signature to binder names in the corresponding + -- type-level declaration). + -> Map Name Type + -- ^ Like the swizzle environment, but as a full-blown substitution. + -> TyVarBndr_ flag + -> (Map Name Type, TyVarBndr_ flag) +swizzleTvb swizzle_env subst tvb = + (subst', tvb2) + where + subst' = Map.insert tvb_name (VarT (tvName tvb2)) subst + tvb_name = tvName tvb + tvb1 = mapTVKind (applySubstitution subst) tvb + tvb2 = + case Map.lookup tvb_name swizzle_env of + Just user_name -> mapTVName (const user_name) tvb1 + Nothing -> tvb1 + +-- The visibility of a binder in a type-level declaration. This generalizes +-- 'Specificity' (which lacks an equivalent to 'Required') and 'BndrVis' (which +-- lacks an equivalent to @'Invisible' 'Inferred'@). +-- +-- This is heavily inspired by a data type of the same name in GHC: +-- https://gitlab.haskell.org/ghc/ghc/-/blob/98597ad5fca81544d74f721fb508295fd2650232/compiler/GHC/Types/Var.hs#L458-465 +data ForAllTyFlag + = Invisible !Specificity + -- ^ If the 'Specificity' value is 'SpecifiedSpec', then the binder is + -- permitted by request (e.g., @\@a@). If the 'Specificity' value is + -- 'InferredSpec', then the binder is prohibited from appearing in source + -- Haskell (e.g., @\@{a}@). + | Required + -- ^ The binder is required to appear in source Haskell (e.g., @a@). + deriving (Show, Eq, Ord, Data, Generic, Lift) + +instance DefaultBndrFlag ForAllTyFlag where + defaultBndrFlag = Required + +#if __GLASGOW_HASKELL__ >= 900 +instance PprFlag ForAllTyFlag where + pprTyVarBndr (PlainTV nm vis) = + pprForAllTyFlag vis (ppr nm) + pprTyVarBndr (KindedTV nm vis k) = + pprForAllTyFlag vis (Ppr.parens (ppr nm Ppr.<+> Ppr.dcolon Ppr.<+> ppr k)) + +pprForAllTyFlag :: ForAllTyFlag -> Ppr.Doc -> Ppr.Doc +pprForAllTyFlag (Invisible SpecifiedSpec) d = Ppr.char '@' Ppr.<> d +pprForAllTyFlag (Invisible InferredSpec) d = Ppr.braces d +pprForAllTyFlag Required d = d +#endif + +-- | Convert a list of @'TyVarBndr' 'ForAllTyFlag'@s to a list of +-- 'TyVarBndrSpec's, which is suitable for use in an invisible @forall@. +-- Specifically: +-- +-- * Variable binders that use @'Invisible' spec@ are converted to @spec@. +-- +-- * Variable binders that are 'Required' are converted to 'SpecifiedSpec', +-- as all of the 'TyVarBndrSpec's are invisible. As an example of how this +-- is used, consider what would happen when singling this data type: +-- +-- @ +-- type T :: forall k -> k -> Type +-- data T k (a :: k) where ... +-- @ +-- +-- Here, the @k@ binder is 'Required'. When we produce the standalone kind +-- signature for the singled data type, we use 'tvbForAllTyFlagsToSpecs' to +-- produce the type variable binders in the outermost @forall@: +-- +-- @ +-- type ST :: forall k (a :: k). T k a -> Type +-- data ST z where ... +-- @ +-- +-- Note that the @k@ is bound visibily (i.e., using 'SpecifiedSpec') in the +-- outermost, invisible @forall@. +tvbForAllTyFlagsToSpecs :: [TyVarBndr_ ForAllTyFlag] -> [TyVarBndrSpec] +tvbForAllTyFlagsToSpecs = map (mapTVFlag to_spec) + where + to_spec :: ForAllTyFlag -> Specificity + to_spec (Invisible spec) = spec + to_spec Required = SpecifiedSpec + +-- | Convert a list of @'TyVarBndr' 'ForAllTyFlag'@s to a list of +-- 'TyVarBndrVis'es, which is suitable for use in a type-level declaration +-- (e.g., the @var_1 ... var_n@ in @class C var_1 ... var_n@). Specifically: +-- +-- * Variable binders that use @'Invisible' 'InferredSpec'@ are dropped +-- entirely. Such binders cannot be represented in source Haskell. +-- +-- * Variable binders that use @'Invisible' 'SpecifiedSpec'@ are converted to +-- 'BndrInvis'. +-- +-- * Variable binders that are 'Required' are converted to 'BndrReq'. +tvbForAllTyFlagsToBndrVis :: [TyVarBndr_ ForAllTyFlag] -> [TyVarBndrVis] +tvbForAllTyFlagsToBndrVis = catMaybes . map (traverseTVFlag to_spec_maybe) + where + to_spec_maybe :: ForAllTyFlag -> Maybe BndrVis + to_spec_maybe (Invisible InferredSpec) = Nothing + to_spec_maybe (Invisible SpecifiedSpec) = Just bndrInvis + to_spec_maybe Required = Just BndrReq + +---------------------------------------- +-- Free names, etc. +---------------------------------------- + +-- | Check if a name occurs anywhere within a TH tree. +nameOccursIn :: Data a => Name -> a -> Bool +nameOccursIn n = everything (||) $ mkQ False (== n) + +-- | Extract all Names mentioned in a TH tree. +allNamesIn :: Data a => a -> [Name] +allNamesIn = everything (++) $ mkQ [] (:[]) + +-- | Extract the names bound in a @Stmt@. +-- +-- This does /not/ extract any type variables bound by pattern signatures, +-- constructor patterns, or type patterns. +extractBoundNamesStmt :: Stmt -> OSet Name +extractBoundNamesStmt (BindS pat _) = extractBoundNamesPat pat +extractBoundNamesStmt (LetS decs) = foldMap extractBoundNamesDec decs +extractBoundNamesStmt (NoBindS _) = OS.empty +extractBoundNamesStmt (ParS stmtss) = foldMap (foldMap extractBoundNamesStmt) stmtss +#if __GLASGOW_HASKELL__ >= 807 +extractBoundNamesStmt (RecS stmtss) = foldMap extractBoundNamesStmt stmtss +#endif + +-- | Extract the names bound in a @Dec@ that could appear in a @let@ expression. +-- +-- This does /not/ extract any type variables bound by pattern signatures, +-- constructor patterns, or type patterns. +extractBoundNamesDec :: Dec -> OSet Name +extractBoundNamesDec (FunD name _) = OS.singleton name +extractBoundNamesDec (ValD pat _ _) = extractBoundNamesPat pat +extractBoundNamesDec _ = OS.empty + +-- | Extract the names bound in a @Pat@. +-- +-- This does /not/ extract any type variables bound by pattern signatures, +-- constructor patterns, or type patterns. +extractBoundNamesPat :: Pat -> OSet Name +extractBoundNamesPat (LitP _) = OS.empty +extractBoundNamesPat (VarP name) = OS.singleton name +extractBoundNamesPat (TupP pats) = foldMap extractBoundNamesPat pats +extractBoundNamesPat (UnboxedTupP pats) = foldMap extractBoundNamesPat pats +extractBoundNamesPat (ConP _ +#if __GLASGOW_HASKELL__ >= 901 + _ +#endif + pats) = foldMap extractBoundNamesPat pats +extractBoundNamesPat (InfixP p1 _ p2) = extractBoundNamesPat p1 `OS.union` + extractBoundNamesPat p2 +extractBoundNamesPat (UInfixP p1 _ p2) = extractBoundNamesPat p1 `OS.union` + extractBoundNamesPat p2 +extractBoundNamesPat (ParensP pat) = extractBoundNamesPat pat +extractBoundNamesPat (TildeP pat) = extractBoundNamesPat pat +extractBoundNamesPat (BangP pat) = extractBoundNamesPat pat +extractBoundNamesPat (AsP name pat) = OS.singleton name `OS.union` + extractBoundNamesPat pat +extractBoundNamesPat WildP = OS.empty +extractBoundNamesPat (RecP _ field_pats) = let (_, pats) = unzip field_pats in + foldMap extractBoundNamesPat pats +extractBoundNamesPat (ListP pats) = foldMap extractBoundNamesPat pats +extractBoundNamesPat (SigP pat _) = extractBoundNamesPat pat +extractBoundNamesPat (ViewP _ pat) = extractBoundNamesPat pat +#if __GLASGOW_HASKELL__ >= 801 +extractBoundNamesPat (UnboxedSumP pat _ _) = extractBoundNamesPat pat +#endif +#if __GLASGOW_HASKELL__ >= 909 +extractBoundNamesPat (TypeP _) = OS.empty +extractBoundNamesPat (InvisP _) = OS.empty +#endif +#if __GLASGOW_HASKELL__ >= 911 +extractBoundNamesPat (OrP pats) = foldMap extractBoundNamesPat pats +#endif + +---------------------------------------- +-- General utility +---------------------------------------- + +-- dirty implementation of explicit-to-implicit conversion +newtype MagicIP name a r = MagicIP (IP name a => r) + +-- | Get an implicit param constraint (@IP name a@, which is the desugared +-- form of @(?name :: a)@) from an explicit value. +-- +-- This function is only available with GHC 8.0 or later. +bindIP :: forall name a r. a -> (IP name a => r) -> r +bindIP val k = (unsafeCoerce (MagicIP @name k) :: a -> r) val + +-- like GHC's +splitAtList :: [a] -> [b] -> ([b], [b]) +splitAtList [] x = ([], x) +splitAtList (_ : t) (x : xs) = + let (as, bs) = splitAtList t xs in + (x : as, bs) +splitAtList (_ : _) [] = ([], []) + +thdOf3 :: (a,b,c) -> c +thdOf3 (_,_,c) = c + +liftFst :: (a -> b) -> (a, c) -> (b, c) +liftFst f (a,c) = (f a, c) + +liftSnd :: (a -> b) -> (c, a) -> (c, b) +liftSnd f (c,a) = (c, f a) + +thirdOf3 :: (a -> b) -> (c, d, a) -> (c, d, b) +thirdOf3 f (c, d, a) = (c, d, f a) + +-- lift concatMap into a monad +-- could this be more efficient? +-- | Concatenate the result of a @mapM@ +concatMapM :: (Monad monad, Monoid monoid, Traversable t) + => (a -> monad monoid) -> t a -> monad monoid +concatMapM fn list = do + bss <- mapM fn list + return $ fold bss + +-- like GHC's +-- | Monadic version of mapAccumL +mapAccumLM :: Monad m + => (acc -> x -> m (acc, y)) -- ^ combining function + -> acc -- ^ initial state + -> [x] -- ^ inputs + -> m (acc, [y]) -- ^ final state, outputs +mapAccumLM _ s [] = return (s, []) +mapAccumLM f s (x:xs) = do + (s1, x') <- f s x + (s2, xs') <- mapAccumLM f s1 xs + return (s2, x' : xs') + +-- like GHC's +mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b] +mapMaybeM _ [] = return [] +mapMaybeM f (x:xs) = do + y <- f x + ys <- mapMaybeM f xs + return $ case y of + Nothing -> ys + Just z -> z : ys + +expectJustM :: Fail.MonadFail m => String -> Maybe a -> m a +expectJustM _ (Just x) = return x +expectJustM err Nothing = Fail.fail err + +firstMatch :: (a -> Maybe b) -> [a] -> Maybe b +firstMatch f xs = listToMaybe $ mapMaybe f xs + +firstMatchM :: Monad m => (a -> m (Maybe b)) -> [a] -> m (Maybe b) +firstMatchM f xs = listToMaybe <$> mapMaybeM f xs + +-- | Semi-shallow version of 'everywhereM' - does not recurse into children of nodes of type @a@ (only applies the handler to them). +-- +-- >>> topEverywhereM (pure . fmap (*10) :: [Integer] -> Identity [Integer]) ([1,2,3] :: [Integer], "foo" :: String) +-- Identity ([10,20,30],"foo") +-- +-- >>> everywhereM (mkM (pure . fmap (*10) :: [Integer] -> Identity [Integer])) ([1,2,3] :: [Integer], "foo" :: String) +-- Identity ([10,200,3000],"foo") +topEverywhereM :: (Typeable a, Data b, Monad m) => (a -> m a) -> b -> m b +topEverywhereM handler = + gmapM (topEverywhereM handler) `extM` handler + +-- Checks if a String names a valid Haskell infix data constructor +-- (i.e., does it begin with a colon?). +isInfixDataCon :: String -> Bool +isInfixDataCon (':':_) = True +isInfixDataCon _ = False + +-- | Returns 'True' if the argument 'Name' is that of 'Kind.Type' +-- (or @*@ or 'Kind.★', to support older GHCs). +isTypeKindName :: Name -> Bool +isTypeKindName n = n == typeKindName +#if __GLASGOW_HASKELL__ < 805 + || n == starKindName + || n == uniStarKindName +#endif + +-- | The 'Name' of the kind 'Kind.Type'. +-- 2. The kind @*@ on older GHCs. +typeKindName :: Name +typeKindName = ''Kind.Type + +#if __GLASGOW_HASKELL__ < 805 +-- | The 'Name' of the kind @*@. +starKindName :: Name +starKindName = ''(Kind.*) + +-- | The 'Name' of the kind 'Kind.★'. +uniStarKindName :: Name +uniStarKindName = ''(Kind.★) +#endif + +-- | Is a data type or data instance declaration a @newtype@ declaration, a +-- @data@ declaration, or a @type data@ declaration? +data DataFlavor + = Newtype -- ^ @newtype@ + | Data -- ^ @data@ + | TypeData -- ^ @type data@ + deriving (Eq, Show, Data, Generic, Lift) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,7 +1,8 @@ `th-desugar` Package ==================== -[![Build Status](https://travis-ci.org/goldfirere/th-desugar.png?branch=master)](https://travis-ci.org/goldfirere/th-desugar) +[![Hackage](https://img.shields.io/hackage/v/th-desugar.svg)](http://hackage.haskell.org/package/th-desugar) +[![Build Status](https://github.com/goldfirere/th-desugar/workflows/Haskell-CI/badge.svg)](https://github.com/goldfirere/th-desugar/actions?query=workflow%3AHaskell-CI) This package provides the `Language.Haskell.TH.Desugar` module, which desugars Template Haskell's rich encoding of Haskell syntax into a simpler encoding. @@ -22,3 +23,389 @@ possible. I will try to keep this package up-to-date with respect to changes in GHC. +The minimum supported version of GHC is 8.0, which was chosen to avoid various +Template Haskell bugs in older GHC versions that affect how this library +desugars code. If this choice negatively impacts you, please submit a bug +report. + +Known limitations +----------------- + +## Desugaring depends on language extensions of use sites + +Suppose you quote some Template Haskell declarations in module `A`: + +```hs +{-# LANGUAGE ... #-} +module A where + +decs :: Q [Dec] +decs = [d| ... |] +``` + +And later desugar the declarations with `th-desugar` in module `B`: + +```hs +{-# LANGUAGE ... #-} +module B where + +import A (decs) +import Language.Haskell.TH.Desugar (dsDecs) + +$(do desugaredDecs <- dsDecs decs + ...) +``` + +There are some situations where `th-desugar`'s desugaring depends on which +language extensions are enabled, such as: + +* `MonadFailDesugaring` (for desugaring partial pattern matches in `do` + notation) +* `NoFieldSelectors` (for determining if a record field can be reified as a + field selector with `lookupValueNameWithLocals`) + +Somewhat counterintuitively, `th-desugar` will consult the language extensions +in module `B` (the site where the `decs` are used) for this process, not module +`A` (where the `decs` were defined). This is really a Template Haskell +limitation, since Template Haskell does not offer any way to reify which +language extensions were enabled at the time the declarations were defined. As a +result, `th-desugar` can only check for language extensions at use sites. + +## Limited support for kind inference + +`th-desugar` sometimes has to construct types for certain Haskell entities. +For instance, `th-desugar` desugars all Haskell98-style constructors to use +GADT syntax, so the following: + +```haskell +data T (a :: k) = MkT (Proxy a) +``` + +Will be desugared to something like this: + +```haskell +data T (a :: k) where + MkT :: forall k (a :: k). Proxy a -> T (a :: k) +``` + +Notice that `k` is explicitly quantified in the type of `MkT`. This is due to +an additional pass that `th-desugar` performs over the type variable binders +of `T` to extract all implicitly quantified variables and make them explicit. +This makes the desugared types forwards-compatible with a +[future version of GHC](https://github.com/goldfirere/ghc-proposals/blob/bbefbee6fc0cddb10bbacc85f79e66c2706ce13f/proposals/0000-no-kind-vars.rst) +that requires all kind variables in a top-level `forall` to be explicitly +quantified. + +This process of extracting all implicitly quantified kind variables is not +perfect, however. There are some obscure programs that will cause `th-desugar` +to produce type variable binders that are ill scoped. Here is one example: + +```haskell +data P k (a :: k) +data Foo (a :: Proxy j) (b :: k) c = MkFoo c (P k j) +``` + +If you squint hard at `MkFoo`, you'll notice that `j :: k`. However, this +relationship is not expressed _syntactically_, which means that `th-desugar` +will not be aware of it. Therefore, `th-desugar` will desugar `Foo` to: + +```haskell +data Foo (a :: Proxy j) (b :: k) c where + MkFoo :: forall j k (a :: Proxy j) (b :: k) c. + c -> P k j -> Foo (a :: Proxy j) (b :: k) c +``` + +This is incorrect since `k` must come before `j` in order to be well scoped. +There is a workaround to this issue, however: add more explicit kind +information. If you had instead written this: + +```haskell +data Foo (a :: Proxy (j :: k)) (b :: k) c = MkFoo c (P k j) +``` + +Then the fact that `j :: k` is expressed directly in the AST, so `th-desugar` +is able to pick up on it and pick `forall k j (a :: Proxy j) (b :: k) c. <...>` +as the telescope for the type of `MkFoo`. + +The following constructs are known to be susceptible to this issue: + +1. Desugared Haskell98-style constructors +2. Locally reified class methods +3. Locally reified record selectors +4. Locally reified data constructors +5. Locally reified type family instances (on GHC 8.8 and later, in which the + Template Haskell AST supports explicit `foralls` in type family equations) + +## Limited support for linear types + +Currently, the `th-desugar` AST deliberately makes it impossible to represent +linear types, and desugaring a linear function arrow will simply turn into a +normal function arrow `(->)`. This choice is partly motivated by issues in the +way that linear types interact with Template Haskell, which sometimes make it +impossible to tell whether a reified function type is linear or not. See, for +instance, [GHC#18378](https://gitlab.haskell.org/ghc/ghc/-/issues/18378). + +## Limitations of support for desugaring guards + +`th-desugar` supports guards in the sense that it will desugar guards to +equivalent code that instead uses `case` expressions. For example, this code: + +```hs +f (x, y) + | x == "hello" = x + | otherwise = y +``` + +Will be desugared to this code: + +```hs +f arg = + case arg of + (x, y) -> + case x2 == "hello" of + True -> x + False -> y +``` + +This has the advantage that it saves users from needing to care about the +complexities of guards. It does have some drawbacks, however, which we describe +below. + +### Desugaring guards can result in quadratic code size + +If you desugar this program involving guards: + +```hs +data T = A Int | B Int | C Int + +f :: T -> T -> Maybe Int +f (A x1) (A x2) + | x1 == x2 + = Just x1 +f (B x1) (B x2) + | x1 == x2 + = Just x1 +f (C x1) (C x2) + | x1 == x2 + = Just x1 +f _ _ = Nothing +``` + +You will end up with: + +```hs +f :: T -> T -> Maybe Int +f arg1 arg2 = + case (# arg1, arg2 #) of + (# A x1, A x2 #) -> + case x1 == x2 of + True -> + Just x1 + False -> + case (# arg1, arg2 #) of + (# B y1, B y2 #) -> + case y1 == y2 of + True -> + Just y1 + False -> + case (# arg1, arg2 #) of + (# C z1, C z2 #) -> + case z1 == z2 of + True -> + Just z1 + False -> + case (# arg1, arg2 #) of + (# _, _ #) -> + Nothing + (# _, _ #) -> + Nothing + (# C y1, C y2 #) -> + case y1 == y2 of + True -> + Just y1 + False -> + case (# arg1, arg2 #) of + (# _, _ #) -> + Nothing + (# _, _ #) -> + Nothing + (# B x1, B x2 #) -> + case x1 == x2 of + True -> + Just x1 + False -> + case (# arg1, arg2 #) of + (# C y1, C y2 #) -> + case y1 == y2 of + True -> + Just y1 + False -> + case (# arg1, arg2 #) of + (# _, _ #) -> + Nothing + (# _, _ #) -> + Nothing + (# C x1, C x2 #) -> + case x1 == x2 of + True -> + Just x1 + False -> + case (# arg1, arg2 #) of + (# _, _ #) -> + Nothing + (# _, _ #) -> + Nothing +``` + +That is signficantly more code. In the worst case, the algorithm that +`th-desugar` uses for desugaring guards can lead to a quadratic increase in +code size. One way to avoid this is avoid having incomplete guards that fall +through to later clauses. That is, if you rewrite the original code to this: + +```hs +f :: T -> T -> Maybe Int +f (A x1) (A x2) + | x1 == x2 + = Just x1 + | otherwise + = Nothing +f (B x1) (B x2) + | x1 == x2 + = Just x1 + | otherwise + = Nothing +f (C x1) (C x2) + | x1 == x2 + = Just x1 + | otherwise + = Nothing +``` + +Then `th-desugar` will desugar it to: + +```hs +f :: T -> T -> Maybe Int +f arg1 arg2 = + case (# arg1, arg2 #) of + (# A x1, A x2 #) -> + case x1 == x2 of + True -> + Just x1 + False -> + Nothing + (# B x1, B x2 #) -> + case x1 == x2 of + True -> + Just x1 + False -> + Nothing + (# C x1, C x2 #) -> + case x1 == x2 of + True -> + Just x1 + False -> + Nothing +``` + +This code, while still more verbose than the original, uses a constant amount +of extra code per clause. + +### Desugaring guards can produce more warnings than the original code + +The approach that `th-desugar` uses to desugar guards can result in code that +produces GHC compiler warnings (if `-fenable-th-splice-warnings` is enabled) +where the original code does not. For example, consider the example from above: + +```hs +data T = A Int | B Int | C Int + +f :: T -> T -> Maybe Int +f (A x1) (A x2) + | x1 == x2 + = Just x1 +f (B x1) (B x2) + | x1 == x2 + = Just x1 +f (C x1) (C x2) + | x1 == x2 + = Just x1 +f _ _ = Nothing +``` + +This code compiles without any GHC warnings. If you desugar this code using +`th-desugar`, however, it will produce these warnings: + +``` +warning: [-Woverlapping-patterns] + Pattern match is redundant + In a case alternative: (# B y1, B y2 #) -> ... + | + | (# B y1, B y2 #) -> + | ^^^^^^^^^^^^^^^^^^^... + +warning: [-Woverlapping-patterns] + Pattern match is redundant + In a case alternative: (# C y1, C y2 #) -> ... + | + | (# C y1, C y2 #) -> + | ^^^^^^^^^^^^^^^^^^^... + +warning: [-Woverlapping-patterns] + Pattern match is redundant + In a case alternative: (# C y1, C y2 #) -> ... + | + | (# C y1, C y2 #) -> + | ^^^^^^^^^^^^^^^^^^^... +``` + +GHC is correct here: these matches are wholly redundant. `th-desugar` could +potentially recognize this and perform a more sophisticated analysis to detect +and remove such matches when desugaring guards, but it currently doesn't do +such an analysis. + +## No support for view patterns + +`th-desugar` does not support desugaring view patterns. An alternative to using +view patterns in the patterns of a function is to use pattern guards. +Currently, there is not a viable workaround for using view patterns in pattern +synonym definitions—see [this `th-desugar` +issue](https://github.com/goldfirere/th-desugar/issues/174). + +## No support for or-patterns + +`th-desugar` does not support desugaring +[or-patterns](https://github.com/ghc-proposals/ghc-proposals/blob/c9401f037cb22d1661931b2ec621925101052997/proposals/0522-or-patterns.rst). +See [this `th-desugar` +issue](https://github.com/goldfirere/th-desugar/issues/232). + +## No support for `ApplicativeDo` + +`th-desugar` does not take the `ApplicativeDo` extension into account when +desugaring `do` notation. For example, if you desugar this: + +```hs +{-# LANGUAGE ApplicativeDo #-} + +f x y = do + x' <- x + y' <- y + return (x' ++ y') +``` + +Then `th-desugar` will translate the uses of `<-` in the `do` block to uses of +`Monad` operations (e.g., `(>>=)`) rather than `Applicative` operations (e.g., +`(<*>)`). See [this `th-desugar` +issue](https://github.com/goldfirere/th-desugar/issues/138). + +## No support for `RecursiveDo` + +`th-desugar` does not support the `RecursiveDo` extension at all, so it cannot +desugar any uses of `mdo` expressions or `rec` statements. + +## No support for unresolved infix operators + +`th-desugar` does not support desugaring unresolved infix operators, such as +`UInfixE`. You are unlikely to encounter this limitation when dealing with +Template Haskell quotes, since quoted infix operators will translate to uses of +`InfixE` rather than `UInfixE`. Rather, this limitation would only be +encountered if you manually construct a Template Haskell `Exp` using `UInfixE`. diff --git a/Test/Dec.hs b/Test/Dec.hs --- a/Test/Dec.hs +++ b/Test/Dec.hs @@ -1,24 +1,24 @@ {- Tests for the th-desugar package (c) Richard Eisenberg 2013 -eir@cis.upenn.edu +rae@cs.brynmawr.edu -} {-# LANGUAGE TemplateHaskell, GADTs, PolyKinds, TypeFamilies, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, DataKinds, CPP, RankNTypes, StandaloneDeriving, DefaultSignatures, - ConstraintKinds #-} -#if __GLASGOW_HASKELL__ >= 707 -{-# LANGUAGE RoleAnnotations #-} + ConstraintKinds, RoleAnnotations, DeriveAnyClass #-} +#if __GLASGOW_HASKELL__ >= 810 +{-# LANGUAGE StandaloneKindSignatures #-} #endif - -{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-name-shadowing #-} - -#if __GLASGOW_HASKELL__ >= 711 -{-# OPTIONS_GHC -Wno-redundant-constraints #-} +#if __GLASGOW_HASKELL__ >= 907 +{-# LANGUAGE TypeAbstractions #-} #endif +{-# OPTIONS_GHC -Wno-orphans -Wno-name-shadowing + -Wno-redundant-constraints #-} + module Dec where import qualified Splices as S @@ -34,11 +34,30 @@ $(S.dectest8) $(S.dectest9) $(S.dectest10) -#if __GLASGOW_HASKELL__ >= 709 $(S.dectest11) -#endif $(S.dectest12) $(S.dectest13) +$(S.dectest14) + +$(S.dectest15) + +#if __GLASGOW_HASKELL__ >= 802 +$(S.dectest16) +$(S.dectest17) +#endif + +#if __GLASGOW_HASKELL__ >= 809 +$(S.dectest18) +#endif + +#if __GLASGOW_HASKELL__ >= 907 +$(S.dectest19) +#endif + +#if __GLASGOW_HASKELL__ >= 909 +$(S.dectest20) +$(S.dectest21) +#endif $(fmap unqualify S.instance_test) diff --git a/Test/DsDec.hs b/Test/DsDec.hs --- a/Test/DsDec.hs +++ b/Test/DsDec.hs @@ -1,32 +1,36 @@ {- Tests for the th-desugar package (c) Richard Eisenberg 2013 -eir@cis.upenn.edu +rae@cs.brynmawr.edu -} {-# LANGUAGE TemplateHaskell, GADTs, PolyKinds, TypeFamilies, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, DataKinds, CPP, RankNTypes, StandaloneDeriving, DefaultSignatures, - ConstraintKinds #-} -#if __GLASGOW_HASKELL__ >= 707 -{-# LANGUAGE RoleAnnotations #-} + ConstraintKinds, RoleAnnotations, DeriveAnyClass, + TypeApplications #-} +#if __GLASGOW_HASKELL__ >= 801 +{-# LANGUAGE DerivingStrategies #-} #endif - -{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-incomplete-patterns - -fno-warn-name-shadowing #-} - -#if __GLASGOW_HASKELL__ >= 711 -{-# OPTIONS_GHC -Wno-redundant-constraints #-} +#if __GLASGOW_HASKELL__ >= 810 +{-# LANGUAGE StandaloneKindSignatures #-} #endif +#if __GLASGOW_HASKELL__ >= 907 +{-# LANGUAGE TypeAbstractions #-} +#endif +{-# OPTIONS_GHC -Wno-orphans -Wno-incomplete-patterns + -Wno-name-shadowing -Wno-redundant-constraints #-} + module DsDec where import qualified Splices as S import Splices ( dsDecSplice, unqualify ) -import Language.Haskell.TH ( reportError ) +import qualified Language.Haskell.TH.Datatype.TyVarBndr as THAbs import Language.Haskell.TH.Desugar +import Language.Haskell.TH.Syntax ( qReport ) import Control.Monad @@ -47,34 +51,53 @@ $(dsDecSplice (fmap unqualify S.imp_inst_test3)) $(dsDecSplice (fmap unqualify S.imp_inst_test4)) -#if __GLASGOW_HASKELL__ < 707 -$(return $ decsToTH [S.ds_dectest10]) -#else $(dsDecSplice S.dectest10) -#endif -#if __GLASGOW_HASKELL__ >= 709 $(dsDecSplice S.dectest11) $(dsDecSplice S.standalone_deriving_test) + +#if __GLASGOW_HASKELL__ >= 801 +$(dsDecSplice S.deriv_strat_test) #endif $(dsDecSplice S.dectest12) $(dsDecSplice S.dectest13) +$(dsDecSplice S.dectest14) +$(dsDecSplice S.dectest15) + +#if __GLASGOW_HASKELL__ >= 802 +$(return $ decsToTH [S.ds_dectest16]) +$(return $ decsToTH [S.ds_dectest17]) +#endif + +#if __GLASGOW_HASKELL__ >= 809 +$(dsDecSplice S.dectest18) +#endif + +#if __GLASGOW_HASKELL__ >= 907 +$(dsDecSplice S.dectest19) +#endif + +#if __GLASGOW_HASKELL__ >= 909 +$(dsDecSplice S.dectest20) +$(dsDecSplice S.dectest21) +#endif + $(do decs <- S.rec_sel_test - [DDataD nd [] name [DPlainTV tvbName] cons []] <- dsDecs decs - let arg_ty = (DConT name) `DAppT` (DVarT tvbName) - recsels <- fmap concat $ mapM (getRecordSelectors arg_ty) cons - let num_sels = length recsels `div` 2 -- ignore type sigs - when (num_sels /= S.rec_sel_test_num_sels) $ - reportError $ "Wrong number of record selectors extracted.\n" - ++ "Wanted " ++ show S.rec_sel_test_num_sels - ++ ", Got " ++ show num_sels - let unrecord c@(DCon _ _ _ (DNormalC {}) _) = c - unrecord (DCon tvbs cxt con_name (DRecC fields) rty) = - let (_names, stricts, types) = unzip3 fields - fields' = zip stricts types - in - DCon tvbs cxt con_name (DNormalC fields') rty - plaindata = [DDataD nd [] name [DPlainTV tvbName] (map unrecord cons) []] - return (decsToTH plaindata ++ map letDecToTH recsels)) + withLocalDeclarations decs $ do + [DDataD nd [] name [DPlainTV tvbName THAbs.BndrReq] k cons []] <- dsDecs decs + recsels <- getRecordSelectors cons + let num_sels = length recsels `div` 2 -- ignore type sigs + when (num_sels /= S.rec_sel_test_num_sels) $ + qReport True $ "Wrong number of record selectors extracted.\n" + ++ "Wanted " ++ show S.rec_sel_test_num_sels + ++ ", Got " ++ show num_sels + let unrecord c@(DCon _ _ _ (DNormalC {}) _) = c + unrecord (DCon tvbs cxt con_name (DRecC fields) rty) = + let (_names, stricts, types) = unzip3 fields + fields' = zip stricts types + in + DCon tvbs cxt con_name (DNormalC False fields') rty + plaindata = [DDataD nd [] name [DPlainTV tvbName THAbs.BndrReq] k (map unrecord cons) []] + return (decsToTH plaindata ++ map letDecToTH recsels)) diff --git a/Test/FakeSums.hs b/Test/FakeSums.hs new file mode 100644 --- /dev/null +++ b/Test/FakeSums.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE MagicHash #-} + +-- | Defines data types with names identical to those found in "GHC.Types". +-- This is used as part of a series of unit tests for the +-- @unboxedSumNameDegree_maybe@ function, which should only return 'Just' when the +-- argument 'Name' is actually an unboxed sum from "GHC.Types", not a user-defined +-- type. +module FakeSums + ( Sum2#, Sum3#, Sum4# + ) where + +data Sum2# a b +data Sum3# a b c +data Sum4# a b c diff --git a/Test/FakeTuples.hs b/Test/FakeTuples.hs new file mode 100644 --- /dev/null +++ b/Test/FakeTuples.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE MagicHash #-} + +-- | Defines data types with names identical to those found in "GHC.Tuple". +-- This is used as part of a series of unit tests for the +-- @tupleNameDegree_maybe@ and @unboxedTupleNameDegree_maybe@ functions, which +-- should only return 'Just' when the argument 'Name' is actually a tuple from +-- "GHC.Tuple", not a user-defined type. +module FakeTuples + ( Tuple0, Tuple1, Tuple2, Tuple3 + , Tuple0#, Tuple1#, Tuple2#, Tuple3# + ) where + +data Tuple0 +data Tuple1 a +data Tuple2 a b +data Tuple3 a b c + +data Tuple0# +data Tuple1# a +data Tuple2# a b +data Tuple3# a b c diff --git a/Test/ReifyTypeCUSKs.hs b/Test/ReifyTypeCUSKs.hs new file mode 100644 --- /dev/null +++ b/Test/ReifyTypeCUSKs.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +#if __GLASGOW_HASKELL__ < 806 +{-# LANGUAGE TypeInType #-} +#endif +#if __GLASGOW_HASKELL__ >= 809 +{-# LANGUAGE CUSKs #-} +#endif +-- This is kept in a separate module from ReifyTypeSigs to isolate the use of +-- the -XCUSKs language extension. +module ReifyTypeCUSKs where + +import Data.Kind (Type) +import GHC.Exts (Constraint) +import Language.Haskell.TH.Desugar +import Language.Haskell.TH.Syntax hiding (Type) +import Splices (eqTH) + +test_reify_type_cusks, test_reify_type_no_cusks :: [Bool] +(test_reify_type_cusks, test_reify_type_no_cusks) = + $(do cusk_decls <- + [d| data A1 (a :: Type) + type A2 (a :: Type) = (a :: Type) + type family A3 a + data family A4 a + type family A5 (a :: Type) :: Type where + A5 a = a + class A6 (a :: Type) where + type A7 a b + + data A8 (a :: k) :: k -> Type +#if __GLASGOW_HASKELL__ >= 804 + data A9 (a :: j) :: forall k. k -> Type +#endif +#if __GLASGOW_HASKELL__ >= 809 + data A10 (k :: Type) (a :: k) + data A11 :: forall k -> k -> Type +#endif + |] + + no_cusk_decls <- + [d| data B1 a + type B2 (a :: Type) = a + type B3 a = (a :: Type) + type family B4 (a :: Type) where + B4 a = a + type family B5 a :: Type where + B5 a = a + class B6 a where + type B7 (a :: Type) (b :: Type) :: Type + + data B8 :: k -> Type +#if __GLASGOW_HASKELL__ >= 804 + data B9 :: forall j. j -> k -> Type +#endif + |] + + let test_reify_kind :: DsMonad q + => String -> (Int, Maybe DKind) -> q Bool + test_reify_kind prefix (i, expected_kind) = do + actual_kind <- dsReifyType $ mkName $ prefix ++ show i + return $ expected_kind `eqTH` actual_kind + + typeKind :: DKind + typeKind = DConT typeKindName + + type_to_type :: DKind + type_to_type = DArrowT `DAppT` typeKind `DAppT` typeKind + + cusk_decl_bools <- + withLocalDeclarations cusk_decls $ + traverse (\(i, k) -> test_reify_kind "A" (i, Just k)) $ + [ (1, type_to_type) + , (2, type_to_type) + , (3, type_to_type) + , (4, type_to_type) + , (5, type_to_type) + , (6, DArrowT `DAppT` typeKind `DAppT` DConT ''Constraint) + , (7, DArrowT `DAppT` typeKind `DAppT` type_to_type) + ] + ++ + [ (8, let k = mkName "k" in + DForallT (DForallInvis [DPlainTV k SpecifiedSpec]) $ + DArrowT `DAppT` DVarT k `DAppT` + (DArrowT `DAppT` DVarT k `DAppT` typeKind)) + ] +#if __GLASGOW_HASKELL__ >= 804 + ++ + [ (9, let j = mkName "j" + k = mkName "k" in + DForallT (DForallInvis [DPlainTV j SpecifiedSpec]) $ + DArrowT `DAppT` DVarT j `DAppT` + (DForallT (DForallInvis [DPlainTV k SpecifiedSpec]) $ + DArrowT `DAppT` DVarT k `DAppT` typeKind)) + ] +#endif +#if __GLASGOW_HASKELL__ >= 809 + ++ + [ (10, let k = mkName "k" in + DForallT (DForallVis [DKindedTV k () typeKind]) $ + DArrowT `DAppT` DVarT k `DAppT` typeKind) + , (11, let k = mkName "k" in + DForallT (DForallVis [DPlainTV k ()]) $ + DArrowT `DAppT` DVarT k `DAppT` typeKind) + ] +#endif + + no_cusk_decl_bools <- + withLocalDeclarations no_cusk_decls $ + traverse (test_reify_kind "B") $ + map (, Nothing) $ + [1..7] + ++ [8] +#if __GLASGOW_HASKELL__ >= 804 + ++ [9] +#endif + lift (cusk_decl_bools, no_cusk_decl_bools)) diff --git a/Test/ReifyTypeSigs.hs b/Test/ReifyTypeSigs.hs new file mode 100644 --- /dev/null +++ b/Test/ReifyTypeSigs.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} +#if __GLASGOW_HASKELL__ >= 809 +{-# LANGUAGE StandaloneKindSignatures #-} +#endif +module ReifyTypeSigs where + +#if __GLASGOW_HASKELL__ >= 809 +import Data.Kind +import Data.Proxy +#endif +import Language.Haskell.TH.Desugar +import Language.Haskell.TH.Syntax hiding (Type) +import Splices (eqTH) + +test_reify_kind_sigs :: [Bool] +test_reify_kind_sigs = + $(do kind_sig_decls <- + [d| +#if __GLASGOW_HASKELL__ >= 809 + type A1 :: forall k. k -> Type + data A1 a + + type A2 :: k -> Type + type A2 a = a + + type A3 :: forall k. k -> Type + type family A3 + + type A4 :: forall k. k -> Type + data family A4 a + + type A5 :: k -> Type + type family A5 a where + A5 a = a + + type A6 :: forall (k :: Bool) -> Proxy k -> Constraint + class A6 a b where + type A7 a c +#endif + |] + + let test_reify_kind :: DsMonad q + => (Int, DKind) -> q Bool + test_reify_kind (i, expected_kind) = do + actual_kind <- dsReifyType $ mkName $ "A" ++ show i + return $ Just expected_kind `eqTH` actual_kind + + kind_sig_decl_bools <- + withLocalDeclarations kind_sig_decls $ + traverse test_reify_kind $ + [] +#if __GLASGOW_HASKELL__ >= 809 + ++ + let k = mkName "k" + typeKind = DConT typeKindName + boolKind = DConT ''Bool + k_to_type = DArrowT `DAppT` DVarT k `DAppT` typeKind + forall_k_invis_k_to_type = + DForallT (DForallInvis [DPlainTV k SpecifiedSpec]) k_to_type in + [ (1, forall_k_invis_k_to_type) + , (2, k_to_type) + , (3, forall_k_invis_k_to_type) + , (4, forall_k_invis_k_to_type) + , (5, k_to_type) + , (6, DForallT (DForallVis [DKindedTV k () boolKind]) $ + DArrowT `DAppT` (DConT ''Proxy `DAppT` DVarT k) + `DAppT` DConT ''Constraint) + , (7, DArrowT `DAppT` boolKind `DAppT` + (DArrowT `DAppT` typeKind `DAppT` typeKind)) + ] +#endif + + lift kind_sig_decl_bools) diff --git a/Test/Run.hs b/Test/Run.hs --- a/Test/Run.hs +++ b/Test/Run.hs @@ -1,24 +1,53 @@ {- Tests for the th-desugar package (c) Richard Eisenberg 2013 -eir@cis.upenn.edu +rae@cs.brynmawr.edu -} {-# LANGUAGE TemplateHaskell, UnboxedTuples, ParallelListComp, CPP, - RankNTypes, ImpredicativeTypes, TypeFamilies, + RankNTypes, TypeFamilies, DataKinds, ConstraintKinds, PolyKinds, MultiParamTypeClasses, - FlexibleInstances, ExistentialQuantification #-} -{-# OPTIONS -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns - -fno-warn-unused-matches -fno-warn-type-defaults - -fno-warn-missing-signatures -fno-warn-unused-do-bind #-} + FlexibleInstances, ExistentialQuantification, + ScopedTypeVariables, GADTs, ViewPatterns, TupleSections, + TypeOperators, PartialTypeSignatures, PatternSynonyms, + TypeApplications, MagicHash #-} +{-# OPTIONS -Wno-incomplete-patterns -Wno-overlapping-patterns + -Wno-unused-matches -Wno-type-defaults + -Wno-missing-signatures -Wno-unused-do-bind + -Wno-missing-fields -Wno-incomplete-record-updates + -Wno-partial-type-signatures -Wno-redundant-constraints #-} -#if __GLASGOW_HASKELL__ >= 711 -{-# LANGUAGE PartialTypeSignatures #-} -{-# OPTIONS_GHC -Wno-partial-type-signatures -Wno-redundant-constraints #-} +#if __GLASGOW_HASKELL__ >= 805 +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE QuantifiedConstraints #-} #endif -module Run where +#if __GLASGOW_HASKELL__ < 806 +{-# LANGUAGE TypeInType #-} +#endif +#if __GLASGOW_HASKELL__ >= 809 +{-# LANGUAGE StandaloneKindSignatures #-} +#endif + +#if __GLASGOW_HASKELL__ >= 906 +{-# LANGUAGE TypeData #-} +#endif + +#if __GLASGOW_HASKELL__ >= 907 +{-# LANGUAGE TypeAbstractions #-} +#endif + +#if __GLASGOW_HASKELL__ >= 909 +{-# LANGUAGE RequiredTypeArguments #-} +#endif + +#if __GLASGOW_HASKELL__ >= 911 +{-# LANGUAGE ImpredicativeTypes #-} +#endif + +module Main where + import Prelude hiding ( exp ) import Test.HUnit @@ -29,22 +58,44 @@ import qualified DsDec import qualified Dec import Dec ( RecordSel ) +import ReifyTypeCUSKs +import ReifyTypeSigs +import T159Decs ( t159A, t159B ) +import T183 ( t183 ) +import qualified Language.Haskell.TH.Datatype.TyVarBndr as THAbs import Language.Haskell.TH.Desugar -#if __GLASGOW_HASKELL__ >= 707 +import qualified Language.Haskell.TH.Desugar.OSet as OS import Language.Haskell.TH.Desugar.Expand ( expandUnsoundly ) -#endif import Language.Haskell.TH -import qualified Language.Haskell.TH.Syntax as Syn ( lift ) +import qualified Language.Haskell.TH.Syntax as Syn +import Control.Exception ( ErrorCall ) import Control.Monad -#if __GLASGOW_HASKELL__ < 709 -import Control.Applicative -#endif -#if __GLASGOW_HASKELL__ >= 707 +import qualified Data.Map as M import Data.Proxy + +#if __GLASGOW_HASKELL__ >= 900 +import Data.Kind (Constraint) +import Prelude as P #endif +#if __GLASGOW_HASKELL__ >= 906 +import GHC.Tuple ( Solo(MkSolo) ) +#elif __GLASGOW_HASKELL__ >= 900 +import GHC.Tuple ( Solo(Solo) ) +#endif + +#if __GLASGOW_HASKELL__ >= 908 +import qualified FakeTuples +import GHC.Tuple ( Tuple0, Tuple1, Tuple2, Tuple3, Unit ) +#endif + +#if __GLASGOW_HASKELL__ >= 910 +import qualified FakeSums +import GHC.Types (Solo#, Sum2#, Sum3#, Sum4#, Tuple0#, Tuple1#, Tuple2#, Tuple3#, Unit#) +#endif + -- | -- Convert a HUnit test suite to a spec. This can be used to run existing -- HUnit tests with Hspec. @@ -74,10 +125,8 @@ , "case" ~: $test8_case @=? $(dsSplice test8_case) , "do" ~: $test9_do @=? $(dsSplice test9_do) , "comp" ~: $test10_comp @=? $(dsSplice test10_comp) -#if __GLASGOW_HASKELL__ >= 707 , "parcomp" ~: $test11_parcomp @=? $(dsSplice test11_parcomp) , "parcomp2" ~: $test12_parcomp2 @=? $(dsSplice test12_parcomp2) -#endif , "sig" ~: $test13_sig @=? $(dsSplice test13_sig) , "record" ~: $test14_record @=? $(dsSplice test14_record) , "litp" ~: $test15_litp @=? $(dsSplice test15_litp) @@ -88,8 +137,9 @@ , "asp" ~: $test20_asp @=? $(dsSplice test20_asp) , "wildp" ~: $test21_wildp @=? $(dsSplice test21_wildp) , "listp" ~: $test22_listp @=? $(dsSplice test22_listp) --- type signatures in patterns not yet handled by Template Haskell --- , "sigp" ~: $test23_sigp @=? $(dsSplice test23_sigp) +#if __GLASGOW_HASKELL__ >= 801 + , "sigp" ~: $test23_sigp @=? $(dsSplice test23_sigp) +#endif , "fun" ~: $test24_fun @=? $(dsSplice test24_fun) , "fun2" ~: $test25_fun2 @=? $(dsSplice test25_fun2) , "forall" ~: $test26_forall @=? $(dsSplice test26_forall) @@ -101,14 +151,70 @@ , "tylit" ~: $test32_tylit @=? $(dsSplice test32_tylit) , "tvbs" ~: $test33_tvbs @=? $(dsSplice test33_tvbs) , "let_as" ~: $test34_let_as @=? $(dsSplice test34_let_as) -#if __GLASGOW_HASKELL__ >= 709 , "pred" ~: $test37_pred @=? $(dsSplice test37_pred) , "pred2" ~: $test38_pred2 @=? $(dsSplice test38_pred2) , "eq" ~: $test39_eq @=? $(dsSplice test39_eq) -#endif -#if __GLASGOW_HASKELL__ >= 711 , "wildcard" ~: $test40_wildcards@=? $(dsSplice test40_wildcards) +#if __GLASGOW_HASKELL__ >= 801 + , "typeapps" ~: $test41_typeapps @=? $(dsSplice test41_typeapps) + , "scoped_tvs" ~: $test42_scoped_tvs @=? $(dsSplice test42_scoped_tvs) + , "ubx_sums" ~: $test43_ubx_sums @=? $(dsSplice test43_ubx_sums) #endif + , "let_pragma" ~: $test44_let_pragma @=? $(dsSplice test44_let_pragma) +-- , "empty_rec" ~: $test45_empty_record_con @=? $(dsSplice test45_empty_record_con) + -- This one can't be tested by this means, because it contains an "undefined" +#if __GLASGOW_HASKELL__ >= 803 + , "over_label" ~: $test46_overloaded_label @=? $(dsSplice test46_overloaded_label) +#endif + , "do_partial_match" ~: $test47_do_partial_match @=? $(dsSplice test47_do_partial_match) +#if __GLASGOW_HASKELL__ >= 805 + , "quantified_constraints" ~: $test48_quantified_constraints @=? $(dsSplice test48_quantified_constraints) +#endif +#if __GLASGOW_HASKELL__ >= 807 + , "implicit_params" ~: $test49_implicit_params @=? $(dsSplice test49_implicit_params) + , "vka" ~: $test50_vka @=? $(dsSplice test50_vka) +#endif +#if __GLASGOW_HASKELL__ >= 809 + , "tuple_sections" ~: $test51_tuple_sections @=? $(dsSplice test51_tuple_sections) +#endif +#if __GLASGOW_HASKELL__ >= 900 + , "qual_do" ~: $test52_qual_do @=? $(dsSplice test52_qual_do) +#endif +#if __GLASGOW_HASKELL__ >= 901 + , "vta_in_con_pats" ~: $test53_vta_in_con_pats @=? $(dsSplice test53_vta_in_con_pats) +#endif +#if __GLASGOW_HASKELL__ >= 902 + , "overloaded_record_dot" ~: $test54_overloaded_record_dot @=? $(dsSplice test54_overloaded_record_dot) +#endif +#if __GLASGOW_HASKELL__ >= 903 + , "opaque_pragma" ~: $test55_opaque_pragma @=? $(dsSplice test55_opaque_pragma) + , "lambda_cases" ~: $test56_lambda_cases @=? $(dsSplice test56_lambda_cases) +#endif +#if __GLASGOW_HASKELL__ >= 907 + , "typed_th_bracket" ~: $$($test57_typed_th_bracket) @=? $$($(dsSplice test57_typed_th_bracket)) + , "typed_th_splice" ~: $test58_typed_th_splice @=? $(dsSplice test58_typed_th_splice) +#endif +#if __GLASGOW_HASKELL__ >= 909 + , "embedded_types_keyword" ~: $test59_embedded_types_keyword @=? $(dsSplice test59_embedded_types_keyword) + , "embedded_types_no_keyword" ~: $test60_embedded_types_no_keyword @=? $(dsSplice test60_embedded_types_no_keyword) + , "invis_type_pat" ~: $test61_invis_type_pat @=? $(dsSplice test61_invis_type_pat) + , "embedded_types_lambda_keyword" ~: $test62_embedded_types_lambda_keyword @=? $(dsSplice test62_embedded_types_lambda_keyword) + , "embedded_types_case_keyword" ~: $test63_embedded_types_case_keyword @=? $(dsSplice test63_embedded_types_case_keyword) + , "embedded_types_cases_keyword" ~: $test64_embedded_types_cases_keyword @=? $(dsSplice test64_embedded_types_cases_keyword) + , "embedded_types_lambda_no_keyword" ~: $test65_embedded_types_lambda_no_keyword @=? $(dsSplice test65_embedded_types_lambda_no_keyword) + , "embedded_types_case_no_keyword" ~: $test66_embedded_types_case_no_keyword @=? $(dsSplice test66_embedded_types_case_no_keyword) + , "embedded_types_cases_no_keyword" ~: $test67_embedded_types_cases_no_keyword @=? $(dsSplice test67_embedded_types_cases_no_keyword) + , "invis_type_pat_lambda" ~: $test68_invis_type_pat_lambda @=? $(dsSplice test68_invis_type_pat_lambda) + , "invis_type_pat_cases" ~: $test69_invis_type_pat_cases @=? $(dsSplice test69_invis_type_pat_cases) +#endif +#if __GLASGOW_HASKELL__ >= 911 + , "embedded_forall_invis" ~: $(test70_embedded_forall_invis) @=? $(dsSplice test70_embedded_forall_invis) + , "embedded_forall_vis" ~: $(test71_embedded_forall_vis) @=? $(dsSplice test71_embedded_forall_vis) + , "embedded_constraint" ~: $(test72_embedded_constraint) @=? $(dsSplice test72_embedded_constraint) +#endif +#if __GLASGOW_HASKELL__ >= 913 + , "specialise_exp_pragma" ~: $(test73_specialise_exp_pragma) @=? $(dsSplice test73_specialise_exp_pragma) +#endif ] test35a = $test35_expand @@ -119,7 +225,6 @@ test_e3b = $(test_expand3 >>= dsExp >>= expand >>= return . expToTH) test_e4a = $test_expand4 test_e4b = $(test_expand4 >>= dsExp >>= expand >>= return . expToTH) -#if __GLASGOW_HASKELL__ >= 707 test_e5a = $test_expand5 test_e5b = $(test_expand5 >>= dsExp >>= expand >>= return . expToTH) test_e6a = $test_expand6 @@ -127,11 +232,16 @@ test_e7a = $test_expand7 test_e7b = $(test_expand7 >>= dsExp >>= expand >>= return . expToTH) test_e7c = $(test_expand7 >>= dsExp >>= expandUnsoundly >>= return . expToTH) +#if __GLASGOW_HASKELL__ < 801 test_e8a = $(test_expand8 >>= dsExp >>= expand >>= return . expToTH) - -- the line above should fail once GHC#8953 is fixed for closed type - -- families -test_e8b = $(test_expand8 >>= dsExp >>= expandUnsoundly >>= return . expToTH) + -- This won't expand on recent GHCs now that GHC Trac #8953 is fixed for + -- closed type families. #endif +test_e8b = $(test_expand8 >>= dsExp >>= expandUnsoundly >>= return . expToTH) +test_e9a = $test_expand9 -- requires GHC #9262 +test_e9b = $(test_expand9 >>= dsExp >>= expand >>= return . expToTH) +test_e10a = $test_expand10 +test_e10b = $(test_expand10 >>= dsExp >>= expand >>= return . expToTH) hasSameType :: a -> a -> Bool hasSameType _ _ = True @@ -141,13 +251,16 @@ , hasSameType test36a test36b , hasSameType test_e3a test_e3b , hasSameType test_e4a test_e4b -#if __GLASGOW_HASKELL__ >= 707 , hasSameType test_e5a test_e5b , hasSameType test_e6a test_e6b , hasSameType test_e7a test_e7b , hasSameType test_e7a test_e7c +#if __GLASGOW_HASKELL__ < 801 , hasSameType test_e8a test_e8a #endif + , hasSameType test_e8b test_e8b + , hasSameType test_e9a test_e9b + , hasSameType test_e10a test_e10b ] test_dec :: [Bool] @@ -168,14 +281,12 @@ test_bug8884 :: Bool test_bug8884 = $(do info <- reify ''Poly dinfo@(DTyConI (DOpenTypeFamilyD (DTypeFamilyHead _name _tvbs (DKindSig resK) _ann)) - (Just [DTySynInstD _name2 (DTySynEqn lhs _rhs)])) + (Just [DTySynInstD (DTySynEqn _ lhs _rhs)])) <- dsInfo info - case (resK, lhs) of -#if __GLASGOW_HASKELL__ < 709 - (DStarT, [DVarT _]) -> [| True |] -#else - (DStarT, [DSigT (DVarT _) (DVarT _)]) -> [| True |] -#endif + let isTypeKind (DConT n) = isTypeKindName n + isTypeKind _ = False + case (isTypeKind resK, lhs) of + (True, _ `DAppT` DSigT (DVarT _) (DVarT _)) -> [| True |] _ -> do runIO $ do putStrLn "Failed bug8884 test:" @@ -184,10 +295,10 @@ flatten_dvald :: Bool flatten_dvald = let s1 = $(flatten_dvald_test) - s2 = $(do exp <- flatten_dvald_test - DLetE ddecs dexp <- dsExp exp + s2 = $(do expr <- flatten_dvald_test + DLetE ddecs dexpr <- dsExp expr flattened <- fmap concat $ mapM flattenDValD ddecs - return $ expToTH $ DLetE flattened dexp ) in + return $ expToTH $ DLetE flattened dexpr ) in s1 == s2 test_rec_sels :: Bool @@ -195,12 +306,614 @@ return $ ListE bools) test_standalone_deriving :: Bool -#if __GLASGOW_HASKELL__ >= 709 test_standalone_deriving = (MkBlarggie 5 'x') == (MkBlarggie 5 'x') + +test_deriving_strategies :: Bool +#if __GLASGOW_HASKELL__ >= 801 +test_deriving_strategies = compare (MkBlarggie 5 'x') (MkBlarggie 5 'x') == EQ #else -test_standalone_deriving = True +test_deriving_strategies = True #endif +test_local_tyfam_expansion :: Bool +test_local_tyfam_expansion = + $(do fam_name <- newName "Fam" + let orig_ty = DConT fam_name + exp_ty <- withLocalDeclarations + (decsToTH [ DOpenTypeFamilyD (DTypeFamilyHead fam_name [] DNoSig Nothing) + , DTySynInstD (DTySynEqn Nothing + (DConT fam_name) (DConT ''Int)) ]) + (expandType orig_ty) + orig_ty `eqTHSplice` exp_ty) + +test_stuck_tyfam_expansion :: Bool +test_stuck_tyfam_expansion = + $(do fam_name <- newName "F" + x <- newName "x" + k <- newName "k" + let orig_ty = DConT fam_name `DAppT` DConT '() -- F '() + exp_ty <- withLocalDeclarations + (decsToTH [ -- type family F (x :: k) :: k + DOpenTypeFamilyD + (DTypeFamilyHead fam_name + [DKindedTV x THAbs.BndrReq (DVarT k)] + (DKindSig (DVarT k)) + Nothing) + -- type instance F (x :: ()) = x + , DTySynInstD + (DTySynEqn Nothing + (DConT fam_name `DAppT` + DSigT (DVarT x) (DConT ''())) + (DVarT x)) + ]) + (expandType orig_ty) + orig_ty `eqTHSplice` exp_ty) + +test_t85 :: Bool +test_t85 = + $(do let orig_ty = + (DConT ''Constant `DAppT` DConT ''Int `DAppT` DConT 'True) + `DSigT` (DConT ''Constant `DAppT` DConT ''Char `DAppT` DConT ''Bool) + expected_ty = DConT 'True `DSigT` DConT ''Bool + expanded_ty <- expandType orig_ty + expected_ty `eqTHSplice` expanded_ty) + +test_t92 :: Bool +test_t92 = + $(do a <- newName "a" + f <- newName "f" + let t = DForallT (DForallInvis [DPlainTV f SpecifiedSpec]) + (DVarT f `DAppT` DVarT a) + toposortTyVarsOf [t] `eqTHSplice` [DPlainTV a ()]) + +test_t97 :: Bool +test_t97 = + $(do a <- newName "a" + k <- newName "k" + let orig_ty = DForallT + (DForallInvis + [DKindedTV a SpecifiedSpec + (DConT ''Constant `DAppT` DConT ''Int + `DAppT` DVarT k)]) + (DVarT a) + expected_ty = DForallT (DForallInvis + [DKindedTV a SpecifiedSpec (DVarT k)]) + (DVarT a) + expanded_ty <- expandType orig_ty + expected_ty `eqTHSplice` expanded_ty) + +test_getDataD_kind_sig :: Bool +test_getDataD_kind_sig = + 3 == $(do data_name <- newName "TestData" + a <- newName "a" + let type_kind = DConT typeKindName + data_kind_sig = DArrowT `DAppT` type_kind `DAppT` + (DArrowT `DAppT` type_kind `DAppT` type_kind) + (_, tvbs, _) <- + withLocalDeclarations + [decToTH (DDataD Data [] data_name [DPlainTV a THAbs.BndrReq] + (Just data_kind_sig) [] [])] + (getDataD "th-desugar: Impossible" data_name) + [| $(Syn.lift (length tvbs)) |]) + +test_t100 :: Bool +test_t100 = + $(do decs <- [d| data T b where + MkT :: forall a. { unT :: a } -> T a |] + info <- withLocalDeclarations decs (dsReify (mkName "unT")) + let -- forall a. T a -> a + exp_ty = DForallT (DForallInvis [DPlainTV (mkName "a") SpecifiedSpec]) $ + DArrowT `DAppT` (DConT (mkName "T") `DAppT` DVarT (mkName "a")) + `DAppT` DVarT (mkName "a") + case info of + Just (DVarI _ actual_ty _) -> exp_ty `eqTHSplice` actual_ty + _ -> [| False |]) + +test_t102 :: [Bool] +test_t102 = + $(do decs1 <- [d| data Foo x where MkFoo :: forall a. { unFoo :: a } -> Foo a |] + let b1 = withLocalDeclarations decs1 $ do + [DDataD _ _ _ _ _ cons1 _] <- dsDecs decs1 + recs1 <- getRecordSelectors cons1 + (length recs1 `div` 2) `eqTHSplice` 1 + decs2 <- [d| data HList l where + Nil :: HList '[] + (:>) :: { hhead :: x, htail :: HList xs } -> HList (x ': xs) |] + let b2 = withLocalDeclarations decs2 $ do + [DDataD _ _ _ _ _ cons2 _] <- dsDecs decs2 + recs2 <- getRecordSelectors cons2 + (length recs2 `div` 2) `eqTHSplice` 2 + [| [$b1, $b2] |]) + +test_t103 :: Bool +test_t103 = + $(do decs <- [d| data P (a :: k) = MkP |] + [DDataD _ _ _ _ _ [DCon tvbs _ _ _ _] _] <- dsDecs decs + case tvbs of + [DPlainTV k SpecifiedSpec, DKindedTV a SpecifiedSpec (DVarT k')] + | nameBase k == "k" + , nameBase a == "a" + , k == k' + -> [| True |] + | otherwise + -> [| False |]) + +test_t112 :: [Bool] +test_t112 = + $(do a <- newName "a" + b <- newName "b" + let aVar = DVarT a + bVar = DVarT b + aTvb = DPlainTV a () + bTvb = DPlainTV b () + + fvsABExpected = [aTvb, bTvb] + fvsABActual = toposortTyVarsOf [aVar, bVar] + + fvsBAExpected = [bTvb, aTvb] + fvsBAActual = toposortTyVarsOf [bVar, aVar] + + eqAB = fvsABExpected `eqTH` fvsABActual + eqBA = fvsBAExpected `eqTH` fvsBAActual + [| [eqAB, eqBA] |]) + +test_t132 :: Bool +test_t132 = + $(do let c = mkName "C" + m = mkName "m" + a = mkName "a" + fixity = Fixity 5 InfixR + -- Defines a class with a fixity declaration inside, i.e., + -- + -- class C a where + -- infixr 5 `m` + -- m :: a + -- + -- We define this by hand to avoid GHC#17608 on pre-9.0 GHCs. + decs = sweeten [ DClassD [] c [DPlainTV a THAbs.BndrReq] [] + [ DLetDec (DInfixD fixity NoNamespaceSpecifier m) + , DLetDec (DSigD m (DVarT a)) + ] + ] + expected = Just fixity + actual <- withLocalDeclarations decs (reifyFixityWithLocals m) + expected `eqTHSplice` actual) + +#if __GLASGOW_HASKELL__ >= 801 +-- Test local reification of pattern synonym record selectors. +test_t137 :: [Bool] +test_t137 = + $(do a <- newName "a" + b <- newName "b" + let aVarT = DVarT a + aVarP = DVarP a + bVarT = DVarT b + bVarP = DVarP b + aTvb = DPlainTV a SpecifiedSpec + bTvb = DPlainTV b SpecifiedSpec + + p1 = mkName "P1" + unP1a = mkName "unP1a" + unP1b = mkName "unP1b" + p2 = mkName "P2" + unP2a = mkName "unP2a" + unP2b = mkName "unP2b" + p3 = mkName "P3" + unP3a = mkName "unP3a" + unP3b = mkName "unP3b" + + tupleTy = DConT (tupleTypeName 2) `DAppT` aVarT `DAppT` bVarT + showCxt = [DConT ''Show `DAppT` aVarT] + patSynSigDBodyTy = + DArrowT `DAppT` aVarT `DAppT` (DArrowT `DAppT` bVarT `DAppT` tupleTy) + + -- pattern P{unPa, unPb} = (unPa, unPb) + mkPatSynD :: Name -> Name -> Name -> DDec + mkPatSynD p unPa unPb = + DPatSynD + p + (RecordPatSyn [unPa, unPb]) + DImplBidir + (DConP (tupleDataName 2) [] [aVarP, bVarP]) + + decs :: [Dec] + decs = sweeten + [ -- pattern P1 :: a -> b -> (a, b) + DPatSynSigD p1 patSynSigDBodyTy + , mkPatSynD p1 unP1a unP1b + + -- pattern P2 :: Show a => a -> b -> (a, b) + , DPatSynSigD p2 $ DConstrainedT showCxt patSynSigDBodyTy + , mkPatSynD p2 unP2a unP2b + + -- pattern P3 :: forall b a. Show a => a -> b -> (a, b) + , DPatSynSigD p3 $ + DForallT (DForallInvis [bTvb, aTvb]) $ + DConstrainedT showCxt patSynSigDBodyTy + , mkPatSynD p3 unP3a unP3b + ] + + -- Pair each pattern synonym record selector name with the type that + -- local reification should produce. + expecteds :: [(Name, DType)] + expecteds = + [ (unP1a, DForallT (DForallInvis [aTvb, bTvb]) $ + DArrowT `DAppT` tupleTy `DAppT` aVarT) + , (unP1b, DForallT (DForallInvis [aTvb, bTvb]) $ + DArrowT `DAppT` tupleTy `DAppT` bVarT) + + -- The reified types below use (DForallInvis []) due to the way + -- that ForallT is desugared. + -- See Note [Desugaring and sweetening ForallT] in + -- Language.Haskell.TH.Desugar.Core. + , (unP2a, DForallT (DForallInvis []) $ + DConstrainedT showCxt $ + DArrowT `DAppT` tupleTy `DAppT` aVarT) + , (unP2b, DForallT (DForallInvis []) $ + DConstrainedT showCxt $ + DArrowT `DAppT` tupleTy `DAppT` bVarT) + + , (unP3a, DForallT (DForallInvis [bTvb, aTvb]) $ + DConstrainedT showCxt $ + DArrowT `DAppT` tupleTy `DAppT` aVarT) + , (unP3b, DForallT (DForallInvis [bTvb, aTvb]) $ + DConstrainedT showCxt $ + DArrowT `DAppT` tupleTy `DAppT` bVarT) + ] + + expected_eq_actual :: (Name, DType) -> DsM Q Bool + expected_eq_actual (sel_name, expected_ty) = do + let expected_info = Just $ DVarI sel_name expected_ty Nothing + actual_info <- dsReify sel_name + pure $ expected_info `eqTH` actual_info + + bs <- withLocalDeclarations decs $ mapM expected_eq_actual expecteds + Syn.lift bs) +#endif + +test_t154 :: Bool +test_t154 = + $(do decs <- [d| data T where + (:$$:) :: Int -> Int -> T + |] + ddecs <- dsDecs decs + let mb_is_infix = case ddecs of + [DDataD _ _ _ _ _ [DCon _ _ _ (DNormalC is_infix _) _] _] + -> Just is_infix + _ -> Nothing + mb_is_infix `eqTHSplice` Just False) + +-- Regression test for #159 which ensures that non-exhaustive functions throw +-- a runtime error before forcing their arguments. +test_t159 :: Expectation +test_t159 = do + -- NB: Catch ErrorCall here, not PatternMatchFail. This is because we desugar + -- non-exhaustive patterns into a custom `error` expression. + let testOne f = f (let x = x in x) `shouldThrow` \(_ :: ErrorCall) -> True + testOne t159A + testOne t159B + +#if __GLASGOW_HASKELL__ >= 906 +test_t170 :: [Bool] +test_t170 = + $(do decs <- [d| type data TyData = MkTyData |] + + let test_TypeData_NameSpace nameStr = + withLocalDeclarations decs $ do + Just name <- lookupTypeNameWithLocals nameStr + mbNS <- reifyNameSpace name + mbNS `eqTHSplice` Just Syn.TcClsName + + let b1 = test_TypeData_NameSpace "TyData" + let b2 = test_TypeData_NameSpace "MkTyData" + [| [$b1, $b2] |]) +#endif + +test_t171 :: Bool +test_t171 = + $(do a <- newName "a" + b <- newName "b" + c <- newName "c" + x <- newName "x" + y <- newName "y" + + let aVarT = DVarT a + bVarT = DVarT b + cVarT = DVarT c + aTvb = DPlainTV a SpecifiedSpec + bTvb = DPlainTV b SpecifiedSpec + cTvb = DPlainTV c SpecifiedSpec + t = mkName "T" + mkT = mkName "mkT" + getT1 = mkName "getT1" + getT2 = mkName "getT2" + + dec = -- data T x y where + -- MkT :: forall b a c. { getT1 :: b, getT2 :: c } -> T a b + DDataD + Data + [] + t + [DPlainTV x THAbs.BndrReq, DPlainTV y THAbs.BndrReq] + Nothing + [ DCon + [bTvb, aTvb, cTvb] + [] + mkT + (DRecC [ ( getT1 + , Bang NoSourceUnpackedness NoSourceStrictness + , bVarT + ) + , ( getT2 + , Bang NoSourceUnpackedness NoSourceStrictness + , cVarT + ) + ]) + res_ty + ] + [] + res_ty = DConT t `DAppT` aVarT `DAppT` bVarT + expected_ty = DForallT (DForallInvis [bTvb, aTvb]) $ + DArrowT `DAppT` res_ty `DAppT` bVarT + + withLocalDeclarations (sweeten [dec]) $ do + Just (DVarI _ actual_ty _) <- dsReify getT1 + expected_ty `eqTHSplice` actual_ty) + +-- Unit tests for tupleNameDegree_maybe. These also act as a regression test for +-- #187. +test_t187 :: [Bool] +test_t187 = + map (\(s, expected) -> tupleNameDegree_maybe s == expected) + [ (''(), Just 0) + , (''(,), Just 2) + , (''(,,), Just 3) + , (''Maybe, Nothing) + , (tupleTypeName 0, Just 0) + , (tupleTypeName 2, Just 2) + , (tupleTypeName 3, Just 3) +#if __GLASGOW_HASKELL__ >= 900 + , (''Solo, Just 1) +#if __GLASGOW_HASKELL__ >= 906 + , ('MkSolo, Just 1) +#else + , ('Solo, Just 1) +#endif +#endif +#if __GLASGOW_HASKELL__ >= 908 + , (''Unit, Just 0) + , (''Tuple0, Just 0) + , (''Tuple1, Just 1) + , (''Tuple2, Just 2) + , (''Tuple3, Just 3) + , (''FakeTuples.Tuple0, Nothing) + , (''FakeTuples.Tuple1, Nothing) + , (''FakeTuples.Tuple2, Nothing) + , (''FakeTuples.Tuple3, Nothing) +#endif + ] + +-- A regression test for #188, which ensures that it produces the correct answer +-- for an unusual telescope like: +-- +-- ... forall (a1 :: a2). forall (a2 :: a1). ... +-- +-- Here, a2 is free in the kind of a1 (the first `forall`), but then the second +-- `forall` binds another a2 that shadows what was already in scope. In this +-- example, `toposortKindVarsOfTvbs [(a1 :: a2), (a2 :: a1)]` should return +-- [a2]. +test_t188 :: Bool +test_t188 = + let a1 = mkName "a1" + a2 = mkName "a2" in + toposortKindVarsOfTvbs [DKindedTV a1 () (DVarT a2), DKindedTV a2 () (DVarT a1)] + == [DPlainTV a2 ()] + +#if __GLASGOW_HASKELL__ >= 900 +-- A regression test for #199, which ensures that a locally reified data +-- constructor is given a type signature that takes into account the fact that +-- its parent data type's standalone kind signature marks `k` as inferred. +test_t199 :: [Bool] +test_t199 = + $(do decs <- [d| type P :: forall {k}. k -> Type + data P (a :: k) = MkP |] + + withLocalDeclarations decs $ do + let k = mkName "k" + a = mkName "a" + kTvb = DPlainTV k InferredSpec + aTvb = DKindedTV a SpecifiedSpec (DVarT k) + p = mkName "P" + mkP = mkName "MkP" + pTy = DConT p `DAppT` DVarT a + mbPInfo <- dsReify p + let b1 = + case mbPInfo of + Just (DTyConI (DDataD _ _ _ _ _ [conActual] _) _) -> + let conExpected = + DCon [kTvb, aTvb] [] mkP (DNormalC False []) pTy in + conExpected `eqTH` conActual + _ -> + False + + mbMkPInfo <- dsReify mkP + let b2 = + case mbMkPInfo of + Just (DVarI _ conTyActual _) -> + let conTyExpected = + DForallT (DForallInvis [kTvb, aTvb]) pTy in + conTyExpected `eqTH` conTyActual + _ -> + False + + [| [b1, b2] |]) +#endif + +-- Unit tests for unboxedTupleNameDegree_maybe and unboxedSumNameDegree_maybe. +-- These also act as a regression test for #213. +test_t213 :: [Bool] +test_t213 = + map (\(s, expected) -> unboxedTupleNameDegree_maybe s == expected) + [ (''(##), Just 0) + , (''(#,#), Just 2) + , (''(#,,#), Just 3) + , (''Maybe, Nothing) +#if __GLASGOW_HASKELL__ >= 802 + , (unboxedTupleTypeName 0, Just 0) +#endif + , (unboxedTupleTypeName 2, Just 2) + , (unboxedTupleTypeName 3, Just 3) +#if __GLASGOW_HASKELL__ >= 910 + , (''Unit#, Just 0) + , (''Tuple0#, Just 0) + , (''Solo#, Just 1) + , (''Tuple1#, Just 1) + , (''Tuple2#, Just 2) + , (''Tuple3#, Just 3) + , (''FakeTuples.Tuple0#, Nothing) + , (''FakeTuples.Tuple1#, Nothing) + , (''FakeTuples.Tuple2#, Nothing) + , (''FakeTuples.Tuple3#, Nothing) +#endif + ] +#if __GLASGOW_HASKELL__ >= 802 + ++ + map (\(s, expected) -> unboxedSumNameDegree_maybe s == expected) + [ (unboxedSumTypeName 2, Just 2) + , (unboxedSumTypeName 3, Just 3) + , (unboxedSumTypeName 4, Just 4) +#if __GLASGOW_HASKELL__ >= 910 + , (''Sum2#, Just 2) + , (''Sum3#, Just 3) + , (''Sum4#, Just 4) + , (''FakeSums.Sum2#, Nothing) + , (''FakeSums.Sum3#, Nothing) + , (''FakeSums.Sum4#, Nothing) +#endif + ] +#endif + +#if __GLASGOW_HASKELL__ >= 900 +-- A regression test for #220, which ensures that a locally reified class method +-- is given a type signature that takes into account the fact that its parent +-- class's standalone kind signature marks `k` as inferred. +test_t220 :: Bool +test_t220 = + $(do decs <- [d| type C :: forall {k}. k -> Constraint + class C (a :: k) where + m :: Proxy a |] + + withLocalDeclarations decs $ do + let k = mkName "k" + a = mkName "a" + kTvb = DPlainTV k InferredSpec + aTvb = DKindedTV a SpecifiedSpec (DVarT k) + c = mkName "C" + m = mkName "m" + cTy = DConT c `DAppT` DVarT a + mbMInfo <- dsReify m + case mbMInfo of + Just (DVarI _ mTyActual _) -> + let mTyExpected = + DForallT (DForallInvis [kTvb, aTvb]) $ + DConstrainedT [cTy] $ + DConT ''Proxy `DAppT` DVarT a in + mTyExpected `eqTHSplice` mTyActual + _ -> + [| False |]) +#endif + +-- A regression test for #228, which ensures that dMatchUpSAKWithDecl behaves +-- as expected on code that looks like this: +-- +-- @ +-- type D :: forall (a :: Type). Type +-- data D +-- @ +test_t228 :: Bool +test_t228 = + let sak = DForallT (DForallInvis [DKindedTV (mkName "a") SpecifiedSpec (DConT ''Type)]) (DConT ''Type) + expected_bndrs = [DKindedTV (mkName "a") (Invisible SpecifiedSpec) (DConT ''Type)] in + case dMatchUpSAKWithDecl sak [] of + Nothing -> False + Just actual_bndrs -> expected_bndrs `eqTH` actual_bndrs + +-- Unit tests for functions that compute free variables (e.g., fvDType) +test_fvs :: [Bool] +test_fvs = + $(do a <- newName "a" + + let -- (Show a => Show (Maybe a)) => String + ty1 = DConstrainedT + [DConstrainedT [DConT ''Show `DAppT` DVarT a] + (DConT ''Show `DAppT` (DConT ''Maybe `DAppT` DVarT a))] + (DConT ''String) + b1 = fvDType ty1 `eqTH` OS.singleton a -- #93 + + [| [b1] |]) + +test_kind_substitution :: [Bool] +test_kind_substitution = + $(do a <- newName "a" + b <- newName "b" + c <- newName "c" + k <- newName "k" + let subst = M.singleton a (DVarT b) + + -- (Nothing :: Maybe a) + ty1 = DSigT (DConT 'Nothing) (DConT ''Maybe `DAppT` DVarT a) + -- forall (c :: a). c + ty2 = DForallT (DForallInvis [DKindedTV c SpecifiedSpec (DVarT a)]) + (DVarT c) + -- forall a (c :: a). c + ty3 = DForallT (DForallInvis [ DPlainTV a SpecifiedSpec + , DKindedTV c SpecifiedSpec (DVarT a) + ]) + (DVarT c) + -- forall (a :: k) k (b :: k). Proxy b -> Proxy a + ty4 = DForallT (DForallInvis + [ DKindedTV a SpecifiedSpec (DVarT k) + , DPlainTV k SpecifiedSpec + , DKindedTV b SpecifiedSpec (DVarT k) + ]) + (DArrowT `DAppT` (DConT ''Proxy `DAppT` DVarT b) + `DAppT` (DConT ''Proxy `DAppT` DVarT a)) + + substTy1 <- substTy subst ty1 + substTy2 <- substTy subst ty2 + substTy3 <- substTy subst ty3 + substTy4 <- substTy subst ty4 + + let freeVars1 = fvDType substTy1 + freeVars2 = fvDType substTy2 + freeVars3 = fvDType substTy3 + freeVars4 = fvDType substTy4 + + b1 = freeVars1 `eqTH` OS.singleton b + b2 = freeVars2 `eqTH` OS.singleton b + b3 = freeVars3 `eqTH` OS.empty + b4 = freeVars4 `eqTH` OS.singleton k + [| [b1, b2, b3, b4] |]) + +test_lookup_value_type_names :: [Bool] +test_lookup_value_type_names = + $(do let nameStr = "***" + valName <- newName nameStr + typeName <- newName nameStr + let tyDec = DTySynD typeName [] (DConT ''Bool) + decs = decsToTH [ DLetDec (DSigD valName (DConT ''Bool)) + , DLetDec (DValD (DVarP valName) (DConE 'False)) + , tyDec ] + lookupReify lookup_fun = withLocalDeclarations decs $ do + Just n <- lookup_fun nameStr + Just i <- dsReify n + return i + reifiedVal <- lookupReify lookupValueNameWithLocals + reifiedType <- lookupReify lookupTypeNameWithLocals + let b1 = reifiedVal `eqTH` DVarI valName (DConT ''Bool) Nothing + let b2 = reifiedType `eqTH` DTyConI tyDec Nothing + [| [b1, b2] |]) + local_reifications :: [String] local_reifications = $(do decs <- reifyDecs m_infos <- withLocalDeclarations decs $ @@ -208,6 +921,14 @@ let m_infos' = assumeStarT m_infos ListE <$> mapM (Syn.lift . show) (unqualify m_infos')) +type T123G = Either () () +type T123F = Either T123G T123G +type T123E = Either T123F T123F +type T123D = Either T123E T123E +type T123C = Either T123D T123D +type T123B = Either T123C T123C +type T123A = Either T123B T123B + $reifyDecs $(return []) -- somehow, this is necessary to get the staging correct for the @@ -216,7 +937,7 @@ normal_reifications :: [String] normal_reifications = $(do infos <- mapM reify reifyDecsNames ListE <$> mapM (Syn.lift . show . Just) - (dropTrailing0s $ unqualify infos)) + (dropTrailing0s $ delinearize $ unqualify infos)) zipWith3M :: Monad m => (a -> b -> c -> m d) -> [a] -> [b] -> [c] -> m [d] zipWith3M f (a:as) (b:bs) (c:cs) = liftM2 (:) (f a b c) (zipWith3M f as bs cs) @@ -240,6 +961,45 @@ let bools = zipWith eqTH ds_exprs2 ds_exprs3 Syn.lift bools ) +test_matchTy :: [Bool] +test_matchTy = + [ matchTy NoIgnore (DVarT a) (DConT ''Bool) == Just (M.singleton a (DConT ''Bool)) + , matchTy NoIgnore (DVarT a) (DVarT a) == Just (M.singleton a (DVarT a)) + , matchTy NoIgnore (DVarT a) (DVarT b) == Just (M.singleton a (DVarT b)) + , matchTy NoIgnore (DConT ''Either `DAppT` DVarT a `DAppT` DVarT b) + (DConT ''Either `DAppT` DConT ''Int `DAppT` DConT ''Bool) + == Just (M.fromList [(a, DConT ''Int), (b, DConT ''Bool)]) + , matchTy NoIgnore (DConT ''Either `DAppT` DVarT a `DAppT` DVarT a) + (DConT ''Either `DAppT` DConT ''Int `DAppT` DConT ''Int) + == Just (M.singleton a (DConT ''Int)) + , matchTy NoIgnore (DConT ''Either `DAppT` DVarT a `DAppT` DVarT a) + (DConT ''Either `DAppT` DConT ''Int `DAppT` DConT ''Bool) + == Nothing + , matchTy NoIgnore (DConT ''Int) (DConT ''Bool) == Nothing + , matchTy NoIgnore (DConT ''Int) (DConT ''Int) == Just M.empty + , matchTy NoIgnore (DConT ''Int) (DVarT a) == Nothing + -- Test `DSigT` with both `IgnoreKinds` options + , matchTy NoIgnore (DVarT a `DSigT` DConT ''Bool) (DConT ''Int) == Nothing + , matchTy YesIgnore (DVarT a `DSigT` DConT ''Bool) (DConT ''Int) + == Just (M.singleton a (DConT ''Int)) + -- Test `DAppKindT` with both `IgnoreKinds` options + , matchTy NoIgnore (DConT ''Proxy `DAppKindT` DConT ''Bool `DAppT` DVarT a) + (DConT ''Proxy `DAppT` DConT ''Int) + == Nothing + , matchTy YesIgnore (DConT ''Proxy `DAppKindT` DConT ''Bool `DAppT` DVarT a) + (DConT ''Proxy `DAppT` DConT ''Int) + == Just (M.singleton a (DConT ''Int)) + ] + where + a = mkName "a" + b = mkName "b" + +-- Test that type synonym expansion is efficient +test_t123 :: () +test_t123 = + $(do _ <- expand (DConT ''T123A) + [| () |]) + main :: IO () main = hspec $ do describe "th-desugar library" $ do @@ -254,10 +1014,6 @@ [inst1, inst2] <- reifyInstances ''Show [ty] inst1 `eqTHSplice` inst2) -#if __GLASGOW_HASKELL__ < 707 - it "passes roles test" $ (decsToTH [ds_role_test]) `eqTH` role_test -#endif - it "makes type names" $ test_mkName it "fixes bug 8884" $ test_bug8884 @@ -268,6 +1024,73 @@ it "works with standalone deriving" $ test_standalone_deriving + it "works with deriving strategies" $ test_deriving_strategies + + it "doesn't expand local type families" $ test_local_tyfam_expansion + + it "doesn't crash on a stuck type family application" $ test_stuck_tyfam_expansion + + it "expands type synonyms in kinds" $ test_t85 + + it "toposorts free variables in polytypes" $ test_t92 + + it "expands type synonyms in type variable binders" $ test_t97 + + it "reifies GADT record selectors correctly" $ test_t100 + + zipWithM (\b n -> it ("collects GADT record selectors correctly" ++ show n) b) + test_t102 [1..] + + it "quantifies kind variables in desugared ADT constructors" $ test_t103 + + it "reifies data type return kinds accurately" $ test_getDataD_kind_sig + + zipWithM (\b n -> it ("toposorts free variables deterministically " ++ show n) b) + test_t112 [1..] + + it "reifies fixity declarations inside of classes" $ test_t132 + +#if __GLASGOW_HASKELL__ >= 801 + zipWithM (\b n -> it ("reifies local pattern synonym record selectors " ++ show n) b) + test_t137 [1..] +#endif + + zipWithM (\b n -> it ("computes free variables correctly " ++ show n) b) + test_fvs [1..] + + it "desugars non-infix GADT constructors with symbolic names correctly" $ test_t154 + + it "desugars non-exhaustive expressions into code that errors at runtime" $ test_t159 + +#if __GLASGOW_HASKELL__ >= 906 + zipWithM (\b n -> it ("looks up TypeData names in the type namespace correctly " ++ show n) b) + test_t170 [1..] +#endif + + it "locally reifies GADT record selector types with explicit foralls correctly" $ test_t171 + + it "doesn't reify a field selector with lookupValueNameWithLocals when NoFieldSelectors is set" $ + t183 == Nothing + + zipWithM (\b n -> it ("recognizes tuple names with tupleDegree_maybe correctly " ++ show n) b) + test_t187 [1..] + + it "computes free kind variables correctly in a telescope that uses shadowing" $ test_t188 + +#if __GLASGOW_HASKELL__ >= 900 + zipWithM (\b n -> it ("correctly reifies the type of a data constructor with an inferred type variable binder " ++ show n) b) + test_t199 [1..] +#endif + + zipWithM (\b n -> it ("recognizes unboxed {tuple,sum} names with unboxed{Tuple,Sum}Degree_maybe correctly " ++ show n) b) + test_t213 [1..] + +#if __GLASGOW_HASKELL__ >= 900 + it "correctly reifies the type of a class method with an inferred type variable binder" $ test_t220 +#endif + + it "correctly matches up an invisible forall without a corresponding @-binder" $ test_t228 + -- Remove map pprints here after switch to th-orphans zipWithM (\t t' -> it ("can do Type->DType->Type of " ++ t) $ t == t') $(sequence round_trip_types >>= Syn.lift . map pprint) @@ -275,11 +1098,29 @@ mapM (\ t -> withLocalDeclarations [] (dsType t >>= expandType >>= return . typeToTH)) >>= Syn.lift . map pprint) - zipWith3M (\a b n -> it ("reifies local definition " ++ show n) $ a == b) - local_reifications normal_reifications [1..] + zipWith3M (\a b nm -> it ("reifies local definition " ++ nameBase nm) $ a == b) + local_reifications normal_reifications reifyDecsNames zipWithM (\b n -> it ("works on simplCase test " ++ show n) b) simplCase [1..] zipWithM (\b n -> it ("round-trip successfully on case " ++ show n) b) test_roundtrip [1..] + + zipWithM (\b n -> it ("lookups up local value and type names " ++ show n) b) + test_lookup_value_type_names [1..] + + zipWithM (\b n -> it ("substitutes tyvar binder kinds " ++ show n) b) + test_kind_substitution [1..] + + zipWithM (\b n -> it ("matches types " ++ show n) b) + test_matchTy [1..] + + zipWithM (\b n -> it ("reifies kinds of declarations with CUSKs " ++ show n) b) + test_reify_type_cusks [1..] + + zipWithM (\b n -> it ("reifies kinds of declarations without CUSKs " ++ show n) b) + test_reify_type_no_cusks [1..] + + zipWithM (\b n -> it ("reifies the kinds of declarations with signatures " ++ show n) b) + test_reify_kind_sigs [1..] fromHUnitTest tests diff --git a/Test/Splices.hs b/Test/Splices.hs --- a/Test/Splices.hs +++ b/Test/Splices.hs @@ -1,7 +1,7 @@ {- Tests for the th-desugar package (c) Richard Eisenberg 2013 -eir@cis.upenn.edu +rae@cs.brynmawr.edu -} {-# LANGUAGE TemplateHaskell, LambdaCase, MagicHash, UnboxedTuples, @@ -9,25 +9,83 @@ ScopedTypeVariables, RankNTypes, TypeFamilies, ImpredicativeTypes, DataKinds, PolyKinds, GADTs, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, StandaloneDeriving, - DefaultSignatures, ConstraintKinds #-} -{-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-type-defaults - -fno-warn-name-shadowing #-} + DefaultSignatures, ConstraintKinds, GADTs, ViewPatterns, + TupleSections, NoMonomorphismRestriction, TypeOperators, + TypeApplications #-} +#if __GLASGOW_HASKELL__ >= 801 +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE UnboxedSums #-} +#endif + +#if __GLASGOW_HASKELL__ >= 803 +{-# LANGUAGE OverloadedLabels #-} +{-# OPTIONS_GHC -Wno-orphans #-} -- IsLabel is an orphan +#endif + +#if __GLASGOW_HASKELL__ >= 805 +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE QuantifiedConstraints #-} +#endif + +#if __GLASGOW_HASKELL__ < 806 +{-# LANGUAGE TypeInType #-} +#endif + +#if __GLASGOW_HASKELL__ >= 807 +{-# LANGUAGE ImplicitParams #-} +#endif + +#if __GLASGOW_HASKELL__ >= 809 +{-# LANGUAGE StandaloneKindSignatures #-} +#endif + +#if __GLASGOW_HASKELL__ >= 900 +{-# LANGUAGE QualifiedDo #-} +#endif + +#if __GLASGOW_HASKELL__ >= 902 +{-# LANGUAGE OverloadedRecordDot #-} +#endif + +#if __GLASGOW_HASKELL__ >= 906 +{-# LANGUAGE TypeData #-} +#endif + +#if __GLASGOW_HASKELL__ >= 907 +{-# LANGUAGE TypeAbstractions #-} +#endif + +#if __GLASGOW_HASKELL__ >= 909 +{-# LANGUAGE RequiredTypeArguments #-} +#endif + +{-# OPTIONS_GHC -Wno-missing-signatures -Wno-type-defaults + -Wno-name-shadowing #-} + module Splices where -import Data.List +import qualified Data.List as L +import qualified Data.List.NonEmpty as NE +import Data.List.NonEmpty (NonEmpty(..)) import Data.Char +import qualified Data.Kind as Kind (Type) import GHC.Exts import GHC.TypeLits import Language.Haskell.TH +import Language.Haskell.TH.Datatype.TyVarBndr import Language.Haskell.TH.Desugar +import Language.Haskell.TH.Syntax (Quasi) import Data.Generics -#if __GLASGOW_HASKELL__ < 707 -data Proxy a = Proxy +#if __GLASGOW_HASKELL__ >= 803 +import GHC.OverloadedLabels ( IsLabel(..) ) #endif +import Prelude as P + dsSplice :: Q Exp -> Q Exp dsSplice expq = expq >>= dsExp >>= (return . expToTH) @@ -40,76 +98,80 @@ regName = mkName $ "Dec.Dec" ++ show n infoDs <- reify dsName infoReg <- reify regName -#if __GLASGOW_HASKELL__ < 707 - eqTHSplice infoDs infoReg -#else rolesDs <- reifyRoles dsName rolesReg <- reifyRoles regName -#if __GLASGOW_HASKELL__ < 711 - eqTHSplice (infoDs, rolesDs) (infoReg, rolesReg) -#else fixityDs <- reifyFixity dsName fixityReg <- reifyFixity regName eqTHSplice (infoDs, rolesDs, fixityDs) (infoReg, rolesReg, fixityReg) -#endif -#endif unqualify :: Data a => a -> a unqualify = everywhere (mkT (mkName . nameBase)) assumeStarT :: Data a => a -> a -#if __GLASGOW_HASKELL__ < 709 -assumeStarT = id -#else -assumeStarT = everywhere (mkT go) +assumeStarT = everywhere (assume_spec_t . assume_vis_t . assume_unit_t) where - go :: TyVarBndr -> TyVarBndr - go (PlainTV n) = KindedTV n StarT - go (KindedTV n k) = KindedTV n (assumeStarT k) + assume_spec_t :: Typeable a => a -> a +#if __GLASGOW_HASKELL__ >= 900 + assume_spec_t = mkT assume_spec + + assume_spec :: TyVarBndrSpec -> TyVarBndrSpec + assume_spec (PlainTV n spec) = KindedTV n spec StarT + assume_spec (KindedTV n spec k) = KindedTV n spec (assumeStarT k) +#else + assume_spec_t = id #endif + assume_vis_t :: Typeable a => a -> a +#if __GLASGOW_HASKELL__ >= 907 + assume_vis_t = mkT assume_vis + + assume_vis :: TyVarBndrVis -> TyVarBndrVis + assume_vis (PlainTV n vis) = KindedTV n vis StarT + assume_vis (KindedTV n vis k) = KindedTV n vis (assumeStarT k) +#else + assume_vis_t = id +#endif + + assume_unit_t :: Typeable a => a -> a + assume_unit_t = mkT assume_unit + + assume_unit :: TyVarBndrUnit -> TyVarBndrUnit + assume_unit = elimTV (\n -> kindedTV n StarT) + (\n k -> kindedTV n (assumeStarT k)) + dropTrailing0s :: Data a => a -> a dropTrailing0s = everywhere (mkT (mkName . frob . nameBase)) where - frob str - | head str == 'r' = str - | head str == 'R' = str - | otherwise = dropWhileEnd isDigit str + frob str = + case str of + 'r':_ -> str + 'R':_ -> str + _ -> L.dropWhileEnd isDigit str +-- Because th-desugar does not support linear types, we must pretend like +-- MulArrowT does not exist for testing purposes. +-- See Note [Gracefully handling linear types] in L.H.TH.Desugar.Core. +delinearize :: Data a => a -> a +delinearize = everywhere (mkT no_mul) + where + no_mul :: Type -> Type +#if __GLASGOW_HASKELL__ >= 900 + no_mul (MulArrowT `AppT` _) = ArrowT +#endif + no_mul t = t + eqTH :: (Data a, Show a) => a -> a -> Bool eqTH a b = show (unqualify a) == show (unqualify b) -eqTHSplice :: (Data a, Show a) => a -> a -> Q Exp -eqTHSplice a b = +eqTHSplice :: (Quasi q, Data a, Show a) => a -> a -> q Exp +eqTHSplice a b = runQ $ if a `eqTH` b then [| True |] else [| False |] --- Note [Annotating list elements] --- --- Type annotations on list elements are needed to satisfy GHC 8.0-rc1, otherwise --- we get errors like: --- --- Test/Run.hs:63:53: error: --- • Couldn't match type ‘Maybe Integer’ with ‘forall a. Maybe a’ --- Expected type: [forall a. Maybe a] --- Actual type: [Maybe Integer] --- • In the second argument of ‘(:)’, namely --- ‘(:) (Just 19) ((:) (Nothing :: Maybe Integer) [])’ --- In the second argument of ‘(:)’, namely --- ‘(:) Nothing ((:) (Just 19) ((:) (Nothing :: Maybe Integer) []))’ --- In the second argument of ‘map’, namely --- ‘(:) --- (Just 1) --- ((:) Nothing ((:) (Just 19) ((:) (Nothing :: Maybe Integer) [])))’ --- --- This is probably a bug in the GHC type checker, but I haven't been able to --- reduce it yet - test1_sections = [| map ((* 3) . (4 +) . (\x -> x * x)) [10, 11, 12] |] test2_lampats = [| (\(Just x) (Left z) -> x + z) (Just 5) (Left 10) |] --- See Note [Annotating list elements] -test3_lamcase = [| foldr (-) 0 (map (\case { Just x -> x ; Nothing -> (-3) }) [Just 1, Nothing :: Maybe Integer, Just 19, Nothing :: Maybe Integer]) |] +test3_lamcase = [| foldr (-) 0 (map (\case { Just x -> x ; Nothing -> (-3) }) [Just 1, Nothing, Just 19, Nothing]) |] test4_tuples = [| (\(a, _) (# b, _ #) -> a + b) (1,2) (# 3, 4 #) |] test5_ifs = [| if (5 > 7) then "foo" else if | Nothing <- Just "bar", True -> "blargh" | otherwise -> "bum" |] test6_ifs2 = [| if | Nothing <- Nothing, False -> 3 | Just _ <- Just "foo" -> 5 |] @@ -117,24 +179,22 @@ test8_case = [| case Just False of { Just True -> 1 ; Just _ -> 2 ; Nothing -> 3 } |] test9_do = [| show $ do { foo <- Just "foo" ; let fool = foo ++ "l" - ; elemIndex 'o' fool - ; x <- elemIndex 'l' fool + ; L.elemIndex 'o' fool + ; x <- L.elemIndex 'l' fool ; return (x + 10) } |] test10_comp = [| [ (x, x+1) | x <- [1..10], x `mod` 2 == 0 ] |] -#if __GLASGOW_HASKELL__ >= 707 test11_parcomp = [| [ (x,y) | x <- [1..10], x `mod` 2 == 0 | y <- [2,5..20] ] |] test12_parcomp2 = [| [ (x,y,z) | x <- [1..10], z <- [3..100], x + z `mod` 2 == 0 | y <- [2,5..20] ] |] -#endif test13_sig = [| show (read "[10, 11, 12]" :: [Int]) |] data Record = MkRecord1 { field1 :: Bool, field2 :: Int } | MkRecord2 { field2 :: Int, field3 :: Char } -test14_record = [| let r1 = [MkRecord1 { field2 = 5, field1 = False }, MkRecord2 { field2 = 6, field3 = 'q' }] - r2 = map (\r -> r { field2 = 18 }) r1 - r3 = (head r2) { field1 = True } in - map (\case MkRecord1 { field2 = some_int, field1 = some_bool } -> show some_int ++ show some_bool - MkRecord2 { field2 = some_int, field3 = some_char } -> show some_int ++ show some_char) (r3 : r2) |] +test14_record = [| let r1 = MkRecord1 { field2 = 5, field1 = False } :| [MkRecord2 { field2 = 6, field3 = 'q' }] + r2 = fmap (\r -> r { field2 = 18 }) r1 + r3 = (NE.head r2) { field1 = True } in + fmap (\case MkRecord1 { field2 = some_int, field1 = some_bool } -> show some_int ++ show some_bool + MkRecord2 { field2 = some_int, field3 = some_char } -> show some_int ++ show some_char) (NE.cons r3 r2) |] test15_litp = [| map (\case { 5 -> True ; _ -> False }) [5,6] |] test16_tupp = [| map (\(x,y,z) -> x + y + z) [(1,2,3),(4,5,6)] |] @@ -143,28 +203,25 @@ deriving (Show, Eq) test17_infixp = [| map (\(x :+: y) -> if y then x + 1 else x - 1) [5 :+: True, 10 :+: False] |] --- See Note [Annotating list elements] -test18_tildep = [| map (\ ~() -> Nothing :: Maybe Int) [undefined :: (), ()] |] +test18_tildep = [| map (\ ~() -> Nothing :: Maybe Int) [undefined, ()] |] test19_bangp = [| map (\ !() -> 5) [()] |] test20_asp = [| map (\ a@(b :+: c) -> (if c then b + 1 else b - 1, a)) [5 :+: True, 10 :+: False] |] test21_wildp = [| zipWith (\_ _ -> 10) [1,2,3] ['a','b','c'] |] test22_listp = [| map (\ [a,b,c] -> a + b + c) [[1,2,3],[4,5,6]] |] --- type signatures in patterns not yet handled by Template Haskell --- test23_sigp = [| map (\ (a :: Int) -> a + a) [5, 10] |] +#if __GLASGOW_HASKELL__ >= 801 +test23_sigp = [| map (\ (a :: Int) -> a + a) [5, 10] |] +#endif --- See Note [Annotating list elements] -test24_fun = [| let f :: Maybe (Maybe a) -> Maybe a - f (Just x) = x +test24_fun = [| let f (Just x) = x f Nothing = Nothing in f (Just (Just 10)) |] --- See Note [Annotating list elements] test25_fun2 = [| let f (Just x) | x > 0 = x | x < 0 = x + 10 f Nothing = 0 f _ = 18 in - map f [Just (-5), Just 5, Just 10, Nothing :: Maybe Integer, Just 0] |] + map f [Just (-5), Just 5, Just 10, Nothing, Just 0] |] test26_forall = [| let f :: Num a => a -> a f x = x + 10 in @@ -176,41 +233,262 @@ test28_tupt = [| let f :: (a,b) -> a f (a,_) = a in map f [(1,'a'),(2,'b')] |] -test29_listt = [| let f :: [[a]] -> a - f = head . head in +test29_listt = [| let f :: [[Int]] -> [[Int]] + f = map (map (+1)) in map f [ [[1]], [[2]] ] |] test30_promoted = [| let f :: Proxy '() -> Proxy '[Int, Bool] -> () f _ _ = () in f Proxy Proxy |] -test31_constraint = [| let f :: Proxy (c :: * -> Constraint) -> () +test31_constraint = [| let f :: Proxy (c :: Kind.Type -> Constraint) -> () f _ = () in [f (Proxy :: Proxy Eq), f (Proxy :: Proxy Show)] |] test32_tylit = [| let f :: Proxy (a :: Symbol) -> Proxy (b :: Nat) -> () f _ _ = () in f (Proxy :: Proxy "Hi there!") (Proxy :: Proxy 10) |] -test33_tvbs = [| let f :: forall a (b :: * -> *). Monad b => a -> b a +test33_tvbs = [| let f :: forall a (b :: Kind.Type -> Kind.Type). Monad b => a -> b a f = return in [f 1, f 2] :: [Maybe Int] |] -test34_let_as = [| let a@(Just x) = Just 5 in - show x ++ show a |] +test34_let_as = [| let a@(x, y) = (5, 6) in + show x ++ show y ++ show a |] type Pair a = (a, a) test35_expand = [| let f :: Pair a -> a f = fst in f |] -type Const a b = b -test36_expand = [| let f :: Const Int (,) Bool Char -> Char +type Constant a b = b +test36_expand = [| let f :: Constant Int (,) Bool Char -> Char f = snd in f |] -#if __GLASGOW_HASKELL__ >= 711 test40_wildcards = [| let f :: (Show a, _) => a -> a -> _ f x y = if x == y then show x else "bad" in f True False :: String |] + +#if __GLASGOW_HASKELL__ >= 801 +test41_typeapps = [| let f :: forall a. (a -> Bool) -> Bool + f g = g (undefined @_ @a) in + f (const True) |] + +test42_scoped_tvs = [| let f :: (Read a, Show a) => a -> String -> String + f (_ :: b) (x :: String) = show (read x :: b) + in f True "True" |] + +test43_ubx_sums = [| let f :: (# Bool | String #) -> Bool + f (# b | #) = not b + f (# | c #) = c == "c" in + f (# | "a" #) |] #endif +test44_let_pragma = [| let x :: Int + x = 1 + {-# INLINE x #-} + in x |] + +test45_empty_record_con = [| let j :: Maybe Int + j = Just{} + in case j of + Nothing -> j + Just{} -> j |] + +#if __GLASGOW_HASKELL__ >= 803 +data Label (l :: Symbol) = Get + +class Has a l b | a l -> b where + from :: a -> Label l -> b + +data Point = Point Int Int deriving Show + +instance Has Point "x" Int where from (Point x _) _ = x +instance Has Point "y" Int where from (Point _ y) _ = y + +instance Has a l b => IsLabel l (a -> b) where + fromLabel x = from x (Get :: Label l) + +test46_overloaded_label = [| let p = Point 3 4 in + #x p - #y p |] +#endif + +test47_do_partial_match = [| do { Just () <- [Nothing]; return () } |] + +#if __GLASGOW_HASKELL__ >= 805 +test48_quantified_constraints = + [| let f :: forall f a. (forall x. Eq x => Eq (f x), Eq a) => f a -> f a -> Bool + f = (==) + in f (Proxy @Int) (Proxy @Int) |] +#endif + +#if __GLASGOW_HASKELL__ >= 807 +test49_implicit_params = [| let f :: (?x :: Int, ?y :: Int) => (Int, Int) + f = + let ?x = ?y + ?y = ?x + in (?x, ?y) + in (let ?x = 42 + ?y = 27 + in f) |] + +test50_vka = [| let hrefl :: (:~~:) @Bool @Bool 'True 'True + hrefl = HRefl + in hrefl |] +#endif + +#if __GLASGOW_HASKELL__ >= 809 +test51_tuple_sections = + [| let f1 :: String -> Char -> (String, Int, Char) + f1 = (,5,) + + f2 :: String -> Char -> (# String, Int, Char #) + f2 = (#,5,#) + in case (#,#) (f1 "a" 'a') (f2 "b" 'b') of + (#,#) ((,,) _ a _) ((#,,#) _ b _) -> a + b |] +#endif + +#if __GLASGOW_HASKELL__ >= 900 +test52_qual_do = + [| P.do x <- [1, 2] + y@1 <- [x] + [1, 2] + P.return y |] +#endif + +#if __GLASGOW_HASKELL__ >= 901 +test53_vta_in_con_pats = + [| let f :: Maybe Int -> Int + f (Just @Int x) = x + f (Nothing @Int) = 42 + in f (Just @Int 27) |] +#endif + +#if __GLASGOW_HASKELL__ >= 902 +data ORD1 = MkORD1 { unORD1 :: Int } +data ORD2 = MkORD2 { unORD2 :: ORD1 } + +test54_overloaded_record_dot = + [| let ord1 :: ORD1 + ord1 = MkORD1 1 + + ord2 :: ORD2 + ord2 = MkORD2 ord1 + + in (ord2.unORD2.unORD1, (.unORD2.unORD1) ord2) |] +#endif + +#if __GLASGOW_HASKELL__ >= 903 +test55_opaque_pragma = + [| let f :: String -> String + f x = x + {-# OPAQUE f #-} + in f "Hello, World!" |] + +test56_lambda_cases = + [| (\cases (Just x) (Just y) -> x ++ y + _ _ -> "") (Just "Hello") (Just "World") |] +#endif + +#if __GLASGOW_HASKELL__ >= 907 +test57_typed_th_bracket = + typedBracketE [| 'x' |] + +test58_typed_th_splice = + typedSpliceE (typedBracketE [| 'y' |]) +#endif + +#if __GLASGOW_HASKELL__ >= 909 +test59_embedded_types_keyword = + [| let idv :: forall a -> a -> a + idv (type a) (x :: a) = x :: a + + in idv (type Bool) True |] + +test60_embedded_types_no_keyword = + [| let idv :: forall a -> a -> a + idv a (x :: a) = x :: a + + in idv Bool True |] + +test61_invis_type_pat = + [| let f :: a -> a + f @a = id @a + + in f @Bool True |] + +test62_embedded_types_lambda_keyword = + [| let idv :: forall a -> a -> a + idv = \(type a) (x :: a) -> x :: a + + in idv (type Bool) True |] + +test63_embedded_types_case_keyword = + [| let idv :: forall a -> a -> a + idv = \case + (type a) -> id @a + + in idv (type Bool) True |] + +test64_embedded_types_cases_keyword = + [| let idv :: forall a -> a -> a + idv = \cases + (type a) (x :: a) -> x :: a + + in idv (type Bool) True |] + +test65_embedded_types_lambda_no_keyword = + [| let idv :: forall a -> a -> a + idv = \a (x :: a) -> x :: a + + in idv Bool True |] + +test66_embedded_types_case_no_keyword = + [| let idv :: forall a -> a -> a + idv = \case + a -> id @a + + in idv Bool True |] + +test67_embedded_types_cases_no_keyword = + [| let idv :: forall a -> a -> a + idv = \cases + a (x :: a) -> x :: a + + in idv Bool True |] + +aux :: (forall a. a -> a) -> (forall a. a -> a) +aux f x = f x + +test68_invis_type_pat_lambda = + [| aux (\ @a (x :: a) -> x :: a) @Bool True |] + +test69_invis_type_pat_cases = + [| aux (\cases @a (x :: a) -> x :: a) @Bool True |] +#endif + +#if __GLASGOW_HASKELL__ >= 911 +test70_embedded_forall_invis = + [| let idv :: forall a -> a -> a + idv _ x = x + in idv (forall a. a -> a) id True |] + +test71_embedded_forall_vis = + [| let idv :: forall a -> a -> a + idv _ x = x + in idv (forall a -> a -> a) idv Bool True |] + +test72_embedded_constraint = + [| let idv :: forall a -> a -> a + idv _ x = x + in idv (forall a. (a ~ Bool) => a -> a) (\x -> not x) False |] +#endif + +#if __GLASGOW_HASKELL__ >= 913 +test73_specialise_exp_pragma = + [| let {-# SPECIALISE f @() #-} + f :: forall a. Show a => a -> String + f = show + in f () |] +#endif + type family TFExpand x type instance TFExpand Int = Bool type instance TFExpand (Maybe a) = [a] @@ -221,7 +499,6 @@ f [True, False] = () in f |] -#if __GLASGOW_HASKELL__ >= 707 type family ClosedTF a where ClosedTF Int = Bool ClosedTF x = Char @@ -233,8 +510,11 @@ f 'x' = () in f |] -type family PolyTF (x :: k) :: * where - PolyTF (x :: *) = Bool +#if __GLASGOW_HASKELL__ >= 809 +type PolyTF :: forall k. k -> Kind.Type +#endif +type family PolyTF (x :: k) :: Kind.Type where + PolyTF (x :: Kind.Type) = Bool test_expand7 = [| let f :: PolyTF Int -> () f True = () in @@ -243,9 +523,18 @@ f True = () in f |] -#endif -#if __GLASGOW_HASKELL__ >= 709 +test_expand9 = [| let f :: TFExpand (Maybe (IO a)) -> IO () + f actions = sequence_ actions in + f |] + +type family TFExpandClosed a where + TFExpandClosed (Maybe a) = [a] + +test_expand10 = [| let f :: TFExpandClosed (Maybe (IO a)) -> IO () + f actions = sequence_ actions in + f |] + test37_pred = [| let f :: (Read a, (Show a, Num a)) => a -> a f x = read (show x) + x in (f 3, f 4.5) |] @@ -257,60 +546,40 @@ test39_eq = [| let f :: (a ~ b) => a -> b f x = x in (f ()) |] -#endif -#if __GLASGOW_HASKELL__ < 707 -dec_test_nums = [1..9] :: [Int] -#elif __GLASGOW_HASKELL__ < 709 -dec_test_nums = [1..10] :: [Int] -#else dec_test_nums = [1..11] :: [Int] -#endif -dectest1 = [d| data Dec1 = Foo | Bar Int |] -dectest2 = [d| data Dec2 a = forall b. (Show b, Eq a) => MkDec2 a b Bool |] -dectest3 = [d| data Dec3 a = forall b. MkDec3 { foo :: a, bar :: b } -#if __GLASGOW_HASKELL__ >= 707 +dectest1 = [d| data Dec1 where + Foo :: Dec1 + Bar :: Int -> Dec1 |] +dectest2 = [d| data Dec2 a where + MkDec2 :: forall a b. (Show b, Eq a) => a -> b -> Bool -> Dec2 a |] +dectest3 = [d| data Dec3 a where + MkDec3 :: forall a b. { foo :: a, bar :: b } -> Dec3 a type role Dec3 nominal -#endif |] -dectest4 = [d| newtype Dec4 a = MkDec4 (a, Int) |] +dectest4 = [d| newtype Dec4 a where + MkDec4 :: (a, Int) -> Dec4 a |] dectest5 = [d| type Dec5 a b = (a b, Maybe b) |] -dectest6 = [d| class (Monad m1, Monad m2) => Dec6 (m1 :: * -> *) m2 | m1 -> m2 where +dectest6 = [d| class (Monad m1, Monad m2) => Dec6 (m1 :: Kind.Type -> Kind.Type) m2 | m1 -> m2 where lift :: forall a. m1 a -> m2 a - type M2 m1 :: * -> * |] -dectest7 = [d| type family Dec7 a (b :: *) (c :: Bool) :: * -> * |] + type M2 m1 :: Kind.Type -> Kind.Type |] +dectest7 = [d| type family Dec7 a (b :: Kind.Type) (c :: Bool) :: Kind.Type -> Kind.Type |] dectest8 = [d| type family Dec8 a |] -dectest9 = [d| data family Dec9 a (b :: * -> *) :: * -> * |] -#if __GLASGOW_HASKELL__ < 707 -ds_dectest10 = DClosedTypeFamilyD - (DTypeFamilyHead - (mkName "Dec10") - [DPlainTV (mkName "a")] - (DKindSig (DAppT (DAppT DArrowT DStarT) DStarT)) - Nothing) - [ DTySynEqn [DConT ''Int] (DConT ''Maybe) - , DTySynEqn [DConT ''Bool] (DConT ''[]) ] -dectest10 = [d| type family Dec10 a :: * -> * - type instance Dec10 Int = Maybe - type instance Dec10 Bool = [] |] - -ds_role_test = DRoleAnnotD (mkName "Dec3") [NominalR] -role_test = [] -#else -dectest10 = [d| type family Dec10 a :: * -> * where +dectest9 = [d| data family Dec9 a (b :: Kind.Type -> Kind.Type) :: Kind.Type -> Kind.Type |] +dectest10 = [d| type family Dec10 a :: Kind.Type -> Kind.Type where Dec10 Int = Maybe Dec10 Bool = [] |] -#endif data Blarggie a = MkBlarggie Int a -#if __GLASGOW_HASKELL__ >= 709 dectest11 = [d| class Dec11 a where meth13 :: a -> a -> Bool default meth13 :: Eq a => a -> a -> Bool meth13 = (==) |] standalone_deriving_test = [d| deriving instance Eq a => Eq (Blarggie a) |] +#if __GLASGOW_HASKELL__ >= 801 +deriv_strat_test = [d| deriving stock instance Ord a => Ord (Blarggie a) |] #endif dectest12 = [d| data Dec12 a where @@ -319,10 +588,75 @@ |] -dectest13 = [d| data Dec13 :: (* -> Constraint) -> * where +dectest13 = [d| data Dec13 :: (Kind.Type -> Constraint) -> Kind.Type where MkDec13 :: c a => a -> Dec13 c |] +dectest14 = [d| data InfixADT = Int `InfixADT` Int |] + +dectest15 = [d| infixl 5 :**:, :&&:, :^^:, `ActuallyPrefix` + data InfixGADT a where + (:**:) :: Int -> b -> InfixGADT (Maybe b) -- Only this one is infix + (:&&:) :: { infixGADT1 :: b, infixGADT2 :: Int } -> InfixGADT [b] + ActuallyPrefix :: Char -> Bool -> InfixGADT Double + (:^^:) :: Int -> Int -> Int -> InfixGADT Int + (:!!:) :: Char -> Char -> InfixGADT Char |] + +class ExCls a +data ExData1 a +data ExData2 a + +-- ds_dectest{16,17} demonstrate instance declarations with outermost foralls, +-- a feature which Template Haskell itself does not yet support (see #151). +-- For this reason, the closest we can get to this in TH is to construct +-- equivalent Decs, dectest{16,17}, that drop the outermost foralls. The test +-- suite ensures that this process happens automatically during sweetening by +-- checking that the sweetened versions of ds_dectest{16,17} equal +-- dectest{16,17}. + +ds_dectest16 = DInstanceD Nothing (Just [DPlainTV (mkName "a") ()]) [] + (DConT ''ExCls `DAppT` + (DConT ''ExData1 `DAppT` DVarT (mkName "a"))) [] +dectest16 :: Q [Dec] +dectest16 = return [ InstanceD + Nothing + [] (ConT ''ExCls `AppT` + (ConT ''ExData1 `AppT` VarT (mkName "a"))) [] ] +ds_dectest17 = DStandaloneDerivD Nothing (Just [DPlainTV (mkName "a") ()]) [] + (DConT ''ExCls `DAppT` + (DConT ''ExData2 `DAppT` DVarT (mkName "a"))) +dectest17 :: Q [Dec] +dectest17 = return [ StandaloneDerivD +#if __GLASGOW_HASKELL__ >= 802 + Nothing +#endif + [] (ConT ''ExCls `AppT` + (ConT ''ExData2 `AppT` VarT (mkName "a"))) ] + +#if __GLASGOW_HASKELL__ >= 809 +dectest18 = [d| data Dec18 :: forall k -> k -> Kind.Type where + MkDec18 :: forall k (a :: k). Dec18 k a |] +#endif + +#if __GLASGOW_HASKELL__ >= 907 +dectest19 = [d| type Dec19 :: forall k. k -> Kind.Type + data Dec19 @k (a :: k) = MkDec19 k (Proxy a) |] +#endif + +#if __GLASGOW_HASKELL__ >= 909 +dectest20 = [d| infixr 3 data !@# + infixr 3 type !@# + + (!@#) :: Bool -> Bool -> Bool + (!@#) = (&&) + + type family (!@#) :: Bool -> Bool -> Bool |] + +dectest21 = [d| {-# SCC dec21 "dec21" #-} + dec21 :: a -> a + dec21 x = x |] +#endif + instance_test = [d| instance (Show a, Show b) => Show (a -> b) where show _ = "function" |] @@ -332,45 +666,43 @@ lift (Just x) = Right x type M2 Maybe = Either () |] -data family Dec9 a (b :: * -> *) :: * -> * -imp_inst_test2 = [d| data instance Dec9 Int Maybe a = MkIMB [a] | forall b. MkIMB2 (b a) |] -imp_inst_test3 = [d| newtype instance Dec9 Bool m x = MkBMX (m x) |] +data family Dec9 a (b :: Kind.Type -> Kind.Type) :: Kind.Type -> Kind.Type +imp_inst_test2 = [d| data instance Dec9 Int Maybe a where + MkIMB :: [a] -> Dec9 Int Maybe a + MkIMB2 :: forall a b. b a -> Dec9 Int Maybe a |] +imp_inst_test3 = [d| newtype instance Dec9 Bool m x where + MkBMX :: m x -> Dec9 Bool m x |] type family Dec8 a imp_inst_test4 = [d| type instance Dec8 Int = Bool |] -- used for bug8884 test -type family Poly (a :: k) :: * +type family Poly (a :: k) :: Kind.Type type instance Poly x = Int flatten_dvald_test = [| let (a,b,c) = ("foo", 4, False) in show a ++ show b ++ show c |] -rec_sel_test = [d| data RecordSel a = forall b. (Show a, Eq b) => +rec_sel_test = [d| data RecordSel a = Show a => MkRecord { recsel1 :: (Int, a) - , recsel_naughty :: (a, b) - , recsel2 :: (forall b. b -> a) - , recsel3 :: Bool } - | MkRecord2 { recsel4 :: (a, a) } |] -rec_sel_test_num_sels = 4 :: Int -- exclude naughty one + , recsel2 :: (forall b. b -> a) + , recsel3 :: Bool } + | MkRecord2 { recsel3 :: Bool + , recsel4 :: (a, a) } |] +rec_sel_test_num_sels = 4 :: Int testRecSelTypes :: Int -> Q Exp testRecSelTypes n = do -#if __GLASGOW_HASKELL__ > 710 VarI _ ty1 _ <- reify (mkName ("DsDec.recsel" ++ show n)) VarI _ ty2 _ <- reify (mkName ("Dec.recsel" ++ show n)) -#else - VarI _ ty1 _ _ <- reify (mkName ("DsDec.recsel" ++ show n)) - VarI _ ty2 _ _ <- reify (mkName ("Dec.recsel" ++ show n)) -#endif let ty1' = return $ unqualify ty1 ty2' = return $ unqualify ty2 [| let x :: $ty1' - x = undefined + x _ = undefined y :: $ty2' - y = undefined + y _ = undefined in - $(return $ VarE $ mkName "hasSameType") x y |] + $(return $ VarE $ mkName "hasSameType") (\d -> x d) (\d -> y d) |] -- used for expand @@ -378,13 +710,20 @@ reifyDecs :: Q [Dec] reifyDecs = [d| - r1 :: a -> a + -- NB: Use a forall here! If you don't, when you splice r1 in and then reify + -- it, GHC will add an explicit forall behind the scenes, which will cause an + -- incongruity with the locally reified declaration (which would lack an + -- explicit forall). + r1 :: forall a. a -> a r1 x = x class R2 a b where r3 :: a -> b -> c -> a - type R4 b a :: * - data R5 a :: * + type R4 b a :: Kind.Type + -- Only define this on GHC 8.0 or later, since TH had trouble quoting + -- associated type family defaults before then. + type R4 b a = Either a b + data R5 a :: Kind.Type data R6 a = R7 { r8 :: a -> a, r9 :: Bool } @@ -393,9 +732,9 @@ type R4 a (R6 a) = a data R5 (R6 a) = forall b. Show b => R10 { r11 :: a, naughty :: b } - type family R12 a b :: * + type family R12 a b :: Kind.Type - data family R13 a :: * + data family R13 a :: Kind.Type data instance R13 Int = R14 { r15 :: Bool } @@ -405,27 +744,114 @@ newtype R18 = R19 Bool type R20 = Bool -#if __GLASGOW_HASKELL__ >= 707 - type family R21 (a :: k) (b :: k) :: k where R21 a b = b + type family R21 (a :: k) (b :: k) :: k where +#if __GLASGOW_HASKELL__ >= 801 +#if __GLASGOW_HASKELL__ >= 807 + forall k (a :: k) (b :: k). #endif + R21 (a :: k) (b :: k) = b +#else + -- Due to GHC Trac #12646, R21 will get reified without kind signatures on + -- a and b on older GHCs, so we must reflect that here. + R21 a b = b +#endif class XXX a where r22 :: a -> a r22 = id -- test #32 + data R23 a = MkR23 { getR23 :: a } + + r23Test :: R23 a -> a + r23Test (MkR23 { getR23 = x }) = x + +#if __GLASGOW_HASKELL__ >= 801 + pattern Point :: Int -> Int -> (Int, Int) + pattern Point{x, y} = (x, y) + + data T a where + MkT :: Eq b => a -> b -> T a + + foo :: Show a => a -> Bool + foo x = show x == "foo" + + pattern P :: Show a => Eq b => b -> T a + pattern P x <- MkT (foo -> True) x + + pattern HeadC :: a -> [a] + pattern HeadC x <- x:_ where + HeadC x = [x] + + class LL f where + llMeth :: f a -> () + + instance LL [] where + llMeth _ = () + + pattern LLMeth :: LL f => f a + pattern LLMeth <- (llMeth -> ()) + + {-# COMPLETE LLMeth :: [] #-} + + llEx :: [a] -> Int + llEx LLMeth = 5 +#endif + +#if __GLASGOW_HASKELL__ >= 805 + newtype Id a = MkId a + deriving stock Eq + + newtype R24 a = MkR24 [a] + deriving Eq via (Id [a]) +#endif + + class R25 (f :: k -> Kind.Type) where + r26 :: forall (a :: k). f a + + data R27 (a :: k) = R28 { r29 :: Proxy a } + + class R30 a where + r31 :: a -> b -> a + +#if __GLASGOW_HASKELL__ >= 809 + type R32 :: forall k -> k -> Kind.Type + type family R32 :: forall k -> k -> Kind.Type where +#endif + + data R33 a where + R34 :: { r35 :: Int } -> R33 Int + +#if __GLASGOW_HASKELL__ >= 906 + type data R36 a = R37 a + type data R38 a where + R39 :: forall a. a -> R38 a +#endif + + -- A regression test for #184 + data family x ^^^ y + data instance x ^^^ y = R40 x y + + -- A regression test for #188 + data R41 a (x :: Maybe a) = R42 |] reifyDecsNames :: [Name] reifyDecsNames = map mkName [ "r1" -#if __GLASGOW_HASKELL__ < 711 - , "R2", "r3" -- these fail due to GHC#11797 -#endif , "R4", "R5", "R6", "R7", "r8", "r9", "R10", "r11" , "R12", "R13", "R14", "r15", "r16", "r17", "R18", "R19", "R20" -#if __GLASGOW_HASKELL__ >= 707 , "R21" -#endif , "r22" + , "R25", "r26", "R28", "r29" + , "R30", "r31" +#if __GLASGOW_HASKELL__ >= 809 + , "R32" +#endif + , "R33", "R34", "r35" +#if __GLASGOW_HASKELL__ >= 906 + , "R36", "R37", "R38", "R39" +#endif + , "R40" + , "R41", "R42" ] simplCaseTests :: [Q Exp] @@ -436,6 +862,11 @@ |] , [| let foo [] = True foo _ = False in (foo [], foo "hi") |] +#if __GLASGOW_HASKELL__ >= 801 + , [| let foo ([] :: String) = True + foo (_ :: String) = False + in foo "hello" |] +#endif ] -- These foralls are needed because of bug trac9262, fixed in ghc-7.10. @@ -456,10 +887,8 @@ , test8_case , test9_do , test10_comp -#if __GLASGOW_HASKELL__ >= 707 , test11_parcomp , test12_parcomp2 -#endif , test13_sig , test14_record , test15_litp @@ -470,6 +899,9 @@ , test20_asp , test21_wildp , test22_listp +#if __GLASGOW_HASKELL__ >= 801 + , test23_sigp +#endif , test24_fun , test25_fun2 , test26_forall @@ -481,9 +913,66 @@ , test32_tylit , test33_tvbs , test34_let_as -#if __GLASGOW_HASKELL__ >= 709 , test37_pred , test38_pred2 , test39_eq +#if __GLASGOW_HASKELL__ >= 801 + , test41_typeapps + , test42_scoped_tvs + , test43_ubx_sums +#endif + , test44_let_pragma + , test45_empty_record_con +#if __GLASGOW_HASKELL__ >= 803 + , test46_overloaded_label +#endif + , test47_do_partial_match +#if __GLASGOW_HASKELL__ >= 805 + , test48_quantified_constraints +#endif +#if __GLASGOW_HASKELL__ >= 807 + , test49_implicit_params + , test50_vka +#endif +#if __GLASGOW_HASKELL__ >= 809 + , test51_tuple_sections +#endif +#if __GLASGOW_HASKELL__ >= 900 + , test52_qual_do +#endif +#if __GLASGOW_HASKELL__ >= 901 + , test53_vta_in_con_pats +#endif +#if __GLASGOW_HASKELL__ >= 902 + , test54_overloaded_record_dot +#endif +#if __GLASGOW_HASKELL__ >= 903 + , test55_opaque_pragma + , test56_lambda_cases +#endif +#if __GLASGOW_HASKELL__ >= 907 + , test57_typed_th_bracket + , test58_typed_th_splice +#endif +#if __GLASGOW_HASKELL__ >= 909 + , test59_embedded_types_keyword + , test60_embedded_types_no_keyword + , test61_invis_type_pat + , test62_embedded_types_lambda_keyword + , test63_embedded_types_case_keyword + , test64_embedded_types_cases_keyword + , test65_embedded_types_lambda_no_keyword + , test66_embedded_types_case_no_keyword + , test67_embedded_types_cases_no_keyword + , test68_invis_type_pat_lambda + , test69_invis_type_pat_cases +#endif +#if __GLASGOW_HASKELL__ >= 911 + , test70_embedded_forall_invis + , test71_embedded_forall_vis + , test72_embedded_constraint +#endif +#if __GLASGOW_HASKELL__ >= 913 + , test73_specialise_exp_pragma #endif ] diff --git a/Test/T158Exp.hs b/Test/T158Exp.hs new file mode 100644 --- /dev/null +++ b/Test/T158Exp.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-incomplete-patterns #-} + +-- | A regression test for #158 which ensures that lambda expressions +-- containing patterns with unlifted types desugar as expected. We define this +-- test in its own module, without UnboxedTuples enabled, to ensure that users +-- do not have to enable the extension themselves. +module T158Exp where + +import Language.Haskell.TH.Desugar + +t158 :: () +t158 = + $([| (\27# 42# -> ()) 27# 42# |] >>= dsExp >>= return . expToTH) diff --git a/Test/T159Decs.hs b/Test/T159Decs.hs new file mode 100644 --- /dev/null +++ b/Test/T159Decs.hs @@ -0,0 +1,20 @@ +{-# OPTIONS_GHC -Wno-incomplete-patterns #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} + +-- | Defines two non-exhaustive functions that roundtrip through desugaring +-- and sweetening. Both of these functions should desugar to definitions that +-- throw a runtime exception before forcing their argument. +-- +-- Because these functions are non-exhaustive (and therefore emit warnings), we +-- put them in their own module so that we can disable the appropriate warnings +-- without needing to disable the warnings globally. +module T159Decs + ( t159A, t159B + ) where + +import Splices ( dsDecSplice ) + +$(dsDecSplice [d| t159A, t159B :: () -> IO () + t159A x | False = return () + t159B x = case x of y | False -> return () + |]) 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,17 +1,31 @@ name: th-desugar -version: 1.6 +version: 1.19 cabal-version: >= 1.10 synopsis: Functions to desugar Template Haskell -homepage: http://www.cis.upenn.edu/~eir/packages/th-desugar +homepage: https://github.com/goldfirere/th-desugar category: Template Haskell -author: Richard Eisenberg -maintainer: Richard Eisenberg +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.8 + , GHC == 9.4.8 + , GHC == 9.6.7 + , GHC == 9.8.4 + , GHC == 9.10.3 + , GHC == 9.12.2 + , GHC == 9.14.1 description: This package provides the Language.Haskell.TH.Desugar module, which desugars Template Haskell's rich encoding of Haskell syntax into a simpler encoding. @@ -26,49 +40,71 @@ source-repository this type: git location: https://github.com/goldfirere/th-desugar.git - tag: v1.6 + tag: v1.10 +source-repository head + type: git + location: https://github.com/goldfirere/th-desugar.git + branch: master + library build-depends: - base >= 4 && < 5, - template-haskell, + base >= 4.9 && < 5, + ghc-prim, + template-haskell >= 2.11 && < 2.25, containers >= 0.5, - mtl >= 2.1, + mtl >= 2.1 && < 2.4, + ordered-containers >= 0.2.2, syb >= 0.4, - th-lift >= 0.6.1, - th-orphans >= 0.9.1, - th-expand-syns >= 0.3.0.6 + th-abstraction >= 0.6 && < 0.8, + th-compat >= 0.1 && < 0.2, + th-orphans >= 0.13.11, + transformers-compat >= 0.6.3 default-extensions: TemplateHaskell - exposed-modules: Language.Haskell.TH.Desugar, - Language.Haskell.TH.Desugar.Sweeten, - Language.Haskell.TH.Desugar.Lift, + exposed-modules: Language.Haskell.TH.Desugar Language.Haskell.TH.Desugar.Expand - other-modules: Language.Haskell.TH.Desugar.Core, - Language.Haskell.TH.Desugar.Match, - Language.Haskell.TH.Desugar.Util, + Language.Haskell.TH.Desugar.Lift + Language.Haskell.TH.Desugar.OMap + Language.Haskell.TH.Desugar.OMap.Strict + Language.Haskell.TH.Desugar.OSet + Language.Haskell.TH.Desugar.Subst + Language.Haskell.TH.Desugar.Subst.Capturing + Language.Haskell.TH.Desugar.Sweeten + other-modules: Language.Haskell.TH.Desugar.AST + Language.Haskell.TH.Desugar.Core + Language.Haskell.TH.Desugar.FV + Language.Haskell.TH.Desugar.Match Language.Haskell.TH.Desugar.Reify + Language.Haskell.TH.Desugar.Util default-language: Haskell2010 ghc-options: -Wall test-suite spec type: exitcode-stdio-1.0 - ghc-options: -Wall -main-is Run + ghc-options: -Wall default-language: Haskell2010 default-extensions: TemplateHaskell hs-source-dirs: Test main-is: Run.hs - other-modules: Splices, Dec, DsDec + other-modules: Dec + DsDec + FakeSums + FakeTuples + ReifyTypeCUSKs + ReifyTypeSigs + Splices + T158Exp + T159Decs + T183 build-depends: base >= 4 && < 5, + ghc-prim, template-haskell, containers >= 0.5, - mtl >= 2.1, syb >= 0.4, HUnit >= 1.2, hspec >= 1.3, - th-desugar, - th-lift >= 0.6.1, - th-orphans >= 0.9.1, - th-expand-syns >= 0.3.0.6 + th-abstraction, + th-desugar