th-desugar-1.15/0000755000000000000000000000000007346545000011674 5ustar0000000000000000th-desugar-1.15/CHANGES.md0000644000000000000000000006446107346545000013301 0ustar0000000000000000`th-desugar` release notes ========================== Version 1.15 [2023.03.12] ------------------------- * Support GHC 9.6. * The `NewOrData` data type has been renamed to `DataFlavor` and extended to support `type data` declarations: ```diff -data NewOrData = NewType | Data +data DataFlavor = NewType | Data | TypeData ``` Desugaring upholds the following properties regarding `TypeData`: * A `DDataD` with a `DataFlavor` of `TypeData` cannot have any deriving clauses or datatype contexts, and the `DConFields` in each `DCon` will be a `NormalC` where each `Bang` is equal to `Bang NoSourceUnpackedness NoSourceStrictness`. * A `DDataInstD` can have a `DataFlavor` of `NewType` or `Data`, but not `TypeData`. * The type of `getDataD` has been changed to also include a `DataFlavor`: ```diff -getDataD :: DsMonad q => String -> Name -> q ([TyVarBndrUnit], [Con]) +getDataD :: DsMonad q => String -> Name -> q (DataFlavor, [TyVarBndrUnit], [Con]) ``` * Local reification can now reify the types of pattern synonym record selectors. * Fix a bug in which the types of locally reified GADT record selectors would sometimes have type variables quantified in the wrong order. Version 1.14 [2022.08.23] ------------------------- * Support GHC 9.4. * Drop support for GHC 7.8 and 7.10. As a consequence of this, the `strictToBang` function was removed as it no longer serves a useful purpose. * Desugared lambda expressions and guards that bind multiple patterns can now have patterns with unlifted types. The desugared code uses `UnboxedTuples` to make this possible, so if you load the desugared code into GHCi on prior to GHC 9.2, you will need to enable `-fobject-code`. * `th-desugar` now desugars `PromotedInfixT` and `PromotedUInfixT`, which were added in GHC 9.4. Mirroring the existing treatment of other `Promoted*` `Type`s, `PromotedInfixT` is desugared to an application of a `DConT` applied to two arguments, just like `InfixT` is desugared. Similarly, attempting to desugar a `PromotedUInfixT` results in an error, just like attempting to desugar a `UInfixT` would be. * `th-desugar` now supports `DefaultD` (i.e., `default` declarations) and `OpaqueP` (i.e., `OPAQUE` pragmas), which were added in GHC 9.4. * `th-desugar` now desugars `LamCasesE` (i.e., `\cases` expressions), which was added in GHC 9.4. A `\cases` expression is desugared to an ordinary lambda expression, much like `\case` is currently desugared. * Fix an inconsistency which caused non-exhaustive `case` expressions to be desugared into uses of `EmptyCase`. Non-exhaustive `case` expressions are now desugared into code that throws a "`Non-exhaustive patterns in...`" error at runtime, just as all other forms of non-exhaustive expressions are desugared. * Fix a bug in which `expandType` would not expand closed type families when applied to arguments containing type variables. Version 1.13.1 [2022.05.20] --------------------------- * Allow building with `mtl-2.3.*`. Version 1.13 [2021.10.30] ------------------------- * Support GHC 9.2. * Add support for visible type application in data constructor patterns. As a result of these changes, the `DConP` constructor now has an extra field to represent type arguments: ```diff data DPat = ... - | DConP Name [DPat] -- fun (Just x) = ... + | DConP Name [DType] [DPat] -- fun (Just @t x) = ... | ... ``` * Add support for the `e.field` and `(.field)` syntax from the `OverloadedRecordDot` language extension. * The `Maybe [DTyVarBndrUnit]` fields in `DInstanceD` and `DStandaloneDerivD` are no longer used when sweetening. Previously, `th-desugar` would attempt to sweeten these `DTyVarBndrUnit`s by turning them into a nested `ForallT`, but GHC 9.2 or later no longer allow this, as they forbid nested `forall`s in instance heads entirely. As a result, the `Maybe [DTyVarBndrUnit]` fields are now only useful for functions that consume `DDec`s directly. * Fix a bug in which desugared GADT constructors would sometimes incorrectly claim that they were declared infix, despite this not being the case. Version 1.12 [2021.03.12] ------------------------- * Support GHC 9.0. * Add support for explicit specificity. As part of this change, the way `th-desugar` represents type variable binders has been overhauled: * The `DTyVarBndr` data type is now parameterized by a `flag` type parameter: ```hs data DTyVarBndr flag = DPlainTV Name flag | DKindedTV Name flag DKind ``` This can be instantiated to `Specificity` (for type variable binders that can be specified or inferred) or `()` (for type variable binders where specificity is irrelevant). `DTyVarBndrSpec` and `DTyVarBndrUnit` are also provided as type synonyms for `DTyVarBndr Specificity` and `DTyVarBndr ()`, respectively. * In order to interface with `TyVarBndr` (the TH counterpart to `DTyVarBndr`) in a backwards-compatible way, `th-desugar` now depends on the `th-abstraction` library. * The `ForallVisFlag` has been removed in favor of the new `DForallTelescope` data type, which not only distinguishes between invisible and visible `forall`s but also uses the correct type variable flag for invisible type variables (`Specificity`) and visible type variables (`()`). * The type of the `dsTvb` is now different on pre-9.0 versions of GHC: ```hs #if __GLASGOW_HASKELL__ >= 900 dsTvb :: DsMonad q => TyVarBndr flag -> q (DTyVarBndr flag) #else dsTvb :: DsMonad q => flag -> TyVarBndr -> q (DTyVarBndr flag) #endif ``` This is unfortunately required by the fact that prior to GHC 9.0, there is no `flag` information stored anywhere in a `TyVarBndr`. If you need to use `dsTvb` in a backward-compatible way, `L.H.TH.Desugar` now provides `dsTvbSpec` and `dsTvbUnit` functions which specialise `dsTvb` to particular `flag` types: ```hs dsTvbSpec :: DsMonad q => TyVarBndrSpec -> q DTyVarBndrSpec dsTvbUnit :: DsMonad q => TyVarBndrUnit -> q DTyVarBndrUnit ``` * The type of the `getRecordSelectors` function has changed: ```diff -getRecordSelectors :: DsMonad q => DType -> [DCon] -> q [DLetDec] +getRecordSelectors :: DsMonad q => [DCon] -> q [DLetDec] ``` The old type signature had a `DType` argument whose sole purpose was to help determine which type variables were existential, as this information was used to filter out "naughty" record selectors, like the example below: ```hs data Some :: (Type -> Type) -> Type where MkSome :: { getSome :: f a } -> Some f ``` The old implementation of `getRecordSelectors` would not include `getSome` in the returned list, as its type `f a` mentions an existential type variable, `a`, that is not mentioned in the return type `Some f`. The new implementation of `getRecordSelectors`, on the other hand, makes no attempt to filter out naughty record selectors, so it would include `getSome`. This reason for this change is ultimately because determining which type variables are existentially quantified in the context of Template Haskell is rather challenging in the general case. There are heuristics we could employ to guess which variables are existential, but we have found these heuristics difficult to predict (let alone specify). As a result, we take the slightly less correct (but much easier to explain) approach of returning all record selectors, regardless of whether they are naughty or not. * The `conExistentialTvbs` function has been removed. It was horribly buggy, especially in the presence of GADT constructors. Moreover, this function was used in the implementation of `getRecordSelectors` function, so bugs in `conExistentialTvbs` often affected the results of `getRecordSelectors`. * The types of `decToTH`, `letDecToTH`, and `pragmaToTH` have changed: ```diff -decToTH :: DDec -> [Dec] +decToTH :: DDec -> Dec -letDecToTH :: DLetDec -> Maybe Dec +letDecToTH :: DLetDec -> Dec -pragmaToTH :: DPragma -> Maybe Pragma +pragmaToTH :: DPragma -> Pragma ``` The semantics of `pragmaToTH` have changed accordingly. Previously, `pragmaToTH` would return `Nothing` when the argument is a `DPragma` that is not supported on an old version of GHC, but now an error will be thrown instead. `decToTH` and `letDecToTH`, which transitively invoke `pragmaToTH`, have had their types updated to accommodate `pragmaToTH`'s type change. * The type of the `substTyVarBndrs` function has been simplified to avoid the needless use of continuation-passing style: ```diff -substTyVarBndrs :: Quasi q => DSubst -> [DTyVarBndr flag] -> (DSubst -> [DTyVarBndr flag] -> q a) -> q a +substTyVarBndrs :: Quasi q => DSubst -> [DTyVarBndr flag] -> q (DSubst, [DTyVarBndr flag]) ``` * `mkDLamEFromDPats` has now generates slightly more direct code for certain lambda expressions with `@`-patterns. For example, `\x@y -> f x y` would previously desugar to `\arg -> case arg of { y -> let x = y in f x y }`, but it now desugars to `\y -> let x = y in f x y`. * `mkDLamEFromDPats` now requires only a `Quasi` context instead of `DsMonad`. Version 1.11 [2020.03.25] ------------------------- * Support GHC 8.10. * Add support for visible dependent quantification. As part of this change, the way `th-desugar` represents `forall` and constraint types has been overhauled: * The existing `DForallT` constructor has been split into two smaller constructors: ```diff data DType = ... - | DForallT [DTyVarBndr] DCxt DType + | DForallT ForallVisFlag [DTyVarBndr] DType + | DConstrainedT DCxt DType | ... +data ForallVisFlag + = ForallVis + | ForallInvis ``` The previous design combined `forall`s and constraints into a single constructor, while the new design puts them in distinct constructors `DForallT` and `DConstrainedT`, respectively. The new `DForallT` constructor also has a `ForallVisFlag` field to distinguish invisible `forall`s (e.g., `forall a. a`) from visible `forall`s (e.g., `forall a -> a`). * The `unravel` function has been renamed to `unravelDType` and now returns `(DFunArgs, DType)`, where `DFunArgs` is a data type that represents the possible arguments in a function type (see the Haddocks for `DFunArgs` for more details). There is also an `unravelDType` counterpart for `Type`s named `unravelType`, complete with its own `FunArgs` data type. `{D}FunArgs` also have some supporting operations, including `filter{D}VisFunArgs` (to obtain only the visible arguments) and `ravel{D}Type` (to construct a function type using `{D}FunArgs` and a return `{D}Type`). * Support standalone kind signatures by adding a `DKiSigD` constructor to `DDec`. * Add `dsReifyType`, `reifyTypeWithLocals_maybe`, and `reifyTypeWithLocals`, which allow looking up the types or kinds of locally declared entities. * Fix a bug in which `reifyFixityWithLocals` would not look into local fixity declarations inside of type classes. * Fix a bug in which `reifyFixityWithLocals` would return incorrect results for classes with associated type family defaults. Version 1.10 ------------ * Support GHC 8.8. Drop support for GHC 7.6. * Add support for visible kind application, type variable `foralls` in `RULES`, and explicit `forall`s in type family instances. Correspondingly, * There is now a `DAppKindT` constructor in `DType`. * Previously, the `DDataInstD` constructor had fields of type `Name` and `[DType]`. Those have been scrapped in favor of a single field of type `DType`, representing the application of the data family name (which was previously the `Name`) to its arguments (which was previously the `[DType]`). `DDataInstD` also has a new field of type `Maybe [DTyVarBndr]` to represent its explicitly quantified type variables (if present). * Previously, the `DTySynEqn` constructor had a field of type `[DType]`. That has been scrapped in favor of a field of type `DType`, representing the application of the type family name (which `DTySynEqn` did not used to contain!) to its arguments (which was previously the `[DType]`). `DTySynEqn` also has a new field of type `Maybe [DTyVarBndr]` to represent its explicitly quantified type variables (if present). * `DTySynInstD` no longer has a field of type `Name`, as that is redundant now that each `DTySynEqn` contains the same `Name`. * There is now a field of type `Maybe [DTyVarBndr]` in the `DRuleP` constructor to represent bound type variables in `RULES` (if present). * Add a field of type `Maybe [DTyVarBndr]` to `DInstanceD` and `DStandaloneDerivD` for optionally quantifying type variables explicitly. If supplied with a `Just`, this sweetens the instance type to use a `ForallT` to represent the explicit quantification. This trick is not supported for `InstanceD` on GHC 8.0 and for `StandaloneDerivD` on GHC 7.10 or 8.0, so be aware of this limitation if you supply `Just` for this field. * Add support for desugaring implicit params. This does not involve any changes to the `th-desugar` AST, as: * `(?x :: a) => ...` is desugared to `IP "x" a => ...`. * `id ?x` is desugared to `id (ip @"x")`. * `let ?x = 42 in ...` is desugared to `let new_x_val = 42 in bindIP @"x" new_x_val ...` (where `bindIP` is a new utility function exported by `Language.Haskell.TH.Desugar` on GHC 8.0 or later). In order to support this desugaring, the type signatures of `dsLetDec` and `dsLetDecs` now return `([DLetDec], DExp -> DExp)` instead of just `[DLetDec]`, where `DExp -> DExp` is the expression which binds the values of implicit params (e.g., `\z -> bindIP @"x" new_x_val z`) if any are bound. (If none are bound, this is simply the `id` function.) * Fix a bug in which `toposortTyVarsOf` would error at runtime if given types containing `forall`s as arguments. * Fix a bug in which `fvDType` would return incorrect results if given a type containing quantified constraints. * Fix a bug in which `expandType` would not expand type synonyms in the kinds of type variable binders in `forall`s. * Fix a bug in which `getRecordSelectors` would omit record selectors from GADT constructors. * Fix a bug in which `toposortTyVarsOf` would sometimes not preserve the left-to-right ordering of `Name`s generated with `qNewName`. * Locally reified class methods, data constructors, and record selectors now quantify kind variables properly. * Desugared ADT constructors now quantify kind variables properly. * Remove `DPred`, as it has become too similar to `DType`. This also means that the `DPat` constructors, which previously ended with the suffix `Pa`, can now use the suffix `P`, mirroring TH. * The type of `applyDType` has changed from `DType -> [DType] -> DType` to `DType -> [DTypeArg] -> DType`, where `DTypeArg` is a new data type that encodes whether an argument is a normal type argument (e.g., the `Int` in `Maybe Int`) or a visible kind argument (e.g., the `@Type` in `Proxy @Type Char`). A `TypeArg` data type (which is like `DTypeArg`, but with `Type`s/`Kind`s instead of `DType`s/`DKind`s) is also provided. A handful of utility functions for manipulating `TypeArg`s and `DTypeArg`s are also exported. * `th-desugar` functions that compute free variables (e.g., `fvDType`) now return an `OSet`, a variant of `Set` that remembers the order in which elements were inserted. A consequence of this change is that it fixes a bug that causes free variables to be computed in different orders depending on which unique numbers GHC happened to generate internally. * Substition and type synonym expansion are now more efficient by avoiding the use of `syb` in inner loops. Version 1.9 ----------- * Suppose GHC 8.6. * Add support for `DerivingVia`. Correspondingly, there is now a `DDerivStrategy` data type. * Add support for `QuantifiedConstraints`. Correspondingly, there is now a `DForallPr` constructor in `DPred` to represent quantified constraint types. * Remove the `DStarT` constructor of `DType` in favor of `DConT ''Type`. Two utility functions have been added to `Language.Haskell.TH.Desugar` to ease this transition: * `isTypeKindName`: returns `True` if the argument `Name` is that of `Type` or `★` (or `*`, to support older GHCs). * `typeKindName`: the name of `Type` (on GHC 8.0 or later) or `*` (on older GHCs). * `th-desugar` now desugars all data types to GADT syntax. The most significant API-facing changes resulting from this new design are: * The `DDataD`, `DDataFamilyD`, and `DDataFamInstD` constructors of `DDec` now have `Maybe DKind` fields that either have `Just` an explicit return kind (e.g., the `k -> Type -> Type` in `data Foo :: k -> Type -> Type`) or `Nothing` (if lacking an explicit return kind). * The `DCon` constructor previously had a field of type `Maybe DType`, since there was a possibility it could be a GADT (with an explicit return type) or non-GADT (without an explicit return type) constructor. Since all data types are desugared to GADTs now, this field has been changed to be simply a `DType`. * The type signature of `dsCon` was previously: ```haskell dsCon :: DsMonad q => Con -> q [DCon] ``` However, desugaring constructors now needs more information than before, since GADT constructors have richer type signatures. Accordingly, the type of `dsCon` is now: ```haskell dsCon :: DsMonad q => [DTyVarBndr] -- ^ The universally quantified type variables -- (used if desugaring a non-GADT constructor) -> DType -- ^ The original data declaration's type -- (used if desugaring a non-GADT constructor). -> Con -> q [DCon] ``` The `instance Desugar [Con] [DCon]` has also been removed, as the previous implementation of `desugar` (`concatMapM dsCon`) no longer has enough information to work. Some other utility functions have also been added as part of this change: * A `conExistentialTvbs` function has been introduced to determine the existentially quantified type variables of a `DCon`. Note that this function is not 100% accurate—refer to the documentation for `conExistentialTvbs` for more information. * A `mkExtraDKindBinders` function has been introduced to turn a data type's return kind into explicit, fresh type variable binders. * A `toposortTyVarsOf` function, which finds the free variables of a list of `DType`s and returns them in a well scoped list that has been sorted in reverse topological order. * `th-desugar` now desugars partial pattern matches in `do`-notation and list/monad comprehensions to the appropriate invocation of `fail`. (Previously, these were incorrectly desugared into `case` expressions with incomplete patterns.) * Add a `mkDLamEFromDPats` function for constructing a `DLamE` expression using a list of `DPat` arguments and a `DExp` body. * Add an `unravel` function for decomposing a function type into its `forall`'d type variables, its context, its argument types, and its result type. * Export a `substTyVarBndrs` function from `Language.Haskell.TH.Desugar.Subst`, which substitutes over type variable binders in a capture-avoiding fashion. * `getDataD`, `dataConNameToDataName`, and `dataConNameToCon` from `Language.Haskell.TH.Desugar.Reify` now look up local declarations. As a result, the contexts in their type signatures have been strengthened from `Quasi` to `DsMonad`. * Export a `dTyVarBndrToDType` function which converts a `DTyVarBndr` to a `DType`, which preserves its kind. * Previously, `th-desugar` would silently accept illegal uses of record construction with fields that did not belong to the constructor, such as `Identity { notAField = "wat" }`. This is now an error. Version 1.8 ----------- * Support GHC 8.4. * `substTy` now properly substitutes into kind signatures. * Expose `fvDType`, which computes the free variables of a `DType`. * Incorporate a `DDeclaredInfix` field into `DNormalC` to indicate if it is a constructor that was declared infix. * Implement `lookupValueNameWithLocals`, `lookupTypeNameWithLocals`, `mkDataNameWithLocals`, and `mkTypeNameWithLocals`, counterparts to `lookupValueName`, `lookupTypeName`, `mkDataName`, and `mkTypeName` which have access to local Template Haskell declarations. * Implement `reifyNameSpace` to determine a `Name`'s `NameSpace`. * Export `reifyFixityWithLocals` from `Language.Haskell.TH.Desugar`. * Export `matchTy` (among other goodies) from new module `Language.Haskell.TH.Subst`. This function matches a type template against a target. Version 1.7 ----------- * Support for TH's support for `TypeApplications`, thanks to @RyanGlScott. * Support for unboxed sums, thanks to @RyanGlScott. * Support for `COMPLETE` pragmas. * `getRecordSelectors` now requires a list of `DCon`s as an argument. This makes it easier to return correct record selector bindings in the event that a record selector appears in multiple constructors. (See [goldfirere/singletons#180](https://github.com/goldfirere/singletons/issues/180) for an example of where the old behavior of `getRecordSelectors` went wrong.) * Better type family expansion (expanding an open type family with variables works now). Version 1.6 ----------- * Work with GHC 8, with thanks to @christiaanb for getting this change going. This means that several core datatypes have changed: partcularly, we now have `DTypeFamilyHead` and fixities are now reified separately from other things. * `DKind` is merged with `DType`. * `Generic` instances for everything. Version 1.5.5 ------------- * Fix issue #34. This means that desugaring (twice) is idempotent over expressions, after the second time. That is, if you desugar an expression, sweeten it, desugar again, sweeten again, and then desugar a third time, you get the same result as when you desugared the second time. (The extra round-trip is necessary there to make the output smaller in certain common cases.) Version 1.5.4.1 --------------- * Fix issue #32, concerning reification of classes with default methods. Version 1.5.4 ------------- * Added `expandUnsoundly` Version 1.5.3 ------------- * More `DsMonad` instances, thanks to David Fox. Version 1.5.2 ------------- * Sweeten kinds more, too. Version 1.5.1 ------------- * Thanks to David Fox (@ddssff), sweetening now tries to use more of TH's `Type` constructors. * Also thanks to David Fox, depend usefully on the th-orphans package. Version 1.5 ----------- * There is now a facility to register a list of `Dec` that internal reification should use when necessary. This avoids the user needing to break up their definition across different top-level splices. See `withLocalDeclarations`. This has a side effect of changing the `Quasi` typeclass constraint on many functions to be the new `DsMonad` constraint. Happily, there are `DsMonad` instances for `Q` and `IO`, the two normal inhabitants of `Quasi`. * "Match flattening" is implemented! The functions `scExp` and `scLetDec` remove any nested pattern matches. * More is now exported from `Language.Haskell.TH.Desugar` for ease of use. * `expand` can now expand closed type families! It still requires that the type to expand contain no type variables. * Support for standalone-deriving and default signatures in GHC 7.10. This means that there are now two new constructors for `DDec`. * Support for `static` expressions, which are new in GHC 7.10. Version 1.4.2 ------------- * `expand` functions now consider open type families, as long as the type to be expanded has no free variables. Version 1.4.1 ------------- * Added `Language.Haskell.TH.Desugar.Lift`, which provides `Lift` instances for all of the th-desugar types, as well as several Template Haskell types. * Added `applyDExp` and `applyDType` as convenience functions. Version 1.4.0 ------------- * All `Dec`s can now be desugared, to the new `DDec` type. * Sweetening `Dec`s that do not exist in GHC 7.6.3- works on a "best effort" basis: closed type families are sweetened to open ones, and role annotations are dropped. * `Info`s can now be desugared. Desugaring takes into account GHC bug #8884, which meant that reifying poly-kinded type families in GHC 7.6.3- was subtly wrong. * There is a new function `flattenDValD` which takes a binding like `let (a,b) = foo` and breaks it apart into separate assignments for `a` and `b`. * There is a new `Desugar` class with methods `desugar` and `sweeten`. See the documentation in `Language.Haskell.TH.Desugar`. * Variable names that are distinct in desugared code are now guaranteed to have distinct answers to `nameBase`. * Added a new function `getRecordSelectors` that extracts types and definitions of record selectors from a datatype definition. Version 1.3.1 ------------- * Update cabal file to include testing files in sdist. Version 1.3.0 ------------- * Update to work with `type Pred = Type` in GHC 7.9. This changed the `DPred` type for all GHC versions, though. Version 1.2.0 ------------- * Generalized interface to allow any member of the `Qausi` class, instead of just `Q`. Version 1.1.1 ------------- * Made compatible with HEAD after change in role annotation syntax. Version 1.1 ----------- * Added module `Language.Haskell.TH.Desugar.Expand`, which allows for expansion of type synonyms in desugared types. * Added `Show`, `Typeable`, and `Data` instances to desugared types. * Fixed bug where an as-pattern in a `let` statement was scoped incorrectly. * Changed signature of `dsPat` to be more specific to as-patterns; this allowed for fixing the `let` scoping bug. * Created new functions `dsPatOverExp` and `dsPatsOverExp` to allow for easy desugaring of patterns. * Changed signature of `dsLetDec` to return a list of `DLetDec`s. * Added `dsLetDecs` for convenience. Now, instead of using `mapM dsLetDec`, you should use `dsLetDecs`. Version 1.0 ----------- * Initial release th-desugar-1.15/LICENSE0000644000000000000000000000273707346545000012712 0ustar0000000000000000Copyright (c) 2013, Richard Eisenberg All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.th-desugar-1.15/Language/Haskell/TH/0000755000000000000000000000000007346545000015315 5ustar0000000000000000th-desugar-1.15/Language/Haskell/TH/Desugar.hs0000644000000000000000000004162007346545000017246 0ustar0000000000000000{- Language/Haskell/TH/Desugar.hs (c) Richard Eisenberg 2013 rae@cs.brynmawr.edu -} {-# LANGUAGE CPP, MultiParamTypeClasses, FunctionalDependencies, TypeSynonymInstances, FlexibleInstances, LambdaCase, ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Language.Haskell.TH.Desugar -- Copyright : (C) 2014 Richard Eisenberg -- License : BSD-style (see LICENSE) -- Maintainer : Ryan Scott -- Stability : experimental -- Portability : non-portable -- -- Desugars full Template Haskell syntax into a smaller core syntax for further -- processing. -- ---------------------------------------------------------------------------- module Language.Haskell.TH.Desugar ( -- * Desugared data types DExp(..), DLetDec(..), DPat(..), DType(..), DForallTelescope(..), DKind, DCxt, DPred, DTyVarBndr(..), DTyVarBndrSpec, DTyVarBndrUnit, Specificity(..), DMatch(..), DClause(..), DDec(..), DDerivClause(..), DDerivStrategy(..), DPatSynDir(..), DPatSynType, Overlap(..), PatSynArgs(..), DataFlavor(..), DTypeFamilyHead(..), DFamilyResultSig(..), InjectivityAnn(..), DCon(..), DConFields(..), DDeclaredInfix, DBangType, DVarBangType, Bang(..), SourceUnpackedness(..), SourceStrictness(..), DForeign(..), DPragma(..), DRuleBndr(..), DTySynEqn(..), DInfo(..), DInstanceDec, Role(..), AnnTarget(..), -- * The 'Desugar' class Desugar(..), -- * Main desugaring functions dsExp, dsDecs, dsType, dsInfo, dsPatOverExp, dsPatsOverExp, dsPatX, dsLetDecs, dsTvb, dsTvbSpec, dsTvbUnit, dsCxt, dsCon, dsForeign, dsPragma, dsRuleBndr, -- ** Secondary desugaring functions PatM, dsPred, dsPat, dsDec, dsDataDec, dsDataInstDec, DerivingClause, dsDerivClause, dsLetDec, dsMatches, dsBody, dsGuards, dsDoStmts, dsComp, dsClauses, dsBangType, dsVarBangType, dsTypeFamilyHead, dsFamilyResultSig, #if __GLASGOW_HASKELL__ >= 801 dsPatSynDir, #endif dsTypeArg, -- * Converting desugared AST back to TH AST module Language.Haskell.TH.Desugar.Sweeten, -- * Expanding type synonyms expand, expandType, -- * Reification reifyWithWarning, -- ** Local reification -- $localReification withLocalDeclarations, dsReify, dsReifyType, reifyWithLocals_maybe, reifyWithLocals, reifyFixityWithLocals, reifyTypeWithLocals_maybe, reifyTypeWithLocals, lookupValueNameWithLocals, lookupTypeNameWithLocals, mkDataNameWithLocals, mkTypeNameWithLocals, reifyNameSpace, DsMonad(..), DsM, -- * Nested pattern flattening scExp, scLetDec, -- * Capture-avoiding substitution and utilities module Language.Haskell.TH.Desugar.Subst, -- * Free variable calculation module Language.Haskell.TH.Desugar.FV, -- * Utility functions applyDExp, dPatToDExp, removeWilds, getDataD, dataConNameToDataName, dataConNameToCon, nameOccursIn, allNamesIn, flattenDValD, getRecordSelectors, mkTypeName, mkDataName, newUniqueName, mkTupleDExp, mkTupleDPat, maybeDLetE, maybeDCaseE, mkDLamEFromDPats, tupleDegree_maybe, tupleNameDegree_maybe, unboxedSumDegree_maybe, unboxedSumNameDegree_maybe, unboxedTupleDegree_maybe, unboxedTupleNameDegree_maybe, isTypeKindName, typeKindName, bindIP, mkExtraDKindBinders, dTyVarBndrToDType, changeDTVFlags, toposortTyVarsOf, -- ** 'FunArgs' and 'VisFunArg' FunArgs(..), ForallTelescope(..), VisFunArg(..), filterVisFunArgs, ravelType, unravelType, -- ** 'DFunArgs' and 'DVisFunArg' DFunArgs(..), DVisFunArg(..), filterDVisFunArgs, ravelDType, unravelDType, -- ** 'TypeArg' TypeArg(..), applyType, filterTANormals, unfoldType, -- ** 'DTypeArg' DTypeArg(..), applyDType, filterDTANormals, unfoldDType, -- ** Extracting bound names extractBoundNamesStmt, extractBoundNamesDec, extractBoundNamesPat ) where import Language.Haskell.TH.Datatype.TyVarBndr import Language.Haskell.TH.Desugar.AST import Language.Haskell.TH.Desugar.Core import Language.Haskell.TH.Desugar.Expand import Language.Haskell.TH.Desugar.FV import Language.Haskell.TH.Desugar.Match import Language.Haskell.TH.Desugar.Reify import Language.Haskell.TH.Desugar.Subst import Language.Haskell.TH.Desugar.Sweeten import Language.Haskell.TH.Desugar.Util import Language.Haskell.TH.Syntax import Control.Monad import qualified Data.Foldable as F import Data.Function import qualified Data.Map as M import qualified Data.Set as S import Prelude hiding ( exp ) -- | This class relates a TH type with its th-desugar type and allows -- conversions back and forth. The functional dependency goes only one -- way because we define the following instances on old versions of GHC: -- -- @ -- instance 'Desugar' 'TyVarBndrSpec' 'DTyVarBndrSpec' -- instance 'Desugar' 'TyVarBndrUnit' 'DTyVarBndrUnit' -- @ -- -- Prior to GHC 9.0, 'TyVarBndrSpec' and 'TyVarBndrUnit' are simply type -- synonyms for 'TyVarBndr', so making the functional dependencies -- bidirectional would cause these instances to be rejected. class Desugar th ds | ds -> th where desugar :: DsMonad q => th -> q ds sweeten :: ds -> th instance Desugar Exp DExp where desugar = dsExp sweeten = expToTH instance Desugar Type DType where desugar = dsType sweeten = typeToTH instance Desugar Cxt DCxt where desugar = dsCxt sweeten = cxtToTH #if __GLASGOW_HASKELL__ >= 900 -- | This instance is only @flag@-polymorphic on GHC 9.0 or later, since -- previous versions of GHC do not equip 'TyVarBndr' with a @flag@ type -- parameter. As a result, we define two separate instances for 'DTyVarBndr' -- on older GHCs: -- -- @ -- instance 'Desugar' 'TyVarBndrSpec' 'DTyVarBndrSpec' -- instance 'Desugar' 'TyVarBndrUnit' 'DTyVarBndrUnit' -- @ instance Desugar (TyVarBndr flag) (DTyVarBndr flag) where desugar = dsTvb sweeten = tvbToTH #else -- | This instance monomorphizes the @flag@ parameter of 'DTyVarBndr' since -- pre-9.0 versions of GHC do not equip 'TyVarBndr' with a @flag@ type -- parameter. There is also a corresponding instance for -- 'TyVarBndrUnit'/'DTyVarBndrUnit'. instance Desugar TyVarBndrSpec DTyVarBndrSpec where desugar = dsTvbSpec sweeten = tvbToTH -- | This instance monomorphizes the @flag@ parameter of 'DTyVarBndr' since -- pre-9.0 versions of GHC do not equip 'TyVarBndr' with a @flag@ type -- parameter. There is also a corresponding instance for -- 'TyVarBndrSpec'/'DTyVarBndrSpec'. instance Desugar TyVarBndrUnit DTyVarBndrUnit where desugar = dsTvbUnit sweeten = tvbToTH #endif instance Desugar [Dec] [DDec] where desugar = dsDecs sweeten = decsToTH instance Desugar TypeArg DTypeArg where desugar = dsTypeArg sweeten = typeArgToTH -- | If the declaration passed in is a 'DValD', creates new, equivalent -- declarations such that the 'DPat' in all 'DValD's is just a plain -- 'DVarPa'. Other declarations are passed through unchanged. -- Note that the declarations that come out of this function are rather -- less efficient than those that come in: they have many more pattern -- matches. flattenDValD :: Quasi q => DLetDec -> q [DLetDec] flattenDValD dec@(DValD (DVarP _) _) = return [dec] flattenDValD (DValD pat exp) = do x <- newUniqueName "x" -- must use newUniqueName here because we might be top-level let top_val_d = DValD (DVarP x) exp bound_names = F.toList $ extractBoundNamesDPat pat other_val_ds <- mapM (mk_val_d x) bound_names return $ top_val_d : other_val_ds where mk_val_d x name = do y <- newUniqueName "y" let pat' = wildify name y pat match = DMatch pat' (DVarE y) cas = DCaseE (DVarE x) [match] return $ DValD (DVarP name) cas wildify name y p = case p of DLitP lit -> DLitP lit DVarP n | n == name -> DVarP y | otherwise -> DWildP DConP con ts ps -> DConP con ts (map (wildify name y) ps) DTildeP pa -> DTildeP (wildify name y pa) DBangP pa -> DBangP (wildify name y pa) DSigP pa ty -> DSigP (wildify name y pa) ty DWildP -> DWildP flattenDValD other_dec = return [other_dec] -- | Produces 'DLetDec's representing the record selector functions from -- the provided 'DCon's. -- -- Note that if the same record selector appears in multiple constructors, -- 'getRecordSelectors' will return only one binding for that selector. -- For example, if you had: -- -- @ -- data X = X1 {y :: Symbol} | X2 {y :: Symbol} -- @ -- -- Then calling 'getRecordSelectors' on @[X1, X2]@ will return: -- -- @ -- [ DSigD y (DAppT (DAppT DArrowT (DConT X)) (DConT Symbol)) -- , DFunD y [ DClause [DConP X1 [DVarP field]] (DVarE field) -- , DClause [DConP X2 [DVarP field]] (DVarE field) ] ] -- @ -- -- instead of returning one binding for @X1@ and another binding for @X2@. -- -- 'getRecordSelectors' does not attempt to filter out \"naughty\" record -- selectors—that is, records whose field types mention existentially -- quantified type variables that do not appear in the constructor's return -- type. Here is an example of a naughty record selector: -- -- @ -- data Some :: (Type -> Type) -> Type where -- MkSome :: { getSome :: f a } -> Some f -- @ -- -- GHC itself will not allow the use of @getSome@ as a top-level function due -- to its type @f a@ mentioning the existential variable @a@, but -- 'getRecordSelectors' will return it nonetheless. Ultimately, this design -- choice is a practical one, as detecting which type variables are existential -- in Template Haskell is difficult in the general case. getRecordSelectors :: DsMonad q => [DCon] -> q [DLetDec] getRecordSelectors cons = merge_let_decs `fmap` concatMapM get_record_sels cons where get_record_sels (DCon con_tvbs _ con_name con_fields con_ret_ty) = case con_fields of DRecC fields -> go fields DNormalC{} -> return [] where go fields = do varName <- qNewName "field" return $ concat [ [ DSigD name $ DForallT (DForallInvis con_tvbs) $ DArrowT `DAppT` con_ret_ty `DAppT` field_ty , DFunD name [DClause [DConP con_name [] (mk_field_pats n (length fields) varName)] (DVarE varName)] ] | ((name, _strict, field_ty), n) <- zip fields [0..] ] mk_field_pats :: Int -> Int -> Name -> [DPat] mk_field_pats 0 total name = DVarP name : (replicate (total-1) DWildP) mk_field_pats n total name = DWildP : mk_field_pats (n-1) (total-1) name merge_let_decs :: [DLetDec] -> [DLetDec] merge_let_decs decs = let (name_clause_map, decs') = gather_decs M.empty S.empty decs in augment_clauses name_clause_map decs' -- First, for each record selector-related declarations, do the following: -- -- 1. If it's a DFunD... -- a. If we haven't encountered it before, add a mapping from its Name -- to its associated DClauses, and continue. -- b. If we have encountered it before, augment the existing Name's -- mapping with the new clauses. Then remove the DFunD from the list -- and continue. -- 2. If it's a DSigD... -- a. If we haven't encountered it before, remember its Name and continue. -- b. If we have encountered it before, remove the DSigD from the list -- and continue. -- 3. Otherwise, continue. -- -- After this, scan over the resulting list once more with the mapping -- that we accumulated. For every DFunD, replace its DClauses with the -- ones corresponding to its Name in the mapping. -- -- Note that this algorithm combines all of the DClauses for each unique -- Name, while preserving the order in which the DFunDs were originally -- found. Moreover, it removes duplicate DSigD entries. Using Maps and -- Sets avoid quadratic blowup for data types with many record selectors. where gather_decs :: M.Map Name [DClause] -> S.Set Name -> [DLetDec] -> (M.Map Name [DClause], [DLetDec]) gather_decs name_clause_map _ [] = (name_clause_map, []) gather_decs name_clause_map type_sig_names (x:xs) -- 1. | DFunD n clauses <- x = let name_clause_map' = M.insertWith (\new old -> old ++ new) n clauses name_clause_map in if n `M.member` name_clause_map then gather_decs name_clause_map' type_sig_names xs else let (map', decs') = gather_decs name_clause_map' type_sig_names xs in (map', x:decs') -- 2. | DSigD n _ <- x = if n `S.member` type_sig_names then gather_decs name_clause_map type_sig_names xs else let (map', decs') = gather_decs name_clause_map (n `S.insert` type_sig_names) xs in (map', x:decs') -- 3. | otherwise = let (map', decs') = gather_decs name_clause_map type_sig_names xs in (map', x:decs') augment_clauses :: M.Map Name [DClause] -> [DLetDec] -> [DLetDec] augment_clauses _ [] = [] augment_clauses name_clause_map (x:xs) | DFunD n _ <- x, Just merged_clauses <- n `M.lookup` name_clause_map = DFunD n merged_clauses:augment_clauses name_clause_map xs | otherwise = x:augment_clauses name_clause_map xs -- | Create new kind variable binder names corresponding to the return kind of -- a data type. This is useful when you have a data type like: -- -- @ -- data Foo :: forall k. k -> Type -> Type where ... -- @ -- -- But you want to be able to refer to the type @Foo a b@. -- 'mkExtraDKindBinders' will take the kind @forall k. k -> Type -> Type@, -- discover that is has two visible argument kinds, and return as a result -- two new kind variable binders @[a :: k, b :: Type]@, where @a@ and @b@ -- are fresh type variable names. -- -- This expands kind synonyms if necessary. mkExtraDKindBinders :: forall q. DsMonad q => DKind -> q [DTyVarBndrUnit] mkExtraDKindBinders k = do k' <- expandType k let (fun_args, _) = unravelDType k' vis_fun_args = filterDVisFunArgs fun_args mapM mk_tvb vis_fun_args where mk_tvb :: DVisFunArg -> q DTyVarBndrUnit mk_tvb (DVisFADep tvb) = return tvb mk_tvb (DVisFAAnon ki) = DKindedTV <$> qNewName "a" <*> return () <*> return ki {- $localReification @template-haskell@ reification functions like 'reify' and 'qReify', as well as @th-desugar@'s 'reifyWithWarning', only look through declarations that either (1) have already been typechecked in the current module, or (2) are in scope because of imports. We refer to this as /global/ reification. Sometimes, however, you may wish to reify declarations that have been quoted but not yet been typechecked, such as in the following example: @ example :: IO () example = putStrLn $(do decs <- [d| data Foo = MkFoo |] info <- 'reify' (mkName \"Foo\") stringE $ pprint info) @ Because @Foo@ only exists in a TH quote, it is not available globally. As a result, the call to @'reify' (mkName \"Foo\")@ will fail. To make this sort of example possible, @th-desugar@ extends global reification with /local/ reification. A function that performs local reification (such as 'dsReify', 'reifyWithLocals', or similar functions that have a 'DsMonad' context) looks through both typechecked (or imported) declarations /and/ quoted declarations that are currently in scope. One can add quoted declarations in the current scope by using the 'withLocalDeclarations' function. Here is an example of how to repair the example above using 'withLocalDeclarations': @ example2 :: IO () example2 = putStrLn $(do decs <- [d| data Foo = MkFoo |] info <- 'withLocalDeclarations' decs $ 'reifyWithLocals' (mkName \"Foo\") stringE $ pprint info) @ Note that 'withLocalDeclarations' should only be used to add quoted declarations with names that are not duplicates of existing global or local declarations. Adding duplicate declarations through 'withLocalDeclarations' is undefined behavior and should be avoided. This is unlikely to happen if you are only using 'withLocalDeclarations' in conjunction with TH quotes, however. For instance, this is /not/ an example of duplicate declarations: @ data T = MkT1 $(do decs <- [d| data T = MkT2 |] info <- 'withLocalDeclarations' decs ... ...) @ The quoted @data T = MkT2@ does not conflict with the top-level @data T = Mk1@ since declaring a data type within TH quotes gives it a fresh, unique name that distinguishes it from any other data types already in scope. -} th-desugar-1.15/Language/Haskell/TH/Desugar/0000755000000000000000000000000007346545000016707 5ustar0000000000000000th-desugar-1.15/Language/Haskell/TH/Desugar/AST.hs0000644000000000000000000003102607346545000017674 0ustar0000000000000000{- Language/Haskell/TH/Desugar/AST.hs (c) Ryan Scott 2018 Defines the desugared Template Haskell AST. The desugared types and constructors are prefixed with a D. -} {-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, DeriveLift #-} module Language.Haskell.TH.Desugar.AST where import Data.Data hiding (Fixity) import GHC.Generics hiding (Fixity) import Language.Haskell.TH import Language.Haskell.TH.Instances () import Language.Haskell.TH.Syntax (Lift) #if __GLASGOW_HASKELL__ < 900 import Language.Haskell.TH.Datatype.TyVarBndr (Specificity(..)) #endif import Language.Haskell.TH.Desugar.Util (DataFlavor) -- | Corresponds to TH's @Exp@ type. Note that @DLamE@ takes names, not patterns. data DExp = DVarE Name | DConE Name | DLitE Lit | DAppE DExp DExp | DAppTypeE DExp DType | DLamE [Name] DExp | DCaseE DExp [DMatch] | DLetE [DLetDec] DExp | DSigE DExp DType | DStaticE DExp deriving (Eq, Show, Data, Generic, Lift) -- | Corresponds to TH's @Pat@ type. data DPat = DLitP Lit | DVarP Name | DConP Name [DType] [DPat] | DTildeP DPat | DBangP DPat | DSigP DPat DType | DWildP deriving (Eq, Show, Data, Generic, Lift) -- | Corresponds to TH's @Type@ type, used to represent -- types and kinds. data DType = DForallT DForallTelescope DType | DConstrainedT DCxt DType | DAppT DType DType | DAppKindT DType DKind | DSigT DType DKind | DVarT Name | DConT Name | DArrowT | DLitT TyLit | DWildCardT deriving (Eq, Show, Data, Generic, Lift) -- | The type variable binders in a @forall@. data DForallTelescope = DForallVis [DTyVarBndrUnit] -- ^ A visible @forall@ (e.g., @forall a -> {...}@). -- These do not have any notion of specificity, so we use -- '()' as a placeholder value in the 'DTyVarBndr's. | DForallInvis [DTyVarBndrSpec] -- ^ An invisible @forall@ (e.g., @forall a {b} c -> {...}@), -- where each binder has a 'Specificity'. deriving (Eq, Show, Data, Generic, Lift) -- | Kinds are types. Corresponds to TH's @Kind@ type DKind = DType -- | Predicates are types. Corresponds to TH's @Pred@ type DPred = DType -- | Corresponds to TH's @Cxt@ type DCxt = [DPred] -- | Corresponds to TH's @TyVarBndr@ data DTyVarBndr flag = DPlainTV Name flag | DKindedTV Name flag DKind deriving (Eq, Show, Data, Generic, Functor, Lift) -- | Corresponds to TH's @TyVarBndrSpec@ type DTyVarBndrSpec = DTyVarBndr Specificity -- | Corresponds to TH's @TyVarBndrUnit@ type DTyVarBndrUnit = DTyVarBndr () -- | Corresponds to TH's @Match@ type. data DMatch = DMatch DPat DExp deriving (Eq, Show, Data, Generic, Lift) -- | Corresponds to TH's @Clause@ type. data DClause = DClause [DPat] DExp deriving (Eq, Show, Data, Generic, Lift) -- | Declarations as used in a @let@ statement. data DLetDec = DFunD Name [DClause] | DValD DPat DExp | DSigD Name DType | DInfixD Fixity Name | DPragmaD DPragma deriving (Eq, Show, Data, Generic, Lift) -- | Corresponds to TH's @Dec@ type. data DDec = DLetDec DLetDec -- | An ordinary (i.e., non-data family) data type declaration. Note -- that desugaring upholds the following properties regarding the -- 'DataFlavor' field: -- -- * If the 'DataFlavor' is 'NewType', then there will be exactly -- one 'DCon'. -- -- * If the 'DataFlavor' is 'TypeData', then there will be no -- 'DDerivClause's, the 'DCxt' will be empty, and the 'DConFields' -- in each 'DCon' will be a 'NormalC' where each 'Bang' is equal -- to @Bang 'NoSourceUnpackedness' 'NoSourceStrictness'@. | DDataD DataFlavor DCxt Name [DTyVarBndrUnit] (Maybe DKind) [DCon] [DDerivClause] | DTySynD Name [DTyVarBndrUnit] DType | DClassD DCxt Name [DTyVarBndrUnit] [FunDep] [DDec] -- | Note that the @Maybe [DTyVarBndrUnit]@ field is dropped -- entirely when sweetened, so it is only useful for functions -- that directly consume @DDec@s. | DInstanceD (Maybe Overlap) (Maybe [DTyVarBndrUnit]) DCxt DType [DDec] | DForeignD DForeign | DOpenTypeFamilyD DTypeFamilyHead | DClosedTypeFamilyD DTypeFamilyHead [DTySynEqn] | DDataFamilyD Name [DTyVarBndrUnit] (Maybe DKind) -- | A data family instance declaration. Note that desugaring -- upholds the following properties regarding the 'DataFlavor' -- field: -- -- * If the 'DataFlavor' is 'NewType', then there will be exactly -- one 'DCon'. -- -- * The 'DataFlavor' will never be 'TypeData', as GHC does not -- permit combining data families with @type data@. | DDataInstD DataFlavor DCxt (Maybe [DTyVarBndrUnit]) DType (Maybe DKind) [DCon] [DDerivClause] | DTySynInstD DTySynEqn | DRoleAnnotD Name [Role] -- | Note that the @Maybe [DTyVarBndrUnit]@ field is dropped -- entirely when sweetened, so it is only useful for functions -- that directly consume @DDec@s. | DStandaloneDerivD (Maybe DDerivStrategy) (Maybe [DTyVarBndrUnit]) DCxt DType | DDefaultSigD Name DType | DPatSynD Name PatSynArgs DPatSynDir DPat | DPatSynSigD Name DPatSynType | DKiSigD Name DKind -- DKiSigD is part of DDec, not DLetDec, because standalone kind -- signatures can only appear on the top level. | DDefaultD [DType] deriving (Eq, Show, Data, Generic, Lift) -- | Corresponds to TH's 'PatSynDir' type data DPatSynDir = DUnidir -- ^ @pattern P x {<-} p@ | DImplBidir -- ^ @pattern P x {=} p@ | DExplBidir [DClause] -- ^ @pattern P x {<-} p where P x = e@ deriving (Eq, Show, Data, Generic, Lift) -- | Corresponds to TH's 'PatSynType' type type DPatSynType = DType #if __GLASGOW_HASKELL__ < 801 -- | Same as @PatSynArgs@ from TH; defined here for backwards compatibility. data PatSynArgs = PrefixPatSyn [Name] -- ^ @pattern P {x y z} = p@ | InfixPatSyn Name Name -- ^ @pattern {x P y} = p@ | RecordPatSyn [Name] -- ^ @pattern P { {x,y,z} } = p@ deriving (Eq, Show, Data, Generic, Lift) #endif -- | Corresponds to TH's 'TypeFamilyHead' type data DTypeFamilyHead = DTypeFamilyHead Name [DTyVarBndrUnit] DFamilyResultSig (Maybe InjectivityAnn) deriving (Eq, Show, Data, Generic, Lift) -- | Corresponds to TH's 'FamilyResultSig' type data DFamilyResultSig = DNoSig | DKindSig DKind | DTyVarSig DTyVarBndrUnit deriving (Eq, Show, Data, Generic, Lift) -- | Corresponds to TH's 'Con' type. Unlike 'Con', all 'DCon's reflect GADT -- syntax. This is beneficial for @th-desugar@'s since it means -- that all data type declarations can support explicit return kinds, so -- one does not need to represent them with something like @'Maybe' 'DKind'@, -- since Haskell98-style data declaration syntax isn't used. Accordingly, -- there are some differences between 'DCon' and 'Con' to keep in mind: -- -- * Unlike 'ForallC', where the meaning of the 'TyVarBndr's changes depending -- on whether it's followed by 'GadtC'/'RecGadtC' or not, the meaning of the -- 'DTyVarBndr's in a 'DCon' is always the same: it is the list of -- universally /and/ existentially quantified type variables. Note that it is -- not guaranteed that one set of type variables will appear before the -- other. -- -- * A 'DCon' always has an explicit return type. data DCon = DCon [DTyVarBndrSpec] DCxt Name DConFields DType -- ^ The GADT result type deriving (Eq, Show, Data, Generic, Lift) -- | A list of fields either for a standard data constructor or a record -- data constructor. data DConFields = DNormalC DDeclaredInfix [DBangType] | DRecC [DVarBangType] deriving (Eq, Show, Data, Generic, Lift) -- | 'True' if a constructor is declared infix. For normal ADTs, this means -- that is was written in infix style. For example, both of the constructors -- below are declared infix. -- -- @ -- data Infix = Int `Infix` Int | Int :*: Int -- @ -- -- Whereas neither of these constructors are declared infix: -- -- @ -- data Prefix = Prefix Int Int | (:+:) Int Int -- @ -- -- For GADTs, detecting whether a constructor is declared infix is a bit -- trickier, as one cannot write a GADT constructor "infix-style" like one -- can for normal ADT constructors. GHC considers a GADT constructor to be -- declared infix if it meets the following three criteria: -- -- 1. Its name uses operator syntax (e.g., @(:*:)@). -- 2. It has exactly two fields (without record syntax). -- 3. It has a programmer-specified fixity declaration. -- -- For example, in the following GADT: -- -- @ -- infixl 5 :**:, :&&:, :^^:, `ActuallyPrefix` -- data InfixGADT a where -- (:**:) :: Int -> b -> InfixGADT (Maybe b) -- Only this one is infix -- ActuallyPrefix :: Char -> Bool -> InfixGADT Double -- (:&&:) :: { infixGADT1 :: b, infixGADT2 :: Int } -> InfixGADT [b] -- (:^^:) :: Int -> Int -> Int -> InfixGADT Int -- (:!!:) :: Char -> Char -> InfixGADT Char -- @ -- -- Only the @(:**:)@ constructor is declared infix. The other constructors -- are not declared infix, because: -- -- * @ActuallyPrefix@ does not use operator syntax (criterion 1). -- * @(:&&:)@ uses record syntax (criterion 2). -- * @(:^^:)@ does not have exactly two fields (criterion 2). -- * @(:!!:)@ does not have a programmer-specified fixity declaration (criterion 3). type DDeclaredInfix = Bool -- | Corresponds to TH's @BangType@ type. type DBangType = (Bang, DType) -- | Corresponds to TH's @VarBangType@ type. type DVarBangType = (Name, Bang, DType) -- | Corresponds to TH's @Foreign@ type. data DForeign = DImportF Callconv Safety String Name DType | DExportF Callconv String Name DType deriving (Eq, Show, Data, Generic, Lift) -- | Corresponds to TH's @Pragma@ type. data DPragma = DInlineP Name Inline RuleMatch Phases | DSpecialiseP Name DType (Maybe Inline) Phases | DSpecialiseInstP DType | DRuleP String (Maybe [DTyVarBndrUnit]) [DRuleBndr] DExp DExp Phases | DAnnP AnnTarget DExp | DLineP Int String | DCompleteP [Name] (Maybe Name) | DOpaqueP Name deriving (Eq, Show, Data, Generic, Lift) -- | Corresponds to TH's @RuleBndr@ type. data DRuleBndr = DRuleVar Name | DTypedRuleVar Name DType deriving (Eq, Show, Data, Generic, Lift) -- | Corresponds to TH's @TySynEqn@ type (to store type family equations). data DTySynEqn = DTySynEqn (Maybe [DTyVarBndrUnit]) DType DType deriving (Eq, Show, Data, Generic, Lift) -- | Corresponds to TH's @Info@ type. data DInfo = DTyConI DDec (Maybe [DInstanceDec]) | DVarI Name DType (Maybe Name) -- ^ The @Maybe Name@ stores the name of the enclosing definition -- (datatype, for a data constructor; class, for a method), -- if any | DTyVarI Name DKind | DPrimTyConI Name Int Bool -- ^ The @Int@ is the arity; the @Bool@ is whether this tycon -- is unlifted. | DPatSynI Name DPatSynType deriving (Eq, Show, Data, Generic, Lift) type DInstanceDec = DDec -- ^ Guaranteed to be an instance declaration -- | Corresponds to TH's @DerivClause@ type. data DDerivClause = DDerivClause (Maybe DDerivStrategy) DCxt deriving (Eq, Show, Data, Generic, Lift) -- | Corresponds to TH's @DerivStrategy@ type. data DDerivStrategy = DStockStrategy -- ^ A \"standard\" derived instance | DAnyclassStrategy -- ^ @-XDeriveAnyClass@ | DNewtypeStrategy -- ^ @-XGeneralizedNewtypeDeriving@ | DViaStrategy DType -- ^ @-XDerivingVia@ deriving (Eq, Show, Data, Generic, Lift) th-desugar-1.15/Language/Haskell/TH/Desugar/Core.hs0000644000000000000000000024400407346545000020137 0ustar0000000000000000{- Language/Haskell/TH/Desugar/Core.hs (c) Richard Eisenberg 2013 rae@cs.brynmawr.edu Desugars full Template Haskell syntax into a smaller core syntax for further processing. The desugared types and constructors are prefixed with a D. -} {-# LANGUAGE TemplateHaskellQuotes, LambdaCase, CPP, ScopedTypeVariables, TupleSections, DeriveDataTypeable, DeriveGeneric #-} module Language.Haskell.TH.Desugar.Core where import Prelude hiding (mapM, foldl, foldr, all, elem, exp, concatMap, and) import Language.Haskell.TH hiding (Extension(..), match, clause, cxt) import Language.Haskell.TH.Datatype.TyVarBndr import Language.Haskell.TH.Syntax hiding (Extension(..), lift) import Control.Monad hiding (forM_, mapM) import qualified Control.Monad.Fail as Fail import Control.Monad.Trans (MonadTrans(..)) import Control.Monad.Writer (MonadWriter(..), WriterT(..)) import Control.Monad.Zip import Data.Data (Data) import Data.Either (lefts) import Data.Foldable as F hiding (concat, notElem) import qualified Data.Map as M import Data.Map (Map) import Data.Maybe (isJust, mapMaybe) import Data.Monoid (All(..)) import qualified Data.Set as S import Data.Set (Set) import Data.Traversable #if __GLASGOW_HASKELL__ >= 803 import GHC.OverloadedLabels ( fromLabel ) #endif #if __GLASGOW_HASKELL__ >= 807 import GHC.Classes (IP(..)) #else import qualified Language.Haskell.TH as LangExt (Extension(..)) #endif #if __GLASGOW_HASKELL__ >= 902 import Data.List.NonEmpty (NonEmpty(..)) import GHC.Records (HasField(..)) #endif import GHC.Exts import GHC.Generics (Generic) import Language.Haskell.TH.Desugar.AST import Language.Haskell.TH.Desugar.FV import qualified Language.Haskell.TH.Desugar.OSet as OS import Language.Haskell.TH.Desugar.OSet (OSet) import Language.Haskell.TH.Desugar.Util import Language.Haskell.TH.Desugar.Reify -- | Desugar an expression dsExp :: DsMonad q => Exp -> q DExp dsExp (VarE n) = return $ DVarE n dsExp (ConE n) = return $ DConE n dsExp (LitE lit) = return $ DLitE lit dsExp (AppE e1 e2) = DAppE <$> dsExp e1 <*> dsExp e2 dsExp (InfixE Nothing op Nothing) = dsExp op dsExp (InfixE (Just lhs) op Nothing) = DAppE <$> (dsExp op) <*> (dsExp lhs) dsExp (InfixE Nothing op (Just rhs)) = do lhsName <- newUniqueName "lhs" op' <- dsExp op rhs' <- dsExp rhs return $ DLamE [lhsName] (foldl DAppE op' [DVarE lhsName, rhs']) dsExp (InfixE (Just lhs) op (Just rhs)) = DAppE <$> (DAppE <$> dsExp op <*> dsExp lhs) <*> dsExp rhs dsExp (UInfixE _ _ _) = fail "Cannot desugar unresolved infix operators." dsExp (ParensE exp) = dsExp exp dsExp (LamE pats exp) = do exp' <- dsExp exp (pats', exp'') <- dsPatsOverExp pats exp' mkDLamEFromDPats pats' exp'' dsExp (LamCaseE matches) = do x <- newUniqueName "x" matches' <- dsMatches x matches return $ DLamE [x] (DCaseE (DVarE x) matches') dsExp (TupE exps) = dsTup tupleDataName exps dsExp (UnboxedTupE exps) = dsTup unboxedTupleDataName exps dsExp (CondE e1 e2 e3) = dsExp (CaseE e1 [mkBoolMatch 'True e2, mkBoolMatch 'False e3]) where mkBoolMatch :: Name -> Exp -> Match mkBoolMatch boolDataCon rhs = Match (ConP boolDataCon #if __GLASGOW_HASKELL__ >= 901 [] #endif []) (NormalB rhs) [] dsExp (MultiIfE guarded_exps) = let failure = mkErrorMatchExpr MultiWayIfAlt in dsGuards guarded_exps failure dsExp (LetE decs exp) = do (decs', ip_binder) <- dsLetDecs decs exp' <- dsExp exp return $ DLetE decs' $ ip_binder exp' -- the following special case avoids creating a new "let" when it's not -- necessary. See #34. dsExp (CaseE (VarE scrutinee) matches) = do matches' <- dsMatches scrutinee matches return $ DCaseE (DVarE scrutinee) matches' dsExp (CaseE exp matches) = do scrutinee <- newUniqueName "scrutinee" exp' <- dsExp exp matches' <- dsMatches scrutinee matches return $ DLetE [DValD (DVarP scrutinee) exp'] $ DCaseE (DVarE scrutinee) matches' #if __GLASGOW_HASKELL__ >= 900 dsExp (DoE mb_mod stmts) = dsDoStmts mb_mod stmts #else dsExp (DoE stmts) = dsDoStmts Nothing stmts #endif dsExp (CompE stmts) = dsComp stmts dsExp (ArithSeqE (FromR exp)) = DAppE (DVarE 'enumFrom) <$> dsExp exp dsExp (ArithSeqE (FromThenR exp1 exp2)) = DAppE <$> (DAppE (DVarE 'enumFromThen) <$> dsExp exp1) <*> dsExp exp2 dsExp (ArithSeqE (FromToR exp1 exp2)) = DAppE <$> (DAppE (DVarE 'enumFromTo) <$> dsExp exp1) <*> dsExp exp2 dsExp (ArithSeqE (FromThenToR e1 e2 e3)) = DAppE <$> (DAppE <$> (DAppE (DVarE 'enumFromThenTo) <$> dsExp e1) <*> dsExp e2) <*> dsExp e3 dsExp (ListE exps) = go exps where go [] = return $ DConE '[] go (h : t) = DAppE <$> (DAppE (DConE '(:)) <$> dsExp h) <*> go t dsExp (SigE exp ty) = DSigE <$> dsExp exp <*> dsType ty dsExp (RecConE con_name field_exps) = do con <- dataConNameToCon con_name reordered <- reorder con return $ foldl DAppE (DConE con_name) reordered where reorder con = case con of NormalC _name fields -> non_record fields InfixC field1 _name field2 -> non_record [field1, field2] RecC _name fields -> reorder_fields fields ForallC _ _ c -> reorder c GadtC _names fields _ret_ty -> non_record fields RecGadtC _names fields _ret_ty -> reorder_fields fields reorder_fields fields = reorderFields con_name fields field_exps (repeat $ DVarE 'undefined) non_record fields | null field_exps -- Special case: record construction is allowed for any -- constructor, regardless of whether the constructor -- actually was declared with records, provided that no -- records are given in the expression itself. (See #59). -- -- Con{} desugars down to Con undefined ... undefined. = return $ replicate (length fields) $ DVarE 'undefined | otherwise = impossible $ "Record syntax used with non-record constructor " ++ (show con_name) ++ "." dsExp (RecUpdE exp field_exps) = do -- here, we need to use one of the field names to find the tycon, somewhat dodgily first_name <- case field_exps of ((name, _) : _) -> return name _ -> impossible "Record update with no fields listed." info <- reifyWithLocals first_name applied_type <- case info of VarI _name ty _m_dec -> extract_first_arg ty _ -> impossible "Record update with an invalid field name." type_name <- extract_type_name applied_type (_, _, cons) <- getDataD "This seems to be an error in GHC." type_name let filtered_cons = filter_cons_with_names cons (map fst field_exps) exp' <- dsExp exp matches <- mapM con_to_dmatch filtered_cons let all_matches | length filtered_cons == length cons = matches | otherwise = matches ++ [error_match] return $ DCaseE exp' all_matches where extract_first_arg :: DsMonad q => Type -> q Type extract_first_arg (AppT (AppT ArrowT arg) _) = return arg extract_first_arg (ForallT _ _ t) = extract_first_arg t extract_first_arg (SigT t _) = extract_first_arg t extract_first_arg _ = impossible "Record selector not a function." extract_type_name :: DsMonad q => Type -> q Name extract_type_name (AppT t1 _) = extract_type_name t1 extract_type_name (SigT t _) = extract_type_name t extract_type_name (ConT n) = return n extract_type_name _ = impossible "Record selector domain not a datatype." filter_cons_with_names cons field_names = filter has_names cons where args_contain_names args = let con_field_names = map fst_of_3 args in all (`elem` con_field_names) field_names has_names (RecC _con_name args) = args_contain_names args has_names (RecGadtC _con_name args _ret_ty) = args_contain_names args has_names (ForallC _ _ c) = has_names c has_names _ = False rec_con_to_dmatch con_name args = do let con_field_names = map fst_of_3 args field_var_names <- mapM (newUniqueName . nameBase) con_field_names DMatch (DConP con_name [] (map DVarP field_var_names)) <$> (foldl DAppE (DConE con_name) <$> (reorderFields con_name args field_exps (map DVarE field_var_names))) con_to_dmatch :: DsMonad q => Con -> q DMatch con_to_dmatch (RecC con_name args) = rec_con_to_dmatch con_name args -- We're assuming the GADT constructor has only one Name here, but since -- this constructor was reified, this assumption should always hold true. con_to_dmatch (RecGadtC [con_name] args _ret_ty) = rec_con_to_dmatch con_name args con_to_dmatch (ForallC _ _ c) = con_to_dmatch c con_to_dmatch _ = impossible "Internal error within th-desugar." error_match = DMatch DWildP (mkErrorMatchExpr RecUpd) fst_of_3 (x, _, _) = x dsExp (StaticE exp) = DStaticE <$> dsExp exp dsExp (UnboundVarE n) = return (DVarE n) #if __GLASGOW_HASKELL__ >= 801 dsExp (AppTypeE exp ty) = DAppTypeE <$> dsExp exp <*> dsType ty dsExp (UnboxedSumE exp alt arity) = DAppE (DConE $ unboxedSumDataName alt arity) <$> dsExp exp #endif #if __GLASGOW_HASKELL__ >= 803 dsExp (LabelE str) = return $ DVarE 'fromLabel `DAppTypeE` DLitT (StrTyLit str) #endif #if __GLASGOW_HASKELL__ >= 807 dsExp (ImplicitParamVarE n) = return $ DVarE 'ip `DAppTypeE` DLitT (StrTyLit n) dsExp (MDoE {}) = fail "th-desugar currently does not support RecursiveDo" #endif #if __GLASGOW_HASKELL__ >= 902 dsExp (GetFieldE arg field) = DAppE (mkGetFieldProj field) <$> dsExp arg dsExp (ProjectionE fields) = case fields of f :| fs -> return $ foldl' comp (mkGetFieldProj f) fs where comp :: DExp -> String -> DExp comp acc f = DVarE '(.) `DAppE` mkGetFieldProj f `DAppE` acc #endif #if __GLASGOW_HASKELL__ >= 903 dsExp (LamCasesE clauses) = do clauses' <- dsClauses CaseAlt clauses numArgs <- case clauses' of (DClause pats _:_) -> return $ length pats [] -> fail "\\cases expression must have at least one alternative" args <- replicateM numArgs (newUniqueName "x") return $ DLamE args $ DCaseE (mkUnboxedTupleDExp (map DVarE args)) (map dClauseToUnboxedTupleMatch clauses') #endif -- | Convert a 'DClause' to a 'DMatch' by bundling all of the clause's patterns -- into a match on a single unboxed tuple pattern. That is, convert this: -- -- @ -- f x y z = rhs -- @ -- -- To this: -- -- @ -- f (# x, y, z #) = rhs -- @ -- -- This is used to desugar @\\cases@ expressions into lambda expressions. dClauseToUnboxedTupleMatch :: DClause -> DMatch dClauseToUnboxedTupleMatch (DClause pats rhs) = DMatch (mkUnboxedTupleDPat pats) rhs #if __GLASGOW_HASKELL__ >= 809 dsTup :: DsMonad q => (Int -> Name) -> [Maybe Exp] -> q DExp dsTup = ds_tup #else dsTup :: DsMonad q => (Int -> Name) -> [Exp] -> q DExp dsTup tuple_data_name = ds_tup tuple_data_name . map Just #endif -- | Desugar a tuple (or tuple section) expression. ds_tup :: forall q. DsMonad q => (Int -> Name) -- ^ Compute the 'Name' of a tuple (boxed or unboxed) -- data constructor from its arity. -> [Maybe Exp] -- ^ The tuple's subexpressions. 'Nothing' entries -- denote empty fields in a tuple section. -> q DExp ds_tup tuple_data_name mb_exps = do section_exps <- mapM ds_section_exp mb_exps let section_vars = lefts section_exps tup_body = mk_tup_body section_exps if null section_vars then return tup_body -- If this isn't a tuple section, -- don't create a lambda. else mkDLamEFromDPats (map DVarP section_vars) tup_body where -- If dealing with an empty field in a tuple section (Nothing), create a -- unique name and return Left. These names will be used to construct the -- lambda expression that it desugars to. -- (For example, `(,5)` desugars to `\ts -> (,) ts 5`.) -- -- If dealing with a tuple subexpression (Just), desugar it and return -- Right. ds_section_exp :: Maybe Exp -> q (Either Name DExp) ds_section_exp = maybe (Left <$> qNewName "ts") (fmap Right . dsExp) mk_tup_body :: [Either Name DExp] -> DExp mk_tup_body section_exps = foldl' apply_tup_body (DConE $ tuple_data_name (length section_exps)) section_exps apply_tup_body :: DExp -> Either Name DExp -> DExp apply_tup_body f (Left n) = f `DAppE` DVarE n apply_tup_body f (Right e) = f `DAppE` e -- | Convert a list of 'DPat' arguments and a 'DExp' body into a 'DLamE'. This -- is needed since 'DLamE' takes a list of 'Name's for its bound variables -- instead of 'DPat's, so some reorganization is needed. mkDLamEFromDPats :: Quasi q => [DPat] -> DExp -> q DExp mkDLamEFromDPats pats exp | Just names <- mapM stripDVarP_maybe pats = return $ DLamE names exp | otherwise = do arg_names <- replicateM (length pats) (newUniqueName "arg") let scrutinee = mkUnboxedTupleDExp (map DVarE arg_names) match = DMatch (mkUnboxedTupleDPat pats) exp return $ DLamE arg_names (DCaseE scrutinee [match]) where stripDVarP_maybe :: DPat -> Maybe Name stripDVarP_maybe (DVarP n) = Just n stripDVarP_maybe _ = Nothing #if __GLASGOW_HASKELL__ >= 902 mkGetFieldProj :: String -> DExp mkGetFieldProj field = DVarE 'getField `DAppTypeE` DLitT (StrTyLit field) #endif -- | Desugar a list of matches for a @case@ statement dsMatches :: DsMonad q => Name -- ^ Name of the scrutinee, which must be a bare var -> [Match] -- ^ Matches of the @case@ statement -> q [DMatch] dsMatches scr = go where go :: DsMonad q => [Match] -> q [DMatch] go [] = return [] go (Match pat body where_decs : rest) = do rest' <- go rest let failure = maybeDCaseE CaseAlt (DVarE scr) rest' exp' <- dsBody body where_decs failure (pat', exp'') <- dsPatOverExp pat exp' uni_pattern <- isUniversalPattern pat' -- incomplete attempt at #6 if uni_pattern then return [DMatch pat' exp''] else return (DMatch pat' exp'' : rest') -- | Desugar a @Body@ dsBody :: DsMonad q => Body -- ^ body to desugar -> [Dec] -- ^ "where" declarations -> DExp -- ^ what to do if the guards don't match -> q DExp dsBody (NormalB exp) decs _ = do (decs', ip_binder) <- dsLetDecs decs exp' <- dsExp exp return $ maybeDLetE decs' $ ip_binder exp' dsBody (GuardedB guarded_exps) decs failure = do (decs', ip_binder) <- dsLetDecs decs guarded_exp' <- dsGuards guarded_exps failure return $ maybeDLetE decs' $ ip_binder guarded_exp' -- | If decs is non-empty, delcare them in a let: maybeDLetE :: [DLetDec] -> DExp -> DExp maybeDLetE [] exp = exp maybeDLetE decs exp = DLetE decs exp -- | If matches is non-empty, make a case statement; otherwise make an error statement maybeDCaseE :: MatchContext -> DExp -> [DMatch] -> DExp maybeDCaseE mc _ [] = mkErrorMatchExpr mc maybeDCaseE _ scrut matches = DCaseE scrut matches -- | Desugar guarded expressions dsGuards :: DsMonad q => [(Guard, Exp)] -- ^ Guarded expressions -> DExp -- ^ What to do if none of the guards match -> q DExp dsGuards [] thing_inside = return thing_inside dsGuards ((NormalG gd, exp) : rest) thing_inside = dsGuards ((PatG [NoBindS gd], exp) : rest) thing_inside dsGuards ((PatG stmts, exp) : rest) thing_inside = do success <- dsExp exp failure <- dsGuards rest thing_inside dsGuardStmts stmts success failure -- | Desugar the @Stmt@s in a guard dsGuardStmts :: DsMonad q => [Stmt] -- ^ The @Stmt@s to desugar -> DExp -- ^ What to do if the @Stmt@s yield success -> DExp -- ^ What to do if the @Stmt@s yield failure -> q DExp dsGuardStmts [] success _failure = return success dsGuardStmts (BindS pat exp : rest) success failure = do success' <- dsGuardStmts rest success failure (pat', success'') <- dsPatOverExp pat success' exp' <- dsExp exp return $ DCaseE exp' [DMatch pat' success'', DMatch DWildP failure] dsGuardStmts (LetS decs : rest) success failure = do (decs', ip_binder) <- dsLetDecs decs success' <- dsGuardStmts rest success failure return $ DLetE decs' $ ip_binder success' -- special-case a final pattern containing "otherwise" or "True" -- note that GHC does this special-casing, too, in DsGRHSs.isTrueLHsExpr dsGuardStmts [NoBindS exp] success _failure | VarE name <- exp , name == 'otherwise = return success | ConE name <- exp , name == 'True = return success dsGuardStmts (NoBindS exp : rest) success failure = do exp' <- dsExp exp success' <- dsGuardStmts rest success failure return $ DCaseE exp' [ DMatch (DConP 'True [] []) success' , DMatch (DConP 'False [] []) failure ] dsGuardStmts (ParS _ : _) _ _ = impossible "Parallel comprehension in a pattern guard." #if __GLASGOW_HASKELL__ >= 807 dsGuardStmts (RecS {} : _) _ _ = fail "th-desugar currently does not support RecursiveDo" #endif -- | Desugar the @Stmt@s in a @do@ expression dsDoStmts :: forall q. DsMonad q => Maybe ModName -> [Stmt] -> q DExp dsDoStmts mb_mod = go where go :: [Stmt] -> q DExp go [] = impossible "do-expression ended with something other than bare statement." go [NoBindS exp] = dsExp exp go (BindS pat exp : rest) = do rest' <- go rest dsBindS mb_mod exp pat rest' "do expression" go (LetS decs : rest) = do (decs', ip_binder) <- dsLetDecs decs rest' <- go rest return $ DLetE decs' $ ip_binder rest' go (NoBindS exp : rest) = do exp' <- dsExp exp rest' <- go rest let sequence_name = mk_qual_do_name mb_mod '(>>) return $ DAppE (DAppE (DVarE sequence_name) exp') rest' go (ParS _ : _) = impossible "Parallel comprehension in a do-statement." #if __GLASGOW_HASKELL__ >= 807 go (RecS {} : _) = fail "th-desugar currently does not support RecursiveDo" #endif -- | Desugar the @Stmt@s in a list or monad comprehension dsComp :: DsMonad q => [Stmt] -> q DExp dsComp [] = impossible "List/monad comprehension ended with something other than a bare statement." dsComp [NoBindS exp] = DAppE (DVarE 'return) <$> dsExp exp dsComp (BindS pat exp : rest) = do rest' <- dsComp rest dsBindS Nothing exp pat rest' "monad comprehension" dsComp (LetS decs : rest) = do (decs', ip_binder) <- dsLetDecs decs rest' <- dsComp rest return $ DLetE decs' $ ip_binder rest' dsComp (NoBindS exp : rest) = do exp' <- dsExp exp rest' <- dsComp rest return $ DAppE (DAppE (DVarE '(>>)) (DAppE (DVarE 'guard) exp')) rest' dsComp (ParS stmtss : rest) = do (pat, exp) <- dsParComp stmtss rest' <- dsComp rest DAppE (DAppE (DVarE '(>>=)) exp) <$> mkDLamEFromDPats [pat] rest' #if __GLASGOW_HASKELL__ >= 807 dsComp (RecS {} : _) = fail "th-desugar currently does not support RecursiveDo" #endif -- Desugar a binding statement in a do- or list comprehension. -- -- In the event that the pattern in the statement is partial, the desugared -- case expression will contain a catch-all case that calls 'fail' from either -- 'MonadFail' or 'Monad', depending on whether the @MonadFailDesugaring@ -- language extension is enabled or not. (On GHCs older than 8.0, 'fail' from -- 'Monad' is always used.) dsBindS :: forall q. DsMonad q => Maybe ModName -> Exp -> Pat -> DExp -> String -> q DExp dsBindS mb_mod bind_arg_exp success_pat success_exp ctxt = do bind_arg_exp' <- dsExp bind_arg_exp (success_pat', success_exp') <- dsPatOverExp success_pat success_exp is_univ_pat <- isUniversalPattern success_pat' let bind_into = DAppE (DAppE (DVarE bind_name) bind_arg_exp') if is_univ_pat then bind_into <$> mkDLamEFromDPats [success_pat'] success_exp' else do arg_name <- newUniqueName "arg" fail_name <- mk_fail_name return $ bind_into $ DLamE [arg_name] $ DCaseE (DVarE arg_name) [ DMatch success_pat' success_exp' , DMatch DWildP $ DVarE fail_name `DAppE` DLitE (StringL $ "Pattern match failure in " ++ ctxt) ] where bind_name = mk_qual_do_name mb_mod '(>>=) mk_fail_name :: q Name #if __GLASGOW_HASKELL__ >= 807 -- GHC 8.8 deprecates the MonadFailDesugaring extension since its effects -- are always enabled. Furthermore, MonadFailDesugaring is no longer -- enabled by default, so simply use MonadFail.fail. (That happens to -- be the same as Prelude.fail in 8.8+.) mk_fail_name = return fail_MonadFail_name #else mk_fail_name = do mfd <- qIsExtEnabled LangExt.MonadFailDesugaring return $ if mfd then fail_MonadFail_name else fail_Prelude_name #endif fail_MonadFail_name = mk_qual_do_name mb_mod 'Fail.fail #if __GLASGOW_HASKELL__ < 807 fail_Prelude_name = mk_qual_do_name mb_mod 'Prelude.fail #endif -- | Desugar the contents of a parallel comprehension. -- Returns a @Pat@ containing a tuple of all bound variables and an expression -- to produce the values for those variables dsParComp :: DsMonad q => [[Stmt]] -> q (DPat, DExp) dsParComp [] = impossible "Empty list of parallel comprehension statements." dsParComp [r] = do let rv = foldMap extractBoundNamesStmt r dsR <- dsComp (r ++ [mk_tuple_stmt rv]) return (mk_tuple_dpat rv, dsR) dsParComp (q : rest) = do let qv = foldMap extractBoundNamesStmt q (rest_pat, rest_exp) <- dsParComp rest dsQ <- dsComp (q ++ [mk_tuple_stmt qv]) let zipped = DAppE (DAppE (DVarE 'mzip) dsQ) rest_exp return (DConP (tupleDataName 2) [] [mk_tuple_dpat qv, rest_pat], zipped) -- helper function for dsParComp mk_tuple_stmt :: OSet Name -> Stmt mk_tuple_stmt name_set = NoBindS (mkTupleExp (F.foldr ((:) . VarE) [] name_set)) -- helper function for dsParComp mk_tuple_dpat :: OSet Name -> DPat mk_tuple_dpat name_set = mkTupleDPat (F.foldr ((:) . DVarP) [] name_set) -- | Desugar a pattern, along with processing a (desugared) expression that -- is the entire scope of the variables bound in the pattern. dsPatOverExp :: DsMonad q => Pat -> DExp -> q (DPat, DExp) dsPatOverExp pat exp = do (pat', vars) <- runWriterT $ dsPat pat let name_decs = map (uncurry (DValD . DVarP)) vars return (pat', maybeDLetE name_decs exp) -- | Desugar multiple patterns. Like 'dsPatOverExp'. dsPatsOverExp :: DsMonad q => [Pat] -> DExp -> q ([DPat], DExp) dsPatsOverExp pats exp = do (pats', vars) <- runWriterT $ mapM dsPat pats let name_decs = map (uncurry (DValD . DVarP)) vars return (pats', maybeDLetE name_decs exp) -- | Desugar a pattern, returning a list of (Name, DExp) pairs of extra -- variables that must be bound within the scope of the pattern dsPatX :: DsMonad q => Pat -> q (DPat, [(Name, DExp)]) dsPatX = runWriterT . dsPat -- | Desugaring a pattern also returns the list of variables bound in as-patterns -- and the values they should be bound to. This variables must be brought into -- scope in the "body" of the pattern. type PatM q = WriterT [(Name, DExp)] q -- | Desugar a pattern. dsPat :: DsMonad q => Pat -> PatM q DPat dsPat (LitP lit) = return $ DLitP lit dsPat (VarP n) = return $ DVarP n dsPat (TupP pats) = DConP (tupleDataName (length pats)) [] <$> mapM dsPat pats dsPat (UnboxedTupP pats) = DConP (unboxedTupleDataName (length pats)) [] <$> mapM dsPat pats #if __GLASGOW_HASKELL__ >= 901 dsPat (ConP name tys pats) = DConP name <$> mapM dsType tys <*> mapM dsPat pats #else dsPat (ConP name pats) = DConP name [] <$> mapM dsPat pats #endif dsPat (InfixP p1 name p2) = DConP name [] <$> mapM dsPat [p1, p2] dsPat (UInfixP _ _ _) = fail "Cannot desugar unresolved infix operators." dsPat (ParensP pat) = dsPat pat dsPat (TildeP pat) = DTildeP <$> dsPat pat dsPat (BangP pat) = DBangP <$> dsPat pat dsPat (AsP name pat) = do pat' <- dsPat pat pat'' <- lift $ removeWilds pat' tell [(name, dPatToDExp pat'')] return pat'' dsPat WildP = return DWildP dsPat (RecP con_name field_pats) = do con <- lift $ dataConNameToCon con_name reordered <- reorder con return $ DConP con_name [] reordered where reorder con = case con of NormalC _name fields -> non_record fields InfixC field1 _name field2 -> non_record [field1, field2] RecC _name fields -> reorder_fields_pat fields ForallC _ _ c -> reorder c GadtC _names fields _ret_ty -> non_record fields RecGadtC _names fields _ret_ty -> reorder_fields_pat fields reorder_fields_pat fields = reorderFieldsPat con_name fields field_pats non_record fields | null field_pats -- Special case: record patterns are allowed for any -- constructor, regardless of whether the constructor -- actually was declared with records, provided that -- no records are given in the pattern itself. (See #59). -- -- Con{} desugars down to Con _ ... _. = return $ replicate (length fields) DWildP | otherwise = lift $ impossible $ "Record syntax used with non-record constructor " ++ (show con_name) ++ "." dsPat (ListP pats) = go pats where go [] = return $ DConP '[] [] [] go (h : t) = do h' <- dsPat h t' <- go t return $ DConP '(:) [] [h', t'] dsPat (SigP pat ty) = DSigP <$> dsPat pat <*> dsType ty #if __GLASGOW_HASKELL__ >= 801 dsPat (UnboxedSumP pat alt arity) = DConP (unboxedSumDataName alt arity) [] <$> ((:[]) <$> dsPat pat) #endif dsPat (ViewP _ _) = fail "View patterns are not supported in th-desugar. Use pattern guards instead." -- | Convert a 'DPat' to a 'DExp'. Fails on 'DWildP'. dPatToDExp :: DPat -> DExp dPatToDExp (DLitP lit) = DLitE lit dPatToDExp (DVarP name) = DVarE name dPatToDExp (DConP name tys pats) = foldl DAppE (foldl DAppTypeE (DConE name) tys) (map dPatToDExp pats) dPatToDExp (DTildeP pat) = dPatToDExp pat dPatToDExp (DBangP pat) = dPatToDExp pat dPatToDExp (DSigP pat ty) = DSigE (dPatToDExp pat) ty dPatToDExp DWildP = error "Internal error in th-desugar: wildcard in rhs of as-pattern" -- | Remove all wildcards from a pattern, replacing any wildcard with a fresh -- variable removeWilds :: DsMonad q => DPat -> q DPat removeWilds p@(DLitP _) = return p removeWilds p@(DVarP _) = return p removeWilds (DConP con_name tys pats) = DConP con_name tys <$> mapM removeWilds pats removeWilds (DTildeP pat) = DTildeP <$> removeWilds pat removeWilds (DBangP pat) = DBangP <$> removeWilds pat removeWilds (DSigP pat ty) = DSigP <$> removeWilds pat <*> pure ty removeWilds DWildP = DVarP <$> newUniqueName "wild" -- | Desugar @Info@ dsInfo :: DsMonad q => Info -> q DInfo dsInfo (ClassI dec instances) = do [ddec] <- dsDec dec dinstances <- dsDecs instances return $ DTyConI ddec (Just dinstances) dsInfo (ClassOpI name ty parent) = DVarI name <$> dsType ty <*> pure (Just parent) dsInfo (TyConI dec) = do [ddec] <- dsDec dec return $ DTyConI ddec Nothing dsInfo (FamilyI dec instances) = do [ddec] <- dsDec dec dinstances <- dsDecs instances return $ DTyConI ddec (Just dinstances) dsInfo (PrimTyConI name arity unlifted) = return $ DPrimTyConI name arity unlifted dsInfo (DataConI name ty parent) = DVarI name <$> dsType ty <*> pure (Just parent) dsInfo (VarI name ty Nothing) = DVarI name <$> dsType ty <*> pure Nothing dsInfo (VarI name _ (Just _)) = impossible $ "Declaration supplied with variable: " ++ show name dsInfo (TyVarI name ty) = DTyVarI name <$> dsType ty #if __GLASGOW_HASKELL__ >= 801 dsInfo (PatSynI name ty) = DPatSynI name <$> dsType ty #endif -- | Desugar arbitrary @Dec@s dsDecs :: DsMonad q => [Dec] -> q [DDec] dsDecs = concatMapM dsDec -- | Desugar a single @Dec@, perhaps producing multiple 'DDec's dsDec :: DsMonad q => Dec -> q [DDec] dsDec d@(FunD {}) = dsTopLevelLetDec d dsDec d@(ValD {}) = dsTopLevelLetDec d dsDec (DataD cxt n tvbs mk cons derivings) = dsDataDec Data cxt n tvbs mk cons derivings dsDec (NewtypeD cxt n tvbs mk con derivings) = dsDataDec Newtype cxt n tvbs mk [con] derivings dsDec (TySynD n tvbs ty) = (:[]) <$> (DTySynD n <$> mapM dsTvbUnit tvbs <*> dsType ty) dsDec (ClassD cxt n tvbs fds decs) = (:[]) <$> (DClassD <$> dsCxt cxt <*> pure n <*> mapM dsTvbUnit tvbs <*> pure fds <*> dsDecs decs) dsDec (InstanceD over cxt ty decs) = (:[]) <$> (DInstanceD over Nothing <$> dsCxt cxt <*> dsType ty <*> dsDecs decs) dsDec d@(SigD {}) = dsTopLevelLetDec d dsDec (ForeignD f) = (:[]) <$> (DForeignD <$> dsForeign f) dsDec d@(InfixD {}) = dsTopLevelLetDec d dsDec d@(PragmaD {}) = dsTopLevelLetDec d dsDec (OpenTypeFamilyD tfHead) = (:[]) <$> (DOpenTypeFamilyD <$> dsTypeFamilyHead tfHead) dsDec (DataFamilyD n tvbs m_k) = (:[]) <$> (DDataFamilyD n <$> mapM dsTvbUnit tvbs <*> mapM dsType m_k) #if __GLASGOW_HASKELL__ >= 807 dsDec (DataInstD cxt mtvbs lhs mk cons derivings) = case unfoldType lhs of (ConT n, tys) -> dsDataInstDec Data cxt n mtvbs tys mk cons derivings (_, _) -> fail $ "Unexpected data instance LHS: " ++ pprint lhs dsDec (NewtypeInstD cxt mtvbs lhs mk con derivings) = case unfoldType lhs of (ConT n, tys) -> dsDataInstDec Newtype cxt n mtvbs tys mk [con] derivings (_, _) -> fail $ "Unexpected newtype instance LHS: " ++ pprint lhs #else dsDec (DataInstD cxt n tys mk cons derivings) = dsDataInstDec Data cxt n Nothing (map TANormal tys) mk cons derivings dsDec (NewtypeInstD cxt n tys mk con derivings) = dsDataInstDec Newtype cxt n Nothing (map TANormal tys) mk [con] derivings #endif #if __GLASGOW_HASKELL__ >= 807 dsDec (TySynInstD eqn) = (:[]) <$> (DTySynInstD <$> dsTySynEqn unusedArgument eqn) #else dsDec (TySynInstD n eqn) = (:[]) <$> (DTySynInstD <$> dsTySynEqn n eqn) #endif dsDec (ClosedTypeFamilyD tfHead eqns) = (:[]) <$> (DClosedTypeFamilyD <$> dsTypeFamilyHead tfHead <*> mapM (dsTySynEqn (typeFamilyHeadName tfHead)) eqns) dsDec (RoleAnnotD n roles) = return [DRoleAnnotD n roles] #if __GLASGOW_HASKELL__ >= 801 dsDec (PatSynD n args dir pat) = do dir' <- dsPatSynDir n dir (pat', vars) <- dsPatX pat unless (null vars) $ fail $ "Pattern synonym definition cannot contain as-patterns (@)." return [DPatSynD n args dir' pat'] dsDec (PatSynSigD n ty) = (:[]) <$> (DPatSynSigD n <$> dsType ty) dsDec (StandaloneDerivD mds cxt ty) = (:[]) <$> (DStandaloneDerivD <$> mapM dsDerivStrategy mds <*> pure Nothing <*> dsCxt cxt <*> dsType ty) #else dsDec (StandaloneDerivD cxt ty) = (:[]) <$> (DStandaloneDerivD Nothing Nothing <$> dsCxt cxt <*> dsType ty) #endif dsDec (DefaultSigD n ty) = (:[]) <$> (DDefaultSigD n <$> dsType ty) #if __GLASGOW_HASKELL__ >= 807 dsDec (ImplicitParamBindD {}) = impossible "Non-`let`-bound implicit param binding" #endif #if __GLASGOW_HASKELL__ >= 809 dsDec (KiSigD n ki) = (:[]) <$> (DKiSigD n <$> dsType ki) #endif #if __GLASGOW_HASKELL__ >= 903 dsDec (DefaultD tys) = (:[]) <$> (DDefaultD <$> mapM dsType tys) #endif #if __GLASGOW_HASKELL__ >= 906 dsDec (TypeDataD n tys mk cons) = dsDataDec TypeData [] n tys mk cons [] #endif -- | Desugar a 'DataD', 'NewtypeD', or 'TypeDataD'. dsDataDec :: DsMonad q => DataFlavor -> Cxt -> Name -> [TyVarBndrUnit] -> Maybe Kind -> [Con] -> [DerivingClause] -> q [DDec] dsDataDec nd cxt n tvbs mk cons derivings = do tvbs' <- mapM dsTvbUnit tvbs let h98_tvbs = case mk of -- If there's an explicit return kind, we're dealing with a -- GADT, so this argument goes unused in dsCon. Just {} -> unusedArgument Nothing -> tvbs' h98_return_type = nonFamilyDataReturnType n tvbs' (:[]) <$> (DDataD nd <$> dsCxt cxt <*> pure n <*> pure tvbs' <*> mapM dsType mk <*> concatMapM (dsCon h98_tvbs h98_return_type) cons <*> mapM dsDerivClause derivings) -- | Desugar a 'DataInstD' or a 'NewtypeInstD'. dsDataInstDec :: DsMonad q => DataFlavor -> Cxt -> Name -> Maybe [TyVarBndrUnit] -> [TypeArg] -> Maybe Kind -> [Con] -> [DerivingClause] -> q [DDec] dsDataInstDec nd cxt n mtvbs tys mk cons derivings = do mtvbs' <- mapM (mapM dsTvbUnit) mtvbs tys' <- mapM dsTypeArg tys let lhs' = applyDType (DConT n) tys' h98_tvbs = case (mk, mtvbs') of -- If there's an explicit return kind, we're dealing with a -- GADT, so this argument goes unused in dsCon. (Just {}, _) -> unusedArgument -- H98, and there is an explicit `forall` in front. Just reuse the -- type variable binders from the `forall`. (Nothing, Just tvbs') -> tvbs' -- H98, and no explicit `forall`. Compute the bound variables -- manually. (Nothing, Nothing) -> dataFamInstTvbs tys' h98_fam_inst_type = dataFamInstReturnType n tys' (:[]) <$> (DDataInstD nd <$> dsCxt cxt <*> pure mtvbs' <*> pure lhs' <*> mapM dsType mk <*> concatMapM (dsCon h98_tvbs h98_fam_inst_type) cons <*> mapM dsDerivClause derivings) -- | Desugar a @FamilyResultSig@ dsFamilyResultSig :: DsMonad q => FamilyResultSig -> q DFamilyResultSig dsFamilyResultSig NoSig = return DNoSig dsFamilyResultSig (KindSig k) = DKindSig <$> dsType k dsFamilyResultSig (TyVarSig tvb) = DTyVarSig <$> dsTvbUnit tvb -- | Desugar a @TypeFamilyHead@ dsTypeFamilyHead :: DsMonad q => TypeFamilyHead -> q DTypeFamilyHead dsTypeFamilyHead (TypeFamilyHead n tvbs result inj) = DTypeFamilyHead n <$> mapM dsTvbUnit tvbs <*> dsFamilyResultSig result <*> pure inj typeFamilyHeadName :: TypeFamilyHead -> Name typeFamilyHeadName (TypeFamilyHead n _ _ _) = n -- | Desugar @Dec@s that can appear in a @let@ expression. See the -- documentation for 'dsLetDec' for an explanation of what the return type -- represents. dsLetDecs :: DsMonad q => [Dec] -> q ([DLetDec], DExp -> DExp) dsLetDecs decs = do (let_decss, ip_binders) <- mapAndUnzipM dsLetDec decs let let_decs :: [DLetDec] let_decs = concat let_decss ip_binder :: DExp -> DExp ip_binder = foldr (.) id ip_binders return (let_decs, ip_binder) -- | Desugar a single 'Dec' that can appear in a @let@ expression. -- This produces the following output: -- -- * One or more 'DLetDec's (a single 'Dec' can produce multiple 'DLetDec's -- in the event of a value declaration that binds multiple things by way -- of pattern matching. -- -- * A function of type @'DExp' -> 'DExp'@, which should be applied to the -- expression immediately following the 'DLetDec's. This function prepends -- binding forms for any implicit params that were bound in the argument -- 'Dec'. (If no implicit params are bound, this is simply the 'id' -- function.) -- -- For instance, if the argument to 'dsLetDec' is the @?x = 42@ part of this -- expression: -- -- @ -- let { ?x = 42 } in ?x -- @ -- -- Then the output is: -- -- * @let new_x_val = 42@ -- -- * @\\z -> 'bindIP' \@\"x\" new_x_val z@ -- -- This way, the expression -- @let { new_x_val = 42 } in 'bindIP' \@"x" new_x_val ('ip' \@\"x\")@ can be -- formed. The implicit param binders always come after all the other -- 'DLetDec's to support parallel assignment of implicit params. dsLetDec :: DsMonad q => Dec -> q ([DLetDec], DExp -> DExp) dsLetDec (FunD name clauses) = do clauses' <- dsClauses (FunRhs name) clauses return ([DFunD name clauses'], id) dsLetDec (ValD pat body where_decs) = do (pat', vars) <- dsPatX pat body' <- dsBody body where_decs error_exp let extras = uncurry (zipWith (DValD . DVarP)) $ unzip vars return (DValD pat' body' : extras, id) where error_exp = mkErrorMatchExpr (LetDecRhs pat) dsLetDec (SigD name ty) = do ty' <- dsType ty return ([DSigD name ty'], id) dsLetDec (InfixD fixity name) = return ([DInfixD fixity name], id) dsLetDec (PragmaD prag) = do prag' <- dsPragma prag return ([DPragmaD prag'], id) #if __GLASGOW_HASKELL__ >= 807 dsLetDec (ImplicitParamBindD n e) = do new_n_name <- qNewName $ "new_" ++ n ++ "_val" e' <- dsExp e let let_dec :: DLetDec let_dec = DValD (DVarP new_n_name) e' ip_binder :: DExp -> DExp ip_binder = (DVarE 'bindIP `DAppTypeE` DLitT (StrTyLit n) `DAppE` DVarE new_n_name `DAppE`) return ([let_dec], ip_binder) #endif dsLetDec _dec = impossible "Illegal declaration in let expression." -- | Desugar a single 'Dec' corresponding to something that could appear after -- the @let@ in a @let@ expression, but occurring at the top level. Because the -- 'Dec' occurs at the top level, there is nothing that would correspond to the -- @in ...@ part of the @let@ expression. As a consequence, this function does -- not return a @'DExp' -> 'DExp'@ function corresonding to implicit param -- binders (these cannot occur at the top level). dsTopLevelLetDec :: DsMonad q => Dec -> q [DDec] dsTopLevelLetDec = fmap (map DLetDec . fst) . dsLetDec -- Note the use of fst above: we're silently throwing away any implicit param -- binders that dsLetDec returns, since there is invariant that there will be -- no implicit params in the first place. -- | Desugar a single @Con@. -- -- Because we always desugar @Con@s to GADT syntax (see the documentation for -- 'DCon'), it is not always possible to desugar with just a 'Con' alone. -- For instance, we must desugar: -- -- @ -- data Foo a = forall b. MkFoo b -- @ -- -- To this: -- -- @ -- data Foo a :: Type where -- MkFoo :: forall a b. b -> Foo a -- @ -- -- If our only argument was @forall b. MkFoo b@, it would be somewhat awkward -- to figure out (1) what the set of universally quantified type variables -- (@[a]@) was, and (2) what the return type (@Foo a@) was. For this reason, -- we require passing these as arguments. (If we desugar an actual GADT -- constructor, these arguments are ignored.) dsCon :: DsMonad q => [DTyVarBndrUnit] -- ^ The universally quantified type variables -- (used if desugaring a non-GADT constructor). -> DType -- ^ The original data declaration's type -- (used if desugaring a non-GADT constructor). -> Con -> q [DCon] dsCon univ_dtvbs data_type con = do dcons' <- dsCon' con return $ flip map dcons' $ \(n, dtvbs, dcxt, fields, m_gadt_type) -> case m_gadt_type of Nothing -> let ex_dtvbs = dtvbs expl_dtvbs = changeDTVFlags SpecifiedSpec univ_dtvbs ++ ex_dtvbs impl_dtvbs = changeDTVFlags SpecifiedSpec $ toposortTyVarsOf $ mapMaybe extractTvbKind expl_dtvbs in DCon (impl_dtvbs ++ expl_dtvbs) dcxt n fields data_type Just gadt_type -> let univ_ex_dtvbs = dtvbs in DCon univ_ex_dtvbs dcxt n fields gadt_type -- Desugar a Con in isolation. The meaning of the returned DTyVarBndrs changes -- depending on what the returned Maybe DType value is: -- -- * If returning Just gadt_ty, then we've encountered a GadtC or RecGadtC, -- so the returned DTyVarBndrs are both the universally and existentially -- quantified tyvars. -- * If returning Nothing, we're dealing with a non-GADT constructor, so -- the returned DTyVarBndrs are the existentials only. dsCon' :: DsMonad q => Con -> q [(Name, [DTyVarBndrSpec], DCxt, DConFields, Maybe DType)] dsCon' (NormalC n stys) = do dtys <- mapM dsBangType stys return [(n, [], [], DNormalC False dtys, Nothing)] dsCon' (RecC n vstys) = do vdtys <- mapM dsVarBangType vstys return [(n, [], [], DRecC vdtys, Nothing)] dsCon' (InfixC sty1 n sty2) = do dty1 <- dsBangType sty1 dty2 <- dsBangType sty2 return [(n, [], [], DNormalC True [dty1, dty2], Nothing)] dsCon' (ForallC tvbs cxt con) = do dtvbs <- mapM dsTvbSpec tvbs dcxt <- dsCxt cxt dcons' <- dsCon' con return $ flip map dcons' $ \(n, dtvbs', dcxt', fields, m_gadt_type) -> (n, dtvbs ++ dtvbs', dcxt ++ dcxt', fields, m_gadt_type) dsCon' (GadtC nms btys rty) = do dbtys <- mapM dsBangType btys drty <- dsType rty sequence $ flip map nms $ \nm -> do mbFi <- reifyFixityWithLocals nm -- A GADT data constructor is declared infix when these three -- properties hold: let decInfix = isInfixDataCon (nameBase nm) -- 1. Its name uses operator syntax -- (e.g., (:*:)) && length dbtys == 2 -- 2. It has exactly two fields && isJust mbFi -- 3. It has a programmer-specified -- fixity declaration return (nm, [], [], DNormalC decInfix dbtys, Just drty) dsCon' (RecGadtC nms vbtys rty) = do dvbtys <- mapM dsVarBangType vbtys drty <- dsType rty return $ flip map nms $ \nm -> (nm, [], [], DRecC dvbtys, Just drty) -- | Desugar a @BangType@. dsBangType :: DsMonad q => BangType -> q DBangType dsBangType (b, ty) = (b, ) <$> dsType ty -- | Desugar a @VarBangType@. dsVarBangType :: DsMonad q => VarBangType -> q DVarBangType dsVarBangType (n, b, ty) = (n, b, ) <$> dsType ty -- | Desugar a @Foreign@. dsForeign :: DsMonad q => Foreign -> q DForeign dsForeign (ImportF cc safety str n ty) = DImportF cc safety str n <$> dsType ty dsForeign (ExportF cc str n ty) = DExportF cc str n <$> dsType ty -- | Desugar a @Pragma@. dsPragma :: DsMonad q => Pragma -> q DPragma dsPragma (InlineP n inl rm phases) = return $ DInlineP n inl rm phases dsPragma (SpecialiseP n ty m_inl phases) = DSpecialiseP n <$> dsType ty <*> pure m_inl <*> pure phases dsPragma (SpecialiseInstP ty) = DSpecialiseInstP <$> dsType ty #if __GLASGOW_HASKELL__ >= 807 dsPragma (RuleP str mtvbs rbs lhs rhs phases) = DRuleP str <$> mapM (mapM dsTvbUnit) mtvbs <*> mapM dsRuleBndr rbs <*> dsExp lhs <*> dsExp rhs <*> pure phases #else dsPragma (RuleP str rbs lhs rhs phases) = DRuleP str Nothing <$> mapM dsRuleBndr rbs <*> dsExp lhs <*> dsExp rhs <*> pure phases #endif dsPragma (AnnP target exp) = DAnnP target <$> dsExp exp dsPragma (LineP n str) = return $ DLineP n str #if __GLASGOW_HASKELL__ >= 801 dsPragma (CompleteP cls mty) = return $ DCompleteP cls mty #endif #if __GLASGOW_HASKELL__ >= 903 dsPragma (OpaqueP n) = return $ DOpaqueP n #endif -- | Desugar a @RuleBndr@. dsRuleBndr :: DsMonad q => RuleBndr -> q DRuleBndr dsRuleBndr (RuleVar n) = return $ DRuleVar n dsRuleBndr (TypedRuleVar n ty) = DTypedRuleVar n <$> dsType ty #if __GLASGOW_HASKELL__ >= 807 -- | Desugar a @TySynEqn@. (Available only with GHC 7.8+) -- -- This requires a 'Name' as an argument since 'TySynEqn's did not have -- this information prior to GHC 8.8. dsTySynEqn :: DsMonad q => Name -> TySynEqn -> q DTySynEqn dsTySynEqn _ (TySynEqn mtvbs lhs rhs) = DTySynEqn <$> mapM (mapM dsTvbUnit) mtvbs <*> dsType lhs <*> dsType rhs #else -- | Desugar a @TySynEqn@. (Available only with GHC 7.8+) dsTySynEqn :: DsMonad q => Name -> TySynEqn -> q DTySynEqn dsTySynEqn n (TySynEqn lhss rhs) = do lhss' <- mapM dsType lhss let lhs' = applyDType (DConT n) $ map DTANormal lhss' DTySynEqn Nothing lhs' <$> dsType rhs #endif -- | Desugar clauses to a function definition dsClauses :: DsMonad q => MatchContext -- ^ The context in which the clauses arise -> [Clause] -- ^ Clauses to desugar -> q [DClause] dsClauses _ [] = return [] dsClauses mc (Clause pats (NormalB exp) where_decs : rest) = do -- this case is necessary to maintain the roundtrip property. rest' <- dsClauses mc rest exp' <- dsExp exp (where_decs', ip_binder) <- dsLetDecs where_decs let exp_with_wheres = maybeDLetE where_decs' (ip_binder exp') (pats', exp'') <- dsPatsOverExp pats exp_with_wheres return $ DClause pats' exp'' : rest' dsClauses mc clauses@(Clause outer_pats _ _ : _) = do arg_names <- replicateM (length outer_pats) (newUniqueName "arg") let scrutinee = mkUnboxedTupleDExp (map DVarE arg_names) clause <- DClause (map DVarP arg_names) <$> (DCaseE scrutinee <$> foldrM (clause_to_dmatch scrutinee) [] clauses) return [clause] where clause_to_dmatch :: DsMonad q => DExp -> Clause -> [DMatch] -> q [DMatch] clause_to_dmatch scrutinee (Clause pats body where_decs) failure_matches = do let failure_exp = maybeDCaseE mc scrutinee failure_matches exp <- dsBody body where_decs failure_exp (pats', exp') <- dsPatsOverExp pats exp uni_pats <- fmap getAll $ concatMapM (fmap All . isUniversalPattern) pats' let match = DMatch (mkUnboxedTupleDPat pats') exp' if uni_pats then return [match] else return (match : failure_matches) -- | The context of a pattern match. This is used to produce -- @Non-exhaustive patterns in...@ messages that are tailored to specific -- situations. Compare this to GHC's @HsMatchContext@ data type -- (https://gitlab.haskell.org/ghc/ghc/-/blob/81cf52bb301592ff3d043d03eb9a0d547891a3e1/compiler/Language/Haskell/Syntax/Expr.hs#L1662-1695), -- from which the @MatchContext@ data type takes inspiration. data MatchContext = FunRhs Name -- ^ A pattern matching on an argument of a function binding | LetDecRhs Pat -- ^ A pattern in a @let@ declaration | RecUpd -- ^ A record update | MultiWayIfAlt -- ^ Guards in a multi-way if alternative | CaseAlt -- ^ Patterns and guards in a case alternative -- | Construct an expression that throws an error when encountering a pattern -- at runtime that is not covered by pattern matching. mkErrorMatchExpr :: MatchContext -> DExp mkErrorMatchExpr mc = DAppE (DVarE 'error) (DLitE (StringL ("Non-exhaustive patterns in " ++ pp_context))) where pp_context = case mc of FunRhs n -> show n LetDecRhs pat -> pprint pat RecUpd -> "record update" MultiWayIfAlt -> "multi-way if" CaseAlt -> "case" -- | Desugar a type dsType :: DsMonad q => Type -> q DType #if __GLASGOW_HASKELL__ >= 900 -- See Note [Gracefully handling linear types] dsType (MulArrowT `AppT` _) = return DArrowT dsType MulArrowT = fail "Cannot desugar exotic uses of linear types." #endif dsType (ForallT tvbs preds ty) = mkDForallConstrainedT <$> (DForallInvis <$> mapM dsTvbSpec tvbs) <*> dsCxt preds <*> dsType ty dsType (AppT t1 t2) = DAppT <$> dsType t1 <*> dsType t2 dsType (SigT ty ki) = DSigT <$> dsType ty <*> dsType ki dsType (VarT name) = return $ DVarT name dsType (ConT name) = return $ DConT name -- The PromotedT case is identical to the ConT case above. -- See Note [Desugaring promoted types]. dsType (PromotedT name) = return $ DConT name dsType (TupleT n) = return $ DConT (tupleTypeName n) dsType (UnboxedTupleT n) = return $ DConT (unboxedTupleTypeName n) dsType ArrowT = return DArrowT dsType ListT = return $ DConT ''[] dsType (PromotedTupleT n) = return $ DConT (tupleDataName n) dsType PromotedNilT = return $ DConT '[] dsType PromotedConsT = return $ DConT '(:) dsType StarT = return $ DConT typeKindName dsType ConstraintT = return $ DConT ''Constraint dsType (LitT lit) = return $ DLitT lit dsType EqualityT = return $ DConT ''(~) dsType (InfixT t1 n t2) = dsInfixT t1 n t2 dsType (UInfixT{}) = dsUInfixT dsType (ParensT t) = dsType t dsType WildCardT = return DWildCardT #if __GLASGOW_HASKELL__ >= 801 dsType (UnboxedSumT arity) = return $ DConT (unboxedSumTypeName arity) #endif #if __GLASGOW_HASKELL__ >= 807 dsType (AppKindT t k) = DAppKindT <$> dsType t <*> dsType k dsType (ImplicitParamT n t) = do t' <- dsType t return $ DConT ''IP `DAppT` DLitT (StrTyLit n) `DAppT` t' #endif #if __GLASGOW_HASKELL__ >= 809 dsType (ForallVisT tvbs ty) = DForallT <$> (DForallVis <$> mapM dsTvbUnit tvbs) <*> dsType ty #endif #if __GLASGOW_HASKELL__ >= 903 -- The PromotedInfixT case is identical to the InfixT case above. -- See Note [Desugaring promoted types]. dsType (PromotedInfixT t1 n t2) = dsInfixT t1 n t2 dsType PromotedUInfixT{} = dsUInfixT #endif #if __GLASGOW_HASKELL__ >= 900 -- | Desugar a 'TyVarBndr'. dsTvb :: DsMonad q => TyVarBndr_ flag -> q (DTyVarBndr flag) dsTvb (PlainTV n flag) = return $ DPlainTV n flag dsTvb (KindedTV n flag k) = DKindedTV n flag <$> dsType k #else -- | Desugar a 'TyVarBndr' with a particular @flag@. dsTvb :: DsMonad q => flag -> TyVarBndr -> q (DTyVarBndr flag) dsTvb flag (PlainTV n) = return $ DPlainTV n flag dsTvb flag (KindedTV n k) = DKindedTV n flag <$> dsType k #endif {- Note [Gracefully handling linear types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Per the README, th-desugar does not currently support linear types. Unfortunately, we cannot simply reject all occurrences of multiplicity-polymorphic function arrows (i.e., MulArrowT), as it is possible for "non-linear" code to contain them when reified. For example, the type of a Haskell98 data constructor such as `Just` will be reified as a #-> Maybe a In terms of the TH AST, that is: MulArrowT `AppT` PromotedConT 'One `AppT` VarT a `AppT` (ConT ''Maybe `AppT` VarT a) Therefore, in order to desugar these sorts of types, we have to do *something* with MulArrowT. The approach that th-desugar takes is to pretend that all multiplicity-polymorphic function arrows are actually ordinary function arrows (->) when desugaring types. In other words, whenever th-desugar sees (MulArrowT `AppT` m), for any particular value of `m`, it will turn it into DArrowT. This approach is enough to gracefully handle most uses of MulArrowT, as TH reification always generates MulArrowT applied to some particular multiplicity (as of GHC 9.0, at least). It's conceivable that some wily user could manually construct a TH AST containing MulArrowT in a different position, but since this situation is rare, we simply throw an error in such cases. We adopt a similar stance in L.H.TH.Desugar.Reify when locally reifying the types of data constructors: since th-desugar doesn't currently support linear types, we pretend as if MulArrowT does not exist. As a result, the type of `Just` would be locally reified as `a -> Maybe a`, not `a #-> Maybe a`. Note [Desugaring promoted types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ConT and PromotedT both contain Names as a payload, the only difference being that PromotedT is intended to refer exclusively to promoted data constructor Names, while ConT can refer to both type and data constructor Names alike. When desugaring a PromotedT, we make the assumption that the TH quoting mechanism produced the correct Name and wrap the name in a DConT. In other words, we desugar ConT and PromotedT identically. This assumption about PromotedT may not always be correct, however. Consider this example: data a :+: b = Inl a | Inr b data Exp a = ... | Exp :+: Exp How should `PromotedT (mkName ":+:")` be desugared? Morally, it ought to be desugared to a DConT that contains (:+:) the data constructor, not (:+:) the type constructor. Deciding between the two is not always straightforward, however. We could use the `lookupDataName` function to try and distinguish between the two Names, but this may not necessarily work. This is because the Name passed to `lookupDataName` could have its original module attached, which may not be in scope. Long story short: we make things simple (albeit slightly wrong) by desugaring ConT and PromotedT identically. We'll wait for someone to complain about the wrongness of this approach before researching a more accurate solution. Note that the same considerations also apply to InfixT and PromotedInfixT, which are also desugared identically. -} -- | Desugar an infix 'Type'. dsInfixT :: DsMonad q => Type -> Name -> Type -> q DType dsInfixT t1 n t2 = DAppT <$> (DAppT (DConT n) <$> dsType t1) <*> dsType t2 -- | We cannot desugar unresolved infix operators, so fail if we encounter one. dsUInfixT :: Fail.MonadFail m => m a dsUInfixT = fail "Cannot desugar unresolved infix operators." -- | Desugar a 'TyVarBndrSpec'. dsTvbSpec :: DsMonad q => TyVarBndrSpec -> q DTyVarBndrSpec #if __GLASGOW_HASKELL__ >= 900 dsTvbSpec = dsTvb #else dsTvbSpec = dsTvb SpecifiedSpec #endif -- | Desugar a 'TyVarBndrUnit'. dsTvbUnit :: DsMonad q => TyVarBndrUnit -> q DTyVarBndrUnit #if __GLASGOW_HASKELL__ >= 900 dsTvbUnit = dsTvb #else dsTvbUnit = dsTvb () #endif -- | Desugar a @Cxt@ dsCxt :: DsMonad q => Cxt -> q DCxt dsCxt = concatMapM dsPred #if __GLASGOW_HASKELL__ >= 801 -- | A backwards-compatible type synonym for the thing representing a single -- derived class in a @deriving@ clause. (This is a @DerivClause@, @Pred@, or -- @Name@ depending on the GHC version.) type DerivingClause = DerivClause -- | Desugar a @DerivingClause@. dsDerivClause :: DsMonad q => DerivingClause -> q DDerivClause dsDerivClause (DerivClause mds cxt) = DDerivClause <$> mapM dsDerivStrategy mds <*> dsCxt cxt #else type DerivingClause = Pred dsDerivClause :: DsMonad q => DerivingClause -> q DDerivClause dsDerivClause p = DDerivClause Nothing <$> dsPred p #endif #if __GLASGOW_HASKELL__ >= 801 -- | Desugar a @DerivStrategy@. dsDerivStrategy :: DsMonad q => DerivStrategy -> q DDerivStrategy dsDerivStrategy StockStrategy = pure DStockStrategy dsDerivStrategy AnyclassStrategy = pure DAnyclassStrategy dsDerivStrategy NewtypeStrategy = pure DNewtypeStrategy #if __GLASGOW_HASKELL__ >= 805 dsDerivStrategy (ViaStrategy ty) = DViaStrategy <$> dsType ty #endif #endif #if __GLASGOW_HASKELL__ >= 801 -- | Desugar a @PatSynDir@. (Available only with GHC 8.2+) dsPatSynDir :: DsMonad q => Name -> PatSynDir -> q DPatSynDir dsPatSynDir _ Unidir = pure DUnidir dsPatSynDir _ ImplBidir = pure DImplBidir dsPatSynDir n (ExplBidir clauses) = DExplBidir <$> dsClauses (FunRhs n) clauses #endif -- | Desugar a @Pred@, flattening any internal tuples dsPred :: DsMonad q => Pred -> q DCxt dsPred t | Just ts <- splitTuple_maybe t = concatMapM dsPred ts dsPred (ForallT tvbs cxt p) = dsForallPred tvbs cxt p dsPred (AppT t1 t2) = do [p1] <- dsPred t1 -- tuples can't be applied! (:[]) <$> DAppT p1 <$> dsType t2 dsPred (SigT ty ki) = do preds <- dsPred ty case preds of [p] -> (:[]) <$> DSigT p <$> dsType ki other -> return other -- just drop the kind signature on a tuple. dsPred (VarT n) = return [DVarT n] dsPred (ConT n) = return [DConT n] dsPred t@(PromotedT _) = impossible $ "Promoted type seen as head of constraint: " ++ show t dsPred (TupleT 0) = return [DConT (tupleTypeName 0)] dsPred (TupleT _) = impossible "Internal error in th-desugar in detecting tuple constraints." dsPred t@(UnboxedTupleT _) = impossible $ "Unboxed tuple seen as head of constraint: " ++ show t dsPred ArrowT = impossible "Arrow seen as head of constraint." dsPred ListT = impossible "List seen as head of constraint." dsPred (PromotedTupleT _) = impossible "Promoted tuple seen as head of constraint." dsPred PromotedNilT = impossible "Promoted nil seen as head of constraint." dsPred PromotedConsT = impossible "Promoted cons seen as head of constraint." dsPred StarT = impossible "* seen as head of constraint." dsPred ConstraintT = impossible "The kind `Constraint' seen as head of constraint." dsPred t@(LitT _) = impossible $ "Type literal seen as head of constraint: " ++ show t dsPred EqualityT = return [DConT ''(~)] dsPred (InfixT t1 n t2) = (:[]) <$> dsInfixT t1 n t2 dsPred (UInfixT{}) = dsUInfixT dsPred (ParensT t) = dsPred t dsPred WildCardT = return [DWildCardT] #if __GLASGOW_HASKELL__ >= 801 dsPred t@(UnboxedSumT {}) = impossible $ "Unboxed sum seen as head of constraint: " ++ show t #endif #if __GLASGOW_HASKELL__ >= 807 dsPred (AppKindT t k) = do [p] <- dsPred t (:[]) <$> (DAppKindT p <$> dsType k) dsPred (ImplicitParamT n t) = do t' <- dsType t return [DConT ''IP `DAppT` DLitT (StrTyLit n) `DAppT` t'] #endif #if __GLASGOW_HASKELL__ >= 809 dsPred t@(ForallVisT {}) = impossible $ "Visible dependent quantifier seen as head of constraint: " ++ show t #endif #if __GLASGOW_HASKELL__ >= 900 dsPred MulArrowT = impossible "Linear arrow seen as head of constraint." #endif #if __GLASGOW_HASKELL__ >= 903 dsPred t@PromotedInfixT{} = impossible $ "Promoted infix type seen as head of constraint: " ++ show t dsPred PromotedUInfixT{} = dsUInfixT #endif -- | Desugar a quantified constraint. dsForallPred :: DsMonad q => [TyVarBndrSpec] -> Cxt -> Pred -> q DCxt dsForallPred tvbs cxt p = do ps' <- dsPred p case ps' of [p'] -> (:[]) <$> (mkDForallConstrainedT <$> (DForallInvis <$> mapM dsTvbSpec tvbs) <*> dsCxt cxt <*> pure p') _ -> fail "Cannot desugar constraint tuples in the body of a quantified constraint" -- See GHC #15334. -- | Like 'reify', but safer and desugared. Uses local declarations where -- available. dsReify :: DsMonad q => Name -> q (Maybe DInfo) dsReify = traverse dsInfo <=< reifyWithLocals_maybe -- | Like 'reifyType', but safer and desugared. Uses local declarations where -- available. dsReifyType :: DsMonad q => Name -> q (Maybe DType) dsReifyType = traverse dsType <=< reifyTypeWithLocals_maybe -- Given a list of `forall`ed type variable binders and a context, construct -- a DType using DForallT and DConstrainedT as appropriate. The phrase -- "as appropriate" is used because DConstrainedT will not be used if the -- context is empty, per Note [Desugaring and sweetening ForallT]. mkDForallConstrainedT :: DForallTelescope -> DCxt -> DType -> DType mkDForallConstrainedT tele ctxt ty = DForallT tele $ if null ctxt then ty else DConstrainedT ctxt ty -- create a list of expressions in the same order as the fields in the first argument -- but with the values as given in the second argument -- if a field is missing from the second argument, use the corresponding expression -- from the third argument reorderFields :: DsMonad q => Name -> [VarStrictType] -> [FieldExp] -> [DExp] -> q [DExp] reorderFields = reorderFields' dsExp reorderFieldsPat :: DsMonad q => Name -> [VarStrictType] -> [FieldPat] -> PatM q [DPat] reorderFieldsPat con_name field_decs field_pats = reorderFields' dsPat con_name field_decs field_pats (repeat DWildP) reorderFields' :: (Applicative m, Fail.MonadFail m) => (a -> m da) -> Name -- ^ The name of the constructor (used for error reporting) -> [VarStrictType] -> [(Name, a)] -> [da] -> m [da] reorderFields' ds_thing con_name field_names_types field_things deflts = check_valid_fields >> reorder field_names deflts where field_names = map (\(a, _, _) -> a) field_names_types check_valid_fields = forM_ field_things $ \(thing_name, _) -> unless (thing_name `elem` field_names) $ fail $ "Constructor ‘" ++ nameBase con_name ++ "‘ does not have field ‘" ++ nameBase thing_name ++ "‘" reorder [] _ = return [] reorder (field_name : rest) (deflt : rest_deflt) = do rest' <- reorder rest rest_deflt case find (\(thing_name, _) -> thing_name == field_name) field_things of Just (_, thing) -> (: rest') <$> ds_thing thing Nothing -> return $ deflt : rest' reorder (_ : _) [] = error "Internal error in th-desugar." -- mkTupleDExp, mkUnboxedTupleDExp, and friends construct tuples, avoiding the -- use of 1-tuples. These are used to create auxiliary tuple values when -- desugaring pattern-matching constructs to simpler forms. -- See Note [Auxiliary tuples in pattern matching]. -- | Make a tuple 'DExp' from a list of 'DExp's. Avoids using a 1-tuple. mkTupleDExp :: [DExp] -> DExp mkTupleDExp [exp] = exp mkTupleDExp exps = foldl DAppE (DConE $ tupleDataName (length exps)) exps -- | Make an unboxed tuple 'DExp' from a list of 'DExp's. Avoids using a 1-tuple. mkUnboxedTupleDExp :: [DExp] -> DExp mkUnboxedTupleDExp [exp] = exp mkUnboxedTupleDExp exps = foldl DAppE (DConE $ unboxedTupleDataName (length exps)) exps -- | Make a tuple 'Exp' from a list of 'Exp's. Avoids using a 1-tuple. mkTupleExp :: [Exp] -> Exp mkTupleExp [exp] = exp mkTupleExp exps = foldl AppE (ConE $ tupleDataName (length exps)) exps -- | Make an unboxed tuple 'Exp' from a list of 'Exp's. Avoids using a 1-tuple. mkUnboxedTupleExp :: [Exp] -> Exp mkUnboxedTupleExp [exp] = exp mkUnboxedTupleExp exps = foldl AppE (ConE $ unboxedTupleDataName (length exps)) exps -- | Make a tuple 'DPat' from a list of 'DPat's. Avoids using a 1-tuple. mkTupleDPat :: [DPat] -> DPat mkTupleDPat [pat] = pat mkTupleDPat pats = DConP (tupleDataName (length pats)) [] pats -- | Make an unboxed tuple 'DPat' from a list of 'DPat's. Avoids using a 1-tuple. mkUnboxedTupleDPat :: [DPat] -> DPat mkUnboxedTupleDPat [pat] = pat mkUnboxedTupleDPat pats = DConP (unboxedTupleDataName (length pats)) [] pats -- | Is this pattern guaranteed to match? isUniversalPattern :: DsMonad q => DPat -> q Bool isUniversalPattern (DLitP {}) = return False isUniversalPattern (DVarP {}) = return True isUniversalPattern (DConP con_name _ pats) = do data_name <- dataConNameToDataName con_name (_df, _tvbs, cons) <- getDataD "Internal error." data_name if length cons == 1 then fmap and $ mapM isUniversalPattern pats else return False isUniversalPattern (DTildeP {}) = return True isUniversalPattern (DBangP pat) = isUniversalPattern pat isUniversalPattern (DSigP pat _) = isUniversalPattern pat isUniversalPattern DWildP = return True -- | Apply one 'DExp' to a list of arguments applyDExp :: DExp -> [DExp] -> DExp applyDExp = foldl DAppE -- | Apply one 'DType' to a list of arguments applyDType :: DType -> [DTypeArg] -> DType applyDType = foldl apply where apply :: DType -> DTypeArg -> DType apply f (DTANormal x) = f `DAppT` x apply f (DTyArg x) = f `DAppKindT` x -- | An argument to a type, either a normal type ('DTANormal') or a visible -- kind application ('DTyArg'). -- -- 'DTypeArg' does not appear directly in the @th-desugar@ AST, but it is -- useful when decomposing an application of a 'DType' to its arguments. data DTypeArg = DTANormal DType | DTyArg DKind deriving (Eq, Show, Data, Generic) -- | Desugar a 'TypeArg'. dsTypeArg :: DsMonad q => TypeArg -> q DTypeArg dsTypeArg (TANormal t) = DTANormal <$> dsType t dsTypeArg (TyArg k) = DTyArg <$> dsType k -- | Filter the normal type arguments from a list of 'DTypeArg's. filterDTANormals :: [DTypeArg] -> [DType] filterDTANormals = mapMaybe getDTANormal where getDTANormal :: DTypeArg -> Maybe DType getDTANormal (DTANormal t) = Just t getDTANormal (DTyArg {}) = Nothing -- | Convert a 'DTyVarBndr' into a 'DType' dTyVarBndrToDType :: DTyVarBndr flag -> DType dTyVarBndrToDType (DPlainTV a _) = DVarT a dTyVarBndrToDType (DKindedTV a _ k) = DVarT a `DSigT` k -- | Extract the underlying 'DType' or 'DKind' from a 'DTypeArg'. This forgets -- information about whether a type is a normal argument or not, so use with -- caution. probablyWrongUnDTypeArg :: DTypeArg -> DType probablyWrongUnDTypeArg (DTANormal t) = t probablyWrongUnDTypeArg (DTyArg k) = k -- Take a data type name (which does not belong to a data family) and -- apply it to its type variable binders to form a DType. nonFamilyDataReturnType :: Name -> [DTyVarBndrUnit] -> DType nonFamilyDataReturnType con_name = applyDType (DConT con_name) . map (DTANormal . dTyVarBndrToDType) -- Take a data family name and apply it to its argument types to form a -- data family instance DType. dataFamInstReturnType :: Name -> [DTypeArg] -> DType dataFamInstReturnType fam_name = applyDType (DConT fam_name) -- Data family instance declarations did not come equipped with a list of bound -- type variables until GHC 8.8 (and even then, it's optional whether the user -- provides them or not). This means that there are situations where we must -- reverse engineer this information ourselves from the list of type -- arguments. We accomplish this by taking the free variables of the types -- and performing a reverse topological sort on them to ensure that the -- returned list is well scoped. dataFamInstTvbs :: [DTypeArg] -> [DTyVarBndrUnit] dataFamInstTvbs = toposortTyVarsOf . map probablyWrongUnDTypeArg -- | Take a list of 'DType's, find their free variables, and sort them in -- reverse topological order to ensure that they are well scoped. In other -- words, the free variables are ordered such that: -- -- 1. Whenever an explicit kind signature of the form @(A :: K)@ is -- encountered, the free variables of @K@ will always appear to the left of -- the free variables of @A@ in the returned result. -- -- 2. The constraint in (1) notwithstanding, free variables will appear in -- left-to-right order of their original appearance. -- -- On older GHCs, this takes measures to avoid returning explicitly bound -- kind variables, which was not possible before @TypeInType@. toposortTyVarsOf :: [DType] -> [DTyVarBndrUnit] toposortTyVarsOf tys = let freeVars :: [Name] freeVars = F.toList $ foldMap fvDType tys varKindSigs :: Map Name DKind varKindSigs = foldMap go_ty tys where go_ty :: DType -> Map Name DKind go_ty (DForallT tele t) = go_tele tele (go_ty t) go_ty (DConstrainedT ctxt t) = foldMap go_ty ctxt `mappend` go_ty t go_ty (DAppT t1 t2) = go_ty t1 `mappend` go_ty t2 go_ty (DAppKindT t k) = go_ty t `mappend` go_ty k go_ty (DSigT t k) = let kSigs = go_ty k in case t of DVarT n -> M.insert n k kSigs _ -> go_ty t `mappend` kSigs go_ty (DVarT {}) = mempty go_ty (DConT {}) = mempty go_ty DArrowT = mempty go_ty (DLitT {}) = mempty go_ty DWildCardT = mempty go_tele :: DForallTelescope -> Map Name DKind -> Map Name DKind go_tele (DForallVis tvbs) = go_tvbs tvbs go_tele (DForallInvis tvbs) = go_tvbs tvbs go_tvbs :: [DTyVarBndr flag] -> Map Name DKind -> Map Name DKind go_tvbs tvbs m = foldr go_tvb m tvbs go_tvb :: DTyVarBndr flag -> Map Name DKind -> Map Name DKind go_tvb (DPlainTV n _) m = M.delete n m go_tvb (DKindedTV n _ k) m = M.delete n m `mappend` go_ty k -- | Do a topological sort on a list of tyvars, -- so that binders occur before occurrences -- E.g. given [ a::k, k::*, b::k ] -- it'll return a well-scoped list [ k::*, a::k, b::k ] -- -- This is a deterministic sorting operation -- (that is, doesn't depend on Uniques). -- -- It is also meant to be stable: that is, variables should not -- be reordered unnecessarily. scopedSort :: [Name] -> [Name] scopedSort = go [] [] go :: [Name] -- already sorted, in reverse order -> [Set Name] -- each set contains all the variables which must be placed -- before the tv corresponding to the set; they are accumulations -- of the fvs in the sorted tvs' kinds -- This list is in 1-to-1 correspondence with the sorted tyvars -- INVARIANT: -- all (\tl -> all (`isSubsetOf` head tl) (tail tl)) (tails fv_list) -- That is, each set in the list is a superset of all later sets. -> [Name] -- yet to be sorted -> [Name] go acc _fv_list [] = reverse acc go acc fv_list (tv:tvs) = go acc' fv_list' tvs where (acc', fv_list') = insert tv acc fv_list insert :: Name -- var to insert -> [Name] -- sorted list, in reverse order -> [Set Name] -- list of fvs, as above -> ([Name], [Set Name]) -- augmented lists insert tv [] [] = ([tv], [kindFVSet tv]) insert tv (a:as) (fvs:fvss) | tv `S.member` fvs , (as', fvss') <- insert tv as fvss = (a:as', fvs `S.union` fv_tv : fvss') | otherwise = (tv:a:as, fvs `S.union` fv_tv : fvs : fvss) where fv_tv = kindFVSet tv -- lists not in correspondence insert _ _ _ = error "scopedSort" kindFVSet n = maybe S.empty (OS.toSet . fvDType) (M.lookup n varKindSigs) ascribeWithKind n = maybe (DPlainTV n ()) (DKindedTV n ()) (M.lookup n varKindSigs) in map ascribeWithKind $ scopedSort freeVars dtvbName :: DTyVarBndr flag -> Name dtvbName (DPlainTV n _) = n dtvbName (DKindedTV n _ _) = n -- @mk_qual_do_name mb_mod orig_name@ will simply return @orig_name@ if -- @mb_mod@ is Nothing. If @mb_mod@ is @Just mod_@, then a new 'Name' will be -- returned that uses @mod_@ as the new module prefix. This is useful for -- emulating the behavior of the @QualifiedDo@ extension, which adds module -- prefixes to functions such as ('>>=') and ('>>'). mk_qual_do_name :: Maybe ModName -> Name -> Name mk_qual_do_name mb_mod orig_name = case mb_mod of Nothing -> orig_name Just mod_ -> Name (OccName (nameBase orig_name)) (NameQ mod_) -- | Reconstruct an arrow 'DType' from its argument and result types. ravelDType :: DFunArgs -> DType -> DType ravelDType DFANil res = res ravelDType (DFAForalls tele args) res = DForallT tele (ravelDType args res) ravelDType (DFACxt cxt args) res = DConstrainedT cxt (ravelDType args res) ravelDType (DFAAnon t args) res = DAppT (DAppT DArrowT t) (ravelDType args res) -- | Decompose a function 'DType' into its arguments (the 'DFunArgs') and its -- result type (the 'DType). unravelDType :: DType -> (DFunArgs, DType) unravelDType (DForallT tele ty) = let (args, res) = unravelDType ty in (DFAForalls tele args, res) unravelDType (DConstrainedT cxt ty) = let (args, res) = unravelDType ty in (DFACxt cxt args, res) unravelDType (DAppT (DAppT DArrowT t1) t2) = let (args, res) = unravelDType t2 in (DFAAnon t1 args, res) unravelDType t = (DFANil, t) -- | The list of arguments in a function 'DType'. data DFunArgs = DFANil -- ^ No more arguments. | DFAForalls DForallTelescope DFunArgs -- ^ A series of @forall@ed type variables followed by a dot (if -- 'ForallInvis') or an arrow (if 'ForallVis'). For example, -- the type variables @a1 ... an@ in @forall a1 ... an. r@. | DFACxt DCxt DFunArgs -- ^ A series of constraint arguments followed by @=>@. For example, -- the @(c1, ..., cn)@ in @(c1, ..., cn) => r@. | DFAAnon DType DFunArgs -- ^ An anonymous argument followed by an arrow. For example, the @a@ -- in @a -> r@. deriving (Eq, Show, Data, Generic) -- | A /visible/ function argument type (i.e., one that must be supplied -- explicitly in the source code). This is in contrast to /invisible/ -- arguments (e.g., the @c@ in @c => r@), which are instantiated without -- the need for explicit user input. data DVisFunArg = DVisFADep DTyVarBndrUnit -- ^ A visible @forall@ (e.g., @forall a -> a@). | DVisFAAnon DType -- ^ An anonymous argument followed by an arrow (e.g., @a -> r@). deriving (Eq, Show, Data, Generic) -- | Filter the visible function arguments from a list of 'DFunArgs'. filterDVisFunArgs :: DFunArgs -> [DVisFunArg] filterDVisFunArgs DFANil = [] filterDVisFunArgs (DFAForalls tele args) = case tele of DForallVis tvbs -> map DVisFADep tvbs ++ args' DForallInvis _ -> args' where args' = filterDVisFunArgs args filterDVisFunArgs (DFACxt _ args) = filterDVisFunArgs args filterDVisFunArgs (DFAAnon t args) = DVisFAAnon t:filterDVisFunArgs args -- | Decompose an applied type into its individual components. For example, this: -- -- @ -- Proxy \@Type Char -- @ -- -- would be unfolded to this: -- -- @ -- ('DConT' ''Proxy, ['DTyArg' ('DConT' ''Type), 'DTANormal' ('DConT' ''Char)]) -- @ unfoldDType :: DType -> (DType, [DTypeArg]) unfoldDType = go [] where go :: [DTypeArg] -> DType -> (DType, [DTypeArg]) go acc (DForallT _ ty) = go acc ty go acc (DAppT ty1 ty2) = go (DTANormal ty2:acc) ty1 go acc (DAppKindT ty ki) = go (DTyArg ki:acc) ty go acc (DSigT ty _) = go acc ty go acc ty = (ty, acc) -- | Extract the kind from a 'DTyVarBndr', if one is present. extractTvbKind :: DTyVarBndr flag -> Maybe DKind extractTvbKind (DPlainTV _ _) = Nothing extractTvbKind (DKindedTV _ _ k) = Just k -- | Set the flag in a list of 'DTyVarBndr's. This is often useful in contexts -- where one needs to re-use a list of 'DTyVarBndr's from one flag setting to -- another flag setting. For example, in order to re-use the 'DTyVarBndr's bound -- by a 'DDataD' in a 'DForallT', one can do the following: -- -- @ -- case x of -- 'DDataD' _ _ _ tvbs _ _ _ -> -- 'DForallT' ('DForallInvis' ('changeDTVFlags' 'SpecifiedSpec' tvbs)) ... -- @ changeDTVFlags :: newFlag -> [DTyVarBndr oldFlag] -> [DTyVarBndr newFlag] changeDTVFlags new_flag = map (new_flag <$) -- | Some functions in this module only use certain arguments on particular -- versions of GHC. Other versions of GHC (that don't make use of those -- arguments) might need to conjure up those arguments out of thin air at the -- functions' call sites, so this function serves as a placeholder to use in -- those situations. (In other words, this is a slightly more informative -- version of 'undefined'.) unusedArgument :: a unusedArgument = error "Unused" {- Note [Desugaring and sweetening ForallT] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The ForallT constructor from template-haskell is tremendously awkward. Because ForallT contains both a list of type variable binders and constraint arguments, ForallT expressions can be ambiguous when one of these lists is empty. For example, consider this expression with no constraints: ForallT [PlainTV a] [] (VarT a) What should this desugar to in th-desugar, which must maintain a clear separation between type variable binders and constraints? There are two possibilities: 1. DForallT DForallInvis [DPlainTV a] (DVarT a) (i.e., forall a. a) 2. DForallT DForallInvis [DPlainTV a] (DConstrainedT [] (DVarT a)) (i.e., forall a. () => a) Template Haskell generally drops these empty lists when splicing Template Haskell expressions, so we would like to do the same in th-desugar to mimic TH's behavior as closely as possible. However, there are some situations where dropping empty lists of `forall`ed type variable binders can change the semantics of a program. For instance, contrast `foo :: forall. a -> a` (which is an error) with `foo :: a -> a` (which is fine). Therefore, we try to preserve empty `forall`s to the best of our ability. Here is an informal specification of how th-desugar should handle different sorts of ambiguity. First, a specification for desugaring. Let `tvbs` and `ctxt` be non-empty: * `ForallT tvbs [] ty` should desugar to `DForallT DForallInvis tvbs ty`. * `ForallT [] ctxt ty` should desguar to `DForallT DForallInvis [] (DConstrainedT ctxt ty)`. * `ForallT [] [] ty` should desugar to `DForallT DForallInvis [] ty`. * For all other cases, just straightforwardly desugar `ForallT tvbs ctxt ty` to `DForallT DForallInvis tvbs (DConstraintedT ctxt ty)`. For sweetening: * `DForallT DForallInvis tvbs (DConstrainedT ctxt ty)` should sweeten to `ForallT tvbs ctxt ty`. * `DForallT DForallInvis [] (DConstrainedT ctxt ty)` should sweeten to `ForallT [] ctxt ty`. * `DForallT DForallInvis tvbs (DConstrainedT [] ty)` should sweeten to `ForallT tvbs [] ty`. * `DForallT DForallInvis [] (DConstrainedT [] ty)` should sweeten to `ForallT [] [] ty`. * For all other cases, just straightforwardly sweeten `DForallT DForallInvis tvbs ty` to `ForallT tvbs [] ty` and `DConstrainedT ctxt ty` to `ForallT [] ctxt ty`. Note [Auxiliary tuples in pattern matching] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ th-desugar simplifies the overall treatment of pattern matching in two notable ways: 1. Lambda expressions only bind variables and do not directly perform pattern matching. For example, this: \True False -> () Roughly desugars to: \x y -> case (x, y) of (True, False) -> () _ -> error "Non-exhaustive patterns" 2. th-desugar does not have guards, as guards are desugared into pattern matches. For example, this: f x y | True <- x , False <- y = () Roughly desugars to: f x y = case (x, y) of (True, False) -> () _ -> error "Non-exhaustive patterns" In both of these examples, there are multiple expressions being matched on simultaneously. When desugaring these examples to `case` expressions, we need a construct that allows us to group these patterns together. Auxiliary tuples are one way to accomplish this. While this use of tuples works well when the arguments have lifted types, such as Bool, it doesn't work when the arguments have unlifted types, such as Int#. Imagine desugaring this lambda expression, for instance: \27# 42# -> () The approach above would desugar this to: \x y -> case (x, y) of (27#, 42#) -> () _ -> error "Non-exhaustive patterns" This will not typecheck, however, as we are using _lifted_ tuples, which require their arguments to have lifted types. If we want to support unlifted types, we need a different approach. One idea that seems tempting at first is to create an auxiliary `let` expression, e.g., \x y -> let aux 27# 42# = () in aux x y This avoids having to use lifted tuples, but it creates a new problem: type inference. In the general case, auxiliary `let` expressions aren't enough to handle GADT pattern matches, such as in this example: data T a where MkT :: Int -> T Int g :: T a -> T a -> a g = \(MkT x1) (MkT x2) -> x1 + x2 If you desugar `g` to use an auxiliary `let` expression: g :: T a -> T a -> a g = \t1 t2 -> let aux (MkT x1) (MkT x2) = x1 + x2 in aux t1 t2 Then it will not typecheck. To make this work, you'd need to give `aux` a type signature. Doing this in general is tantamount to performing type inference, however, which is very challenging in a Template Haskell setting. Another approach, which is what th-desugar currently uses, is to use auxiliary _unboxed_ tuples. This is identical to the previous tuple approach, but with slightly different syntax: \x y -> case (# x, y #) of (# 27#, 42# #) -> () _ -> error "Non-exhaustive patterns" Unboxed tuples can handle lifted and unlifted arguments alike, so it is capable of handling all the examples above. You might worry that this approach would require clients of th-desugar to enable the UnboxedTuples extension in non-obvious places, but fortunately, this is not the case. For one thing, all unboxed tuples produced by th-desugar would be TH-generated, so we would bypass the need to enable UnboxedTuples to lex unboxed tuple syntax. GHC's typechecker also imposes a requirement that UnboxedTuples be enabled if a variable has an unboxed tuple type, but this never happens in th-desugar by construction. It's possible that a future version of GHC might be stricter about this, but it seems unlikely. There are a couple of exceptions to the general rule that auxiliary binders should be unboxed: 1. ParallelListComp is desugared using the `mzip` function, which returns a lifted pair. As a result, the variables bound in a parallel list comprehension must be lifted. This is a restriction which is inherited from GHC itself—https://gitlab.haskell.org/ghc/ghc/-/merge_requests/7270. 2. Match flattening desugars lazy patterns that bind multiple variables to code that extracts fields from tuples. For instance, this: data Pair a b = MkPair a b f :: Pair a b -> Pair b a f ~(MkPair x y) = MkPair y x Desugars to this (roughly) when match-flattened: f :: Pair a b -> Pair b a f p = let tuple = case p of MkPair x y -> (x, y) x = case tuple of (x, _) -> x y = case tuple of (_, y) -> x in MkPair y x One could imagine using an unboxed tuple here instead, but since the intermediate `tuple` value would have an unboxed tuple this, this would require users of match flattening to enable UnboxedTuples. Fortunately, using unboxed tuples here isn't necessary, as GHC doesn't support binding variables with unlifted types in lazy patterns anyway. -} th-desugar-1.15/Language/Haskell/TH/Desugar/Expand.hs0000644000000000000000000002213407346545000020464 0ustar0000000000000000{- Language/Haskell/TH/Desugar/Expand.hs (c) Richard Eisenberg 2013 rae@cs.brynmawr.edu -} {-# LANGUAGE NoMonomorphismRestriction, ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Language.Haskell.TH.Desugar.Expand -- Copyright : (C) 2014 Richard Eisenberg -- License : BSD-style (see LICENSE) -- Maintainer : Ryan Scott -- Stability : experimental -- Portability : non-portable -- -- Expands type synonyms and type families in desugared types. -- See also the package th-expand-syns for doing this to -- non-desugared types. -- ---------------------------------------------------------------------------- module Language.Haskell.TH.Desugar.Expand ( -- * Expand synonyms soundly expand, expandType, -- * Expand synonyms potentially unsoundly expandUnsoundly ) where import qualified Data.Map as M import Language.Haskell.TH hiding (cxt) import Language.Haskell.TH.Syntax ( Quasi(..) ) import Data.Data import Data.Generics import qualified Data.Traversable as T import Language.Haskell.TH.Desugar.AST import Language.Haskell.TH.Desugar.Core import Language.Haskell.TH.Desugar.Util import Language.Haskell.TH.Desugar.Sweeten import Language.Haskell.TH.Desugar.Reify import Language.Haskell.TH.Desugar.Subst -- | Expands all type synonyms in a desugared type. Also expands open type family -- applications. (In GHCs before 7.10, this part does not work if there are any -- variables.) Attempts to -- expand closed type family applications, but aborts the moment it spots anything -- strange, like a nested type family application or type variable. expandType :: DsMonad q => DType -> q DType expandType = expand_type NoIgnore expand_type :: forall q. DsMonad q => IgnoreKinds -> DType -> q DType expand_type ign = go [] where go :: [DTypeArg] -> DType -> q DType go [] (DForallT tele ty) = DForallT <$> expand_tele ign tele <*> expand_type ign ty go _ (DForallT {}) = impossible "A forall type is applied to another type." go [] (DConstrainedT cxt ty) = DConstrainedT <$> mapM (expand_type ign) cxt <*> expand_type ign ty go _ (DConstrainedT {}) = impossible "A constrained type is applied to another type." go args (DAppT t1 t2) = do t2' <- expand_type ign t2 go (DTANormal t2' : args) t1 go args (DAppKindT p k) = do k' <- expand_type ign k go (DTyArg k' : args) p go args (DSigT ty ki) = do ty' <- go [] ty ki' <- go [] ki finish (DSigT ty' ki') args go args (DConT n) = expand_con ign n args go args ty@(DVarT _) = finish ty args go args ty@DArrowT = finish ty args go args ty@(DLitT _) = finish ty args go args ty@DWildCardT = finish ty args finish :: DType -> [DTypeArg] -> q DType finish ty args = return $ applyDType ty args -- | Expands all type synonyms in the kinds of a @forall@ telescope. expand_tele :: DsMonad q => IgnoreKinds -> DForallTelescope -> q DForallTelescope expand_tele ign (DForallVis tvbs) = DForallVis <$> mapM (expand_tvb ign) tvbs expand_tele ign (DForallInvis tvbs) = DForallInvis <$> mapM (expand_tvb ign) tvbs -- | Expands all type synonyms in a type variable binder's kind. expand_tvb :: DsMonad q => IgnoreKinds -> DTyVarBndr flag -> q (DTyVarBndr flag) expand_tvb _ tvb@DPlainTV{} = pure tvb expand_tvb ign (DKindedTV n flag k) = DKindedTV n flag <$> expand_type ign k -- | Expand a constructor with given arguments expand_con :: forall q. DsMonad q => IgnoreKinds -> Name -- ^ Tycon name -> [DTypeArg] -- ^ Arguments -> q DType -- ^ Expanded type expand_con ign n args = do info <- reifyWithLocals n case info of TyConI (TySynD _ _ StarT) -- See Note [Don't expand synonyms for *] -> return $ applyDType (DConT typeKindName) args _ -> go info where -- Only the normal (i.e., non-visibly applied) arguments. These are -- important since we need to align these with the arguments of the type -- synonym/family, and visible kind arguments can mess with this. normal_args :: [DType] normal_args = filterDTANormals args go :: Info -> q DType go info = do dinfo <- dsInfo info case dinfo of DTyConI (DTySynD _n tvbs rhs) _ | length normal_args >= length tvbs -- this should always be true! -> do let (syn_args, rest_args) = splitAtList tvbs normal_args ty <- substTy (M.fromList $ zip (map dtvbName tvbs) syn_args) rhs ty' <- expand_type ign ty return $ applyDType ty' $ map DTANormal rest_args DTyConI (DOpenTypeFamilyD (DTypeFamilyHead _n tvbs _frs _ann)) _ | length normal_args >= length tvbs -- this should always be true! -> do let (syn_args, rest_args) = splitAtList tvbs normal_args -- We need to get the correct instance. If we fail to reify anything -- (e.g., if a type family is quasiquoted), then fall back by -- pretending that there are no instances in scope. insts <- qRecover (return []) $ qReifyInstances n (map typeToTH syn_args) dinsts <- dsDecs insts case dinsts of [DTySynInstD (DTySynEqn _ lhs rhs)] | (_, lhs_args) <- unfoldDType lhs , let lhs_normal_args = filterDTANormals lhs_args , Just subst <- unionMaybeSubsts $ zipWith (matchTy ign) lhs_normal_args syn_args -> do ty <- substTy subst rhs ty' <- expand_type ign ty return $ applyDType ty' $ map DTANormal rest_args _ -> give_up DTyConI (DClosedTypeFamilyD (DTypeFamilyHead _n tvbs _frs _ann) eqns) _ | length normal_args >= length tvbs -> do let (syn_args, rest_args) = splitAtList tvbs normal_args rhss <- mapMaybeM (check_eqn syn_args) eqns case rhss of (rhs : _) -> do rhs' <- expand_type ign rhs return $ applyDType rhs' $ map DTANormal rest_args [] -> give_up where -- returns the substed rhs check_eqn :: [DType] -> DTySynEqn -> q (Maybe DType) check_eqn arg_tys (DTySynEqn _ lhs rhs) = do let (_, lhs_args) = unfoldDType lhs normal_lhs_args = filterDTANormals lhs_args m_subst = unionMaybeSubsts $ zipWith (matchTy ign) normal_lhs_args arg_tys T.mapM (flip substTy rhs) m_subst _ -> give_up -- Used when we can't proceed with type family instance expansion any more, -- and must conservatively return the orignal type family applied to its -- arguments. give_up :: q DType give_up = return $ applyDType (DConT n) args {- Note [Don't expand synonyms for *] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We deliberately avoid expanding type synonyms for * such as Type and ★. Why? If you reify any such type synonym using Template Haskell, this is what you'll get: TyConI (TySynD [] StarT) If you blindly charge ahead and recursively inspect the right-hand side of this type synonym, you'll desugar StarT into (DConT ''Type), reify ''Type, and get back another type synonym with StarT as its right-hand side. Then you'll recursively inspect StarT and find yourself knee-deep in an infinite loop. To prevent these sorts of shenanigans, we simply stop whenever we see a type synonym with StarT as its right-hand side and return Type. -} -- | Expand all type synonyms and type families in the desugared abstract -- syntax tree provided, where type family simplification is on a "best effort" -- basis. Normally, the first parameter should have a type like -- 'DExp' or 'DLetDec'. expand :: (DsMonad q, Data a) => a -> q a expand = expand_ NoIgnore -- | Expand all type synonyms and type families in the desugared abstract -- syntax tree provided, where type family simplification is on a "better -- than best effort" basis. This means that it will try so hard that it will -- sometimes do the wrong thing. Specifically, any kind parameters to type -- families are ignored. So, if we have -- -- > type family F (x :: k) where -- > F (a :: *) = Int -- -- 'expandUnsoundly' will expand @F 'True@ to @Int@, ignoring that the -- expansion should only work for type of kind @*@. -- -- This function is useful because plain old 'expand' will simply fail -- to expand type families that make use of kinds. Sometimes, the kinds -- are benign and we want to expand anyway. Use this function in that case. expandUnsoundly :: (DsMonad q, Data a) => a -> q a expandUnsoundly = expand_ YesIgnore -- | Generalization of 'expand' that either can or won't ignore kind annotations.sx expand_ :: (DsMonad q, Data a) => IgnoreKinds -> a -> q a expand_ ign = everywhereM (mkM (expand_type ign)) th-desugar-1.15/Language/Haskell/TH/Desugar/FV.hs0000644000000000000000000000444307346545000017563 0ustar0000000000000000{- Language/Haskell/TH/Desugar/FV.hs (c) Ryan Scott 2018 Compute free variables of programs. -} {-# LANGUAGE CPP #-} module Language.Haskell.TH.Desugar.FV ( fvDType , extractBoundNamesDPat ) where #if __GLASGOW_HASKELL__ < 804 import Data.Monoid ((<>)) #endif import Language.Haskell.TH.Syntax import Language.Haskell.TH.Desugar.AST import qualified Language.Haskell.TH.Desugar.OSet as OS import Language.Haskell.TH.Desugar.OSet (OSet) -- | Compute the free variables of a 'DType'. fvDType :: DType -> OSet Name fvDType = go where go :: DType -> OSet Name go (DForallT tele ty) = fv_dtele tele (go ty) go (DConstrainedT ctxt ty) = foldMap fvDType ctxt <> go ty go (DAppT t1 t2) = go t1 <> go t2 go (DAppKindT t k) = go t <> go k go (DSigT ty ki) = go ty <> go ki go (DVarT n) = OS.singleton n go (DConT {}) = OS.empty go DArrowT = OS.empty go (DLitT {}) = OS.empty go DWildCardT = OS.empty ----- -- Extracting bound term names ----- -- | Extract the term variables bound by a 'DPat'. -- -- This does /not/ extract any type variables bound by pattern signatures. extractBoundNamesDPat :: DPat -> OSet Name extractBoundNamesDPat = go where go :: DPat -> OSet Name go (DLitP _) = OS.empty go (DVarP n) = OS.singleton n go (DConP _ tys pats) = foldMap fvDType tys <> foldMap go pats go (DTildeP p) = go p go (DBangP p) = go p go (DSigP p _) = go p go DWildP = OS.empty ----- -- Binding forms ----- -- | Adjust the free variables of something following a 'DForallTelescope'. fv_dtele :: DForallTelescope -> OSet Name -> OSet Name fv_dtele (DForallVis tvbs) = fv_dtvbs tvbs fv_dtele (DForallInvis tvbs) = fv_dtvbs tvbs -- | Adjust the free variables of something following 'DTyVarBndr's. fv_dtvbs :: [DTyVarBndr flag] -> OSet Name -> OSet Name fv_dtvbs tvbs fvs = foldr fv_dtvb fvs tvbs -- | Adjust the free variables of something following a 'DTyVarBndr'. fv_dtvb :: DTyVarBndr flag -> OSet Name -> OSet Name fv_dtvb (DPlainTV n _) fvs = OS.delete n fvs fv_dtvb (DKindedTV n _ k) fvs = OS.delete n fvs <> fvDType k th-desugar-1.15/Language/Haskell/TH/Desugar/Lift.hs0000644000000000000000000000133007346545000020136 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Language.Haskell.TH.Desugar.Lift -- Copyright : (C) 2014 Richard Eisenberg -- License : BSD-style (see LICENSE) -- Maintainer : Ryan Scott -- Stability : experimental -- Portability : non-portable -- -- Historically, this module defined orphan @Lift@ instances for the data types -- in @th-desugar@. Nowadays, these instances are defined alongside the data -- types themselves, so this module simply re-exports the instances. -- ---------------------------------------------------------------------------- module Language.Haskell.TH.Desugar.Lift () where import Language.Haskell.TH.Desugar () th-desugar-1.15/Language/Haskell/TH/Desugar/Match.hs0000644000000000000000000004027007346545000020302 0ustar0000000000000000{- Language/Haskell/TH/Desugar/Match.hs (c) Richard Eisenberg 2013 rae@cs.brynmawr.edu Simplifies case statements in desugared TH. After this pass, there are no more nested patterns. This code is directly based on the analogous operation as written in GHC. -} {-# LANGUAGE CPP, TemplateHaskellQuotes #-} module Language.Haskell.TH.Desugar.Match (scExp, scLetDec) where import Prelude hiding ( fail, exp ) import Control.Monad hiding ( fail ) import qualified Control.Monad as Monad import Data.Data import qualified Data.Foldable as F import Data.Generics import qualified Data.Set as S import qualified Data.Map as Map import Language.Haskell.TH.Instances () import Language.Haskell.TH.Syntax import Language.Haskell.TH.Desugar.AST import Language.Haskell.TH.Desugar.Core (dsReify, maybeDLetE, mkTupleDExp) import Language.Haskell.TH.Desugar.FV import qualified Language.Haskell.TH.Desugar.OSet as OS import Language.Haskell.TH.Desugar.Util import Language.Haskell.TH.Desugar.Reify -- | Remove all nested pattern-matches within this expression. This also -- removes all 'DTildePa's and 'DBangPa's. After this is run, every pattern -- is guaranteed to be either a 'DConPa' with bare variables as arguments, -- a 'DLitPa', or a 'DWildPa'. scExp :: DsMonad q => DExp -> q DExp scExp (DAppE e1 e2) = DAppE <$> scExp e1 <*> scExp e2 scExp (DLamE names exp) = DLamE names <$> scExp exp scExp (DCaseE scrut matches) | DVarE name <- scrut = simplCaseExp [name] clauses | otherwise = do scrut_name <- newUniqueName "scrut" case_exp <- simplCaseExp [scrut_name] clauses return $ DLetE [DValD (DVarP scrut_name) scrut] case_exp where clauses = map match_to_clause matches match_to_clause (DMatch pat exp) = DClause [pat] exp scExp (DLetE decs body) = DLetE <$> mapM scLetDec decs <*> scExp body scExp (DSigE exp ty) = DSigE <$> scExp exp <*> pure ty scExp (DAppTypeE exp ty) = DAppTypeE <$> scExp exp <*> pure ty scExp e@(DVarE {}) = return e scExp e@(DConE {}) = return e scExp e@(DLitE {}) = return e scExp e@(DStaticE {}) = return e -- | Like 'scExp', but for a 'DLetDec'. scLetDec :: DsMonad q => DLetDec -> q DLetDec scLetDec (DFunD name clauses@(DClause pats1 _ : _)) = do arg_names <- mapM (const (newUniqueName "_arg")) pats1 clauses' <- mapM sc_clause_rhs clauses case_exp <- simplCaseExp arg_names clauses' return $ DFunD name [DClause (map DVarP arg_names) case_exp] where sc_clause_rhs (DClause pats exp) = DClause pats <$> scExp exp scLetDec (DValD pat exp) = DValD pat <$> scExp exp scLetDec (DPragmaD prag) = DPragmaD <$> scLetPragma prag scLetDec dec@(DSigD {}) = return dec scLetDec dec@(DInfixD {}) = return dec scLetDec dec@(DFunD _ []) = return dec scLetPragma :: DsMonad q => DPragma -> q DPragma scLetPragma = topEverywhereM scExp -- Only topEverywhereM because scExp already recurses on its own type MatchResult = DExp -> DExp matchResultToDExp :: MatchResult -> DExp matchResultToDExp mr = mr failed_pattern_match where failed_pattern_match = DAppE (DVarE 'error) (DLitE $ StringL "Pattern-match failure") simplCaseExp :: DsMonad q => [Name] -> [DClause] -> q DExp simplCaseExp vars clauses = do let eis = [ EquationInfo pats (\_ -> rhs) | DClause pats rhs <- clauses ] matchResultToDExp `liftM` simplCase vars eis data EquationInfo = EquationInfo [DPat] MatchResult -- like DClause, but with a hole -- analogous to GHC's match (in deSugar/Match.lhs) simplCase :: DsMonad q => [Name] -- the names of the scrutinees -> [EquationInfo] -- the matches (where the # of pats == length (1st arg)) -> q MatchResult simplCase [] clauses = return (foldr1 (.) match_results) where match_results = [ mr | EquationInfo _ mr <- clauses ] simplCase vars@(v:_) clauses = do (aux_binds, tidy_clauses) <- mapAndUnzipM (tidyClause v) clauses let grouped = groupClauses tidy_clauses match_results <- match_groups grouped return (adjustMatchResult (foldr (.) id aux_binds) $ foldr1 (.) match_results) where match_groups :: DsMonad q => [[(PatGroup, EquationInfo)]] -> q [MatchResult] match_groups [] = matchEmpty v match_groups gs = mapM match_group gs match_group :: DsMonad q => [(PatGroup, EquationInfo)] -> q MatchResult match_group [] = error "Internal error in th-desugar (match_group)" match_group eqns@((group,_) : _) = case group of PgCon _ -> matchConFamily vars (subGroup [(c,e) | (PgCon c, e) <- eqns]) PgLit _ -> matchLiterals vars (subGroup [(l,e) | (PgLit l, e) <- eqns]) PgBang -> matchBangs vars (drop_group eqns) PgAny -> matchVariables vars (drop_group eqns) drop_group = map snd -- analogous to GHC's tidyEqnInfo tidyClause :: DsMonad q => Name -> EquationInfo -> q (DExp -> DExp, EquationInfo) tidyClause _ (EquationInfo [] _) = error "Internal error in th-desugar: no patterns in tidyClause." tidyClause v (EquationInfo (pat : pats) body) = do (wrap, pat') <- tidy1 v pat return (wrap, EquationInfo (pat' : pats) body) tidy1 :: DsMonad q => Name -- the name of the variable that ... -> DPat -- ... this pattern is matching against -> q (DExp -> DExp, DPat) -- a wrapper and tidied pattern tidy1 _ p@(DLitP {}) = return (id, p) tidy1 v (DVarP var) = return (wrapBind var v, DWildP) tidy1 _ p@(DConP {}) = return (id, p) tidy1 v (DTildeP pat) = do sel_decs <- mkSelectorDecs pat v return (maybeDLetE sel_decs, DWildP) tidy1 v (DBangP pat) = case pat of DLitP _ -> tidy1 v pat -- already strict DVarP _ -> return (id, DBangP pat) -- no change DConP{} -> tidy1 v pat -- already strict DTildeP p -> tidy1 v (DBangP p) -- discard ~ under ! DBangP p -> tidy1 v (DBangP p) -- discard ! under ! DSigP p _ -> tidy1 v (DBangP p) -- discard sig under ! DWildP -> return (id, DBangP pat) -- no change tidy1 v (DSigP pat ty) | no_tyvars_ty ty = tidy1 v pat -- The match-flattener doesn't know how to deal with patterns that mention -- type variables properly, so we give up if we encounter one. -- See https://github.com/goldfirere/th-desugar/pull/48#issuecomment-266778976 -- for further discussion. | otherwise = Monad.fail "Match-flattening patterns that mention type variables is not supported." where no_tyvars_ty :: Data a => a -> Bool no_tyvars_ty = everything (&&) (mkQ True no_tyvar_ty) no_tyvar_ty :: DType -> Bool no_tyvar_ty (DVarT{}) = False no_tyvar_ty t = gmapQl (&&) True no_tyvars_ty t tidy1 _ DWildP = return (id, DWildP) wrapBind :: Name -> Name -> DExp -> DExp wrapBind new old | new == old = id | otherwise = DLetE [DValD (DVarP new) (DVarE old)] -- like GHC's mkSelectorBinds mkSelectorDecs :: DsMonad q => DPat -- pattern to deconstruct -> Name -- variable being matched against -> q [DLetDec] mkSelectorDecs (DVarP v) name = return [DValD (DVarP v) (DVarE name)] mkSelectorDecs pat name | OS.null binders = return [] | OS.size binders == 1 = do val_var <- newUniqueName "var" err_var <- newUniqueName "err" bind <- mk_bind val_var err_var (head $ F.toList binders) return [DValD (DVarP val_var) (DVarE name), DValD (DVarP err_var) (DVarE 'error `DAppE` (DLitE $ StringL "Irrefutable match failed")), bind] | otherwise = do tuple_expr <- simplCaseExp [name] [DClause [pat] local_tuple] tuple_var <- newUniqueName "tuple" projections <- mapM (mk_projection tuple_var) [0 .. tuple_size-1] return (DValD (DVarP tuple_var) tuple_expr : zipWith DValD (map DVarP binders_list) projections) where binders = extractBoundNamesDPat pat binders_list = F.toList binders tuple_size = length binders_list local_tuple = mkTupleDExp (map DVarE binders_list) mk_projection :: DsMonad q => Name -- of the tuple -> Int -- which element to get (0-indexed) -> q DExp mk_projection tup_name i = do var_name <- newUniqueName "proj" return $ DCaseE (DVarE tup_name) [DMatch (DConP (tupleDataName tuple_size) [] (mk_tuple_pats var_name i)) (DVarE var_name)] mk_tuple_pats :: Name -- of the projected element -> Int -- which element to get (0-indexed) -> [DPat] mk_tuple_pats elt_name i = replicate i DWildP ++ DVarP elt_name : replicate (tuple_size - i - 1) DWildP mk_bind scrut_var err_var bndr_var = do rhs_mr <- simplCase [scrut_var] [EquationInfo [pat] (\_ -> DVarE bndr_var)] return (DValD (DVarP bndr_var) (rhs_mr (DVarE err_var))) data PatGroup = PgAny -- immediate match (wilds, vars, lazies) | PgCon Name | PgLit Lit | PgBang -- like GHC's groupEquations groupClauses :: [EquationInfo] -> [[(PatGroup, EquationInfo)]] groupClauses clauses = runs same_gp [(patGroup (firstPat clause), clause) | clause <- clauses] where same_gp :: (PatGroup, EquationInfo) -> (PatGroup, EquationInfo) -> Bool (pg1,_) `same_gp` (pg2,_) = pg1 `sameGroup` pg2 patGroup :: DPat -> PatGroup patGroup (DLitP l) = PgLit l patGroup (DVarP {}) = error "Internal error in th-desugar (patGroup DVarP)" patGroup (DConP con _ _) = PgCon con patGroup (DTildeP {}) = error "Internal error in th-desugar (patGroup DTildeP)" patGroup (DBangP {}) = PgBang patGroup (DSigP{}) = error "Internal error in th-desugar (patGroup DSigP)" patGroup DWildP = PgAny sameGroup :: PatGroup -> PatGroup -> Bool sameGroup PgAny PgAny = True sameGroup PgBang PgBang = True sameGroup (PgCon _) (PgCon _) = True sameGroup (PgLit _) (PgLit _) = True sameGroup _ _ = False subGroup :: Ord a => [(a, EquationInfo)] -> [[EquationInfo]] subGroup group = map reverse $ Map.elems $ foldl accumulate Map.empty group where accumulate pg_map (pg, eqn) = case Map.lookup pg pg_map of Just eqns -> Map.insert pg (eqn:eqns) pg_map Nothing -> Map.insert pg [eqn] pg_map firstPat :: EquationInfo -> DPat firstPat (EquationInfo (pat : _) _) = pat firstPat _ = error "Clause encountered with no patterns -- should never happen" data CaseAlt = CaseAlt { alt_con :: Name -- con name , _alt_args :: [Name] -- bound var names , _alt_rhs :: MatchResult -- RHS } -- from GHC's MatchCon.lhs matchConFamily :: DsMonad q => [Name] -> [[EquationInfo]] -> q MatchResult matchConFamily (var:vars) groups = do alts <- mapM (matchOneCon vars) groups mkDataConCase var alts matchConFamily [] _ = error "Internal error in th-desugar (matchConFamily)" -- like matchOneConLike from MatchCon matchOneCon :: DsMonad q => [Name] -> [EquationInfo] -> q CaseAlt matchOneCon vars eqns@(eqn1 : _) = do arg_vars <- selectMatchVars (pat_args pat1) match_result <- match_group arg_vars return $ CaseAlt (pat_con pat1) arg_vars match_result where pat1 = firstPat eqn1 pat_args (DConP _ _ pats) = pats pat_args _ = error "Internal error in th-desugar (pat_args)" pat_con (DConP con _ _) = con pat_con _ = error "Internal error in th-desugar (pat_con)" match_group :: DsMonad q => [Name] -> q MatchResult match_group arg_vars = simplCase (arg_vars ++ vars) (map shift eqns) shift (EquationInfo (DConP _ _ args : pats) exp) = EquationInfo (args ++ pats) exp shift _ = error "Internal error in th-desugar (shift)" matchOneCon _ _ = error "Internal error in th-desugar (matchOneCon)" mkDataConCase :: DsMonad q => Name -> [CaseAlt] -> q MatchResult mkDataConCase var case_alts = do all_ctors <- get_all_ctors (alt_con $ head case_alts) return $ \fail -> let matches = map (mk_alt fail) case_alts in DCaseE (DVarE var) (matches ++ mk_default all_ctors fail) where mk_alt fail (CaseAlt con args body_fn) = let body = body_fn fail in DMatch (DConP con [] (map DVarP args)) body mk_default all_ctors fail | exhaustive_case all_ctors = [] | otherwise = [DMatch DWildP fail] mentioned_ctors = S.fromList $ map alt_con case_alts exhaustive_case all_ctors = all_ctors `S.isSubsetOf` mentioned_ctors get_all_ctors :: DsMonad q => Name -> q (S.Set Name) get_all_ctors con_name = do ty_name <- dataConNameToDataName con_name Just (DTyConI tycon_dec _) <- dsReify ty_name return $ S.fromList $ map get_con_name $ get_cons tycon_dec get_cons (DDataD _ _ _ _ _ cons _) = cons get_cons (DDataInstD _ _ _ _ _ cons _) = cons get_cons _ = [] get_con_name (DCon _ _ n _ _) = n matchEmpty :: DsMonad q => Name -> q [MatchResult] matchEmpty var = return [mk_seq] where mk_seq fail = DCaseE (DVarE var) [DMatch DWildP fail] matchLiterals :: DsMonad q => [Name] -> [[EquationInfo]] -> q MatchResult matchLiterals (var:vars) sub_groups = do alts <- mapM match_group sub_groups return (mkCoPrimCaseMatchResult var alts) where match_group :: DsMonad q => [EquationInfo] -> q (Lit, MatchResult) match_group eqns = do let lit = case firstPat (head eqns) of DLitP lit' -> lit' _ -> error $ "Internal error in th-desugar " ++ "(matchLiterals.match_group)" match_result <- simplCase vars (shiftEqns eqns) return (lit, match_result) matchLiterals [] _ = error "Internal error in th-desugar (matchLiterals)" mkCoPrimCaseMatchResult :: Name -- Scrutinee -> [(Lit, MatchResult)] -> MatchResult mkCoPrimCaseMatchResult var match_alts = mk_case where mk_case fail = let alts = map (mk_alt fail) match_alts in DCaseE (DVarE var) (alts ++ [DMatch DWildP fail]) mk_alt fail (lit, body_fn) = DMatch (DLitP lit) (body_fn fail) matchBangs :: DsMonad q => [Name] -> [EquationInfo] -> q MatchResult matchBangs (var:vars) eqns = do match_result <- simplCase (var:vars) $ map (decomposeFirstPat getBangPat) eqns return (mkEvalMatchResult var match_result) matchBangs [] _ = error "Internal error in th-desugar (matchBangs)" decomposeFirstPat :: (DPat -> DPat) -> EquationInfo -> EquationInfo decomposeFirstPat extractpat (EquationInfo (pat:pats) body) = EquationInfo (extractpat pat : pats) body decomposeFirstPat _ _ = error "Internal error in th-desugar (decomposeFirstPat)" getBangPat :: DPat -> DPat getBangPat (DBangP p) = p getBangPat _ = error "Internal error in th-desugar (getBangPat)" mkEvalMatchResult :: Name -> MatchResult -> MatchResult mkEvalMatchResult var body_fn fail = foldl DAppE (DVarE 'seq) [DVarE var, body_fn fail] matchVariables :: DsMonad q => [Name] -> [EquationInfo] -> q MatchResult matchVariables (_:vars) eqns = simplCase vars (shiftEqns eqns) matchVariables _ _ = error "Internal error in th-desugar (matchVariables)" shiftEqns :: [EquationInfo] -> [EquationInfo] shiftEqns = map shift where shift (EquationInfo pats rhs) = EquationInfo (tail pats) rhs adjustMatchResult :: (DExp -> DExp) -> MatchResult -> MatchResult adjustMatchResult wrap mr fail = wrap $ mr fail -- from DsUtils selectMatchVars :: DsMonad q => [DPat] -> q [Name] selectMatchVars = mapM selectMatchVar -- from DsUtils selectMatchVar :: DsMonad q => DPat -> q Name selectMatchVar (DBangP pat) = selectMatchVar pat selectMatchVar (DTildeP pat) = selectMatchVar pat selectMatchVar (DVarP var) = newUniqueName ('_' : nameBase var) selectMatchVar _ = newUniqueName "_pat" -- like GHC's runs runs :: (a -> a -> Bool) -> [a] -> [[a]] runs _ [] = [] runs p (x:xs) = case span (p x) xs of (first, rest) -> (x:first) : (runs p rest) th-desugar-1.15/Language/Haskell/TH/Desugar/OMap.hs0000644000000000000000000001140207346545000020075 0ustar0000000000000000{-# 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) th-desugar-1.15/Language/Haskell/TH/Desugar/OMap/0000755000000000000000000000000007346545000017543 5ustar0000000000000000th-desugar-1.15/Language/Haskell/TH/Desugar/OMap/Strict.hs0000644000000000000000000000764307346545000021361 0ustar0000000000000000{-# 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) th-desugar-1.15/Language/Haskell/TH/Desugar/OSet.hs0000644000000000000000000000700307346545000020115 0ustar0000000000000000{-# 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) th-desugar-1.15/Language/Haskell/TH/Desugar/Reify.hs0000644000000000000000000015233007346545000020325 0ustar0000000000000000{- Language/Haskell/TH/Desugar/Reify.hs (c) Richard Eisenberg 2014 rae@cs.brynmawr.edu Allows for reification from a list of declarations, without looking a name up in the environment. -} {-# LANGUAGE CPP, GeneralizedNewtypeDeriving, ScopedTypeVariables #-} module Language.Haskell.TH.Desugar.Reify ( -- * Reification reifyWithLocals_maybe, reifyWithLocals, reifyWithWarning, reifyInDecs, -- ** Fixity reification qReifyFixity, reifyFixity, reifyFixityWithLocals, reifyFixityInDecs, -- ** Type reification qReifyType, reifyType, reifyTypeWithLocals_maybe, reifyTypeWithLocals, reifyTypeInDecs, -- * Datatype lookup getDataD, dataConNameToCon, dataConNameToDataName, -- * Value and type lookup lookupValueNameWithLocals, lookupTypeNameWithLocals, mkDataNameWithLocals, mkTypeNameWithLocals, reifyNameSpace, -- * Monad support DsMonad(..), DsM, withLocalDeclarations ) where import Control.Applicative import qualified Control.Monad.Fail as Fail import Control.Monad.Reader import Control.Monad.State import Control.Monad.Writer import Control.Monad.RWS import Control.Monad.Trans.Instances () import qualified Data.Foldable as F import Data.Function (on) import qualified Data.List as List import qualified Data.Map as Map import Data.Map (Map) import Data.Maybe import qualified Data.Set as Set import Data.Set (Set) import Language.Haskell.TH.Datatype ( freeVariables, freeVariablesWellScoped , quantifyType, resolveTypeSynonyms ) import Language.Haskell.TH.Datatype.TyVarBndr import Language.Haskell.TH.Instances () import Language.Haskell.TH.Syntax hiding ( lift ) import Language.Haskell.TH.Desugar.Util as Util -- | Like @reify@ from Template Haskell, but looks also in any not-yet-typechecked -- declarations. To establish this list of not-yet-typechecked declarations, -- use 'withLocalDeclarations'. Returns 'Nothing' if reification fails. -- Note that no inferred type information is available from local declarations; -- bottoms may be used if necessary. reifyWithLocals_maybe :: DsMonad q => Name -> q (Maybe Info) reifyWithLocals_maybe name = qRecover (return . reifyInDecs name =<< localDeclarations) (Just `fmap` qReify name) -- | Like 'reifyWithLocals_maybe', but throws an exception upon failure, -- warning the user about separating splices. reifyWithLocals :: DsMonad q => Name -> q Info reifyWithLocals name = do m_info <- reifyWithLocals_maybe name case m_info of Nothing -> reifyFail name Just i -> return i -- | Reify a declaration, warning the user about splices if the reify fails. -- The warning says that reification can fail if you try to reify a type in -- the same splice as it is declared. reifyWithWarning :: (Quasi q, Fail.MonadFail q) => Name -> q Info reifyWithWarning name = qRecover (reifyFail name) (qReify name) -- | Print out a warning about separating splices and fail. reifyFail :: Fail.MonadFail m => Name -> m a reifyFail name = Fail.fail $ "Looking up " ++ (show name) ++ " in the list of available " ++ "declarations failed.\nThis lookup fails if the declaration " ++ "referenced was made in the same Template\nHaskell splice as the use " ++ "of the declaration. If this is the case, put\nthe reference to " ++ "the declaration in a new splice." --------------------------------- -- Utilities --------------------------------- -- | Extract the 'DataFlavor', 'TyVarBndr's and constructors given the 'Name' -- of a type. getDataD :: DsMonad q => String -- ^ Print this out on failure -> Name -- ^ Name of the datatype (@data@ or @newtype@) of interest -> q (DataFlavor, [TyVarBndrUnit], [Con]) getDataD err name = do info <- reifyWithLocals name dec <- case info of TyConI dec -> return dec _ -> badDeclaration case dec of DataD _cxt _name tvbs mk cons _derivings -> go Data tvbs mk cons NewtypeD _cxt _name tvbs mk con _derivings -> go Newtype tvbs mk [con] #if __GLASGOW_HASKELL__ >= 906 TypeDataD _name tvbs mk cons -> go Util.TypeData tvbs mk cons #endif _ -> badDeclaration where go df tvbs mk cons = do let k = fromMaybe (ConT typeKindName) mk extra_tvbs <- mkExtraKindBinders k let all_tvbs = tvbs ++ extra_tvbs return (df, all_tvbs, cons) badDeclaration = fail $ "The name (" ++ (show name) ++ ") refers to something " ++ "other than a datatype. " ++ err -- | Create new kind variable binder names corresponding to the return kind of -- a data type. This is useful when you have a data type like: -- -- @ -- data Foo :: forall k. k -> Type -> Type where ... -- @ -- -- But you want to be able to refer to the type @Foo a b@. -- 'mkExtraKindBinders' will take the kind @forall k. k -> Type -> Type@, -- discover that is has two visible argument kinds, and return as a result -- two new kind variable binders @[a :: k, b :: Type]@, where @a@ and @b@ -- are fresh type variable names. -- -- This expands kind synonyms if necessary. mkExtraKindBinders :: forall q. Quasi q => Kind -> q [TyVarBndrUnit] mkExtraKindBinders k = do k' <- runQ $ resolveTypeSynonyms k let (fun_args, _) = unravelType k' vis_fun_args = filterVisFunArgs fun_args mapM mk_tvb vis_fun_args where mk_tvb :: VisFunArg -> q TyVarBndrUnit mk_tvb (VisFADep tvb) = return tvb mk_tvb (VisFAAnon ki) = kindedTV <$> qNewName "a" <*> return ki -- | From the name of a data constructor, retrive the datatype definition it -- is a part of. dataConNameToDataName :: DsMonad q => Name -> q Name dataConNameToDataName con_name = do info <- reifyWithLocals con_name case info of DataConI _name _type parent_name -> return parent_name _ -> fail $ "The name " ++ show con_name ++ " does not appear to be " ++ "a data constructor." -- | From the name of a data constructor, retrieve its definition as a @Con@ dataConNameToCon :: DsMonad q => Name -> q Con dataConNameToCon con_name = do -- we need to get the field ordering from the constructor. We must reify -- the constructor to get the tycon, and then reify the tycon to get the `Con`s type_name <- dataConNameToDataName con_name (_, _, cons) <- getDataD "This seems to be an error in GHC." type_name let m_con = List.find (any (con_name ==) . get_con_name) cons case m_con of Just con -> return con Nothing -> impossible "Datatype does not contain one of its own constructors." where get_con_name (NormalC name _) = [name] get_con_name (RecC name _) = [name] get_con_name (InfixC _ name _) = [name] get_con_name (ForallC _ _ con) = get_con_name con get_con_name (GadtC names _ _) = names get_con_name (RecGadtC names _ _) = names -------------------------------------------------- -- DsMonad -------------------------------------------------- -- | A 'DsMonad' stores some list of declarations that should be considered -- in scope. 'DsM' is the prototypical inhabitant of 'DsMonad'. class (Quasi m, Fail.MonadFail m) => DsMonad m where -- | Produce a list of local declarations. localDeclarations :: m [Dec] instance DsMonad Q where localDeclarations = return [] instance DsMonad IO where localDeclarations = return [] -- | A convenient implementation of the 'DsMonad' class. Use by calling -- 'withLocalDeclarations'. newtype DsM q a = DsM (ReaderT [Dec] q a) deriving ( Functor, Applicative, Monad, MonadTrans, Quasi, Fail.MonadFail #if __GLASGOW_HASKELL__ >= 803 , MonadIO #endif ) instance (Quasi q, Fail.MonadFail q) => DsMonad (DsM q) where localDeclarations = DsM ask instance DsMonad m => DsMonad (ReaderT r m) where localDeclarations = lift localDeclarations instance DsMonad m => DsMonad (StateT s m) where localDeclarations = lift localDeclarations instance (DsMonad m, Monoid w) => DsMonad (WriterT w m) where localDeclarations = lift localDeclarations instance (DsMonad m, Monoid w) => DsMonad (RWST r w s m) where localDeclarations = lift localDeclarations -- | Add a list of declarations to be considered when reifying local -- declarations. withLocalDeclarations :: DsMonad q => [Dec] -> DsM q a -> q a withLocalDeclarations new_decs (DsM x) = do orig_decs <- localDeclarations runReaderT x (orig_decs ++ new_decs) --------------------------- -- Reifying local declarations --------------------------- -- | Look through a list of declarations and possibly return a relevant 'Info' reifyInDecs :: Name -> [Dec] -> Maybe Info reifyInDecs n decs = snd `fmap` firstMatch (reifyInDec n decs) decs -- | Look through a list of declarations and possibly return a fixity. reifyFixityInDecs :: Name -> [Dec] -> Maybe Fixity reifyFixityInDecs n = firstMatch match_fixity where match_fixity (InfixD fixity n') | n `nameMatches` n' = Just fixity match_fixity (ClassD _ _ _ _ sub_decs) = firstMatch match_fixity sub_decs match_fixity _ = Nothing -- | A reified thing along with the name of that thing. type Named a = (Name, a) reifyInDec :: Name -> [Dec] -> Dec -> Maybe (Named Info) reifyInDec n decs (FunD n' _) | n `nameMatches` n' = Just (n', mkVarI n decs) reifyInDec n decs (ValD pat _ _) | Just n' <- List.find (nameMatches n) (F.toList (extractBoundNamesPat pat)) = Just (n', mkVarI n decs) reifyInDec n _ dec@(DataD _ n' _ _ _ _) | n `nameMatches` n' = Just (n', TyConI dec) reifyInDec n _ dec@(NewtypeD _ n' _ _ _ _) | n `nameMatches` n' = Just (n', TyConI dec) reifyInDec n _ dec@(TySynD n' _ _) | n `nameMatches` n' = Just (n', TyConI dec) reifyInDec n decs dec@(ClassD _ n' _ _ _) | n `nameMatches` n' = Just (n', ClassI (quantifyClassDecMethods dec) (findInstances n decs)) reifyInDec n _ (ForeignD (ImportF _ _ _ n' ty)) | n `nameMatches` n' = Just (n', mkVarITy n ty) reifyInDec n _ (ForeignD (ExportF _ _ n' ty)) | n `nameMatches` n' = Just (n', mkVarITy n ty) reifyInDec n decs dec@(OpenTypeFamilyD (TypeFamilyHead n' _ _ _)) | n `nameMatches` n' = Just (n', FamilyI dec (findInstances n decs)) reifyInDec n decs dec@(DataFamilyD n' _ _) | n `nameMatches` n' = Just (n', FamilyI dec (findInstances n decs)) reifyInDec n _ dec@(ClosedTypeFamilyD (TypeFamilyHead n' _ _ _) _) | n `nameMatches` n' = Just (n', FamilyI dec []) #if __GLASGOW_HASKELL__ >= 801 reifyInDec n decs (PatSynD n' _ _ _) | n `nameMatches` n' = Just (n', mkPatSynI n decs) #endif #if __GLASGOW_HASKELL__ >= 906 reifyInDec n _ dec@(TypeDataD n' _ _ _) | n `nameMatches` n' = Just (n', TyConI dec) #endif reifyInDec n decs (DataD _ ty_name tvbs _mk cons _) | Just info <- maybeReifyCon n decs ty_name (map tvbToTANormalWithSig tvbs) cons = Just info reifyInDec n decs (NewtypeD _ ty_name tvbs _mk con _) | Just info <- maybeReifyCon n decs ty_name (map tvbToTANormalWithSig tvbs) [con] = Just info reifyInDec n _decs (ClassD _ ty_name tvbs _ sub_decs) | Just (n', ty) <- findType n sub_decs = Just (n', ClassOpI n (quantifyClassMethodType ty_name tvbs True ty) ty_name) reifyInDec n decs (ClassD _ _ _ _ sub_decs) | Just info <- firstMatch (reifyInDec n decs) sub_decs -- Important: don't pass (sub_decs ++ decs) to reifyInDec -- above, or else type family defaults can be confused for -- actual instances. See #134. = Just info reifyInDec n decs (InstanceD _ _ _ sub_decs) | Just info <- firstMatch reify_in_instance sub_decs = Just info where reify_in_instance dec@(DataInstD {}) = reifyInDec n (sub_decs ++ decs) dec reify_in_instance dec@(NewtypeInstD {}) = reifyInDec n (sub_decs ++ decs) dec reify_in_instance _ = Nothing #if __GLASGOW_HASKELL__ >= 801 reifyInDec n decs (PatSynD pat_syn_name args _ _) | Just (n', full_sel_ty) <- maybeReifyPatSynRecSelector n decs pat_syn_name args = Just (n', VarI n full_sel_ty Nothing) #endif #if __GLASGOW_HASKELL__ >= 807 reifyInDec n decs (DataInstD _ _ lhs _ cons _) | (ConT ty_name, tys) <- unfoldType lhs , Just info <- maybeReifyCon n decs ty_name tys cons = Just info reifyInDec n decs (NewtypeInstD _ _ lhs _ con _) | (ConT ty_name, tys) <- unfoldType lhs , Just info <- maybeReifyCon n decs ty_name tys [con] = Just info #else reifyInDec n decs (DataInstD _ ty_name tys _ cons _) | Just info <- maybeReifyCon n decs ty_name (map TANormal tys) cons = Just info reifyInDec n decs (NewtypeInstD _ ty_name tys _ con _) | Just info <- maybeReifyCon n decs ty_name (map TANormal tys) [con] = Just info #endif #if __GLASGOW_HASKELL__ >= 906 reifyInDec n decs (TypeDataD ty_name tvbs _mk cons) | Just info <- maybeReifyCon n decs ty_name (map tvbToTANormalWithSig tvbs) cons = Just info #endif reifyInDec _ _ _ = Nothing maybeReifyCon :: Name -> [Dec] -> Name -> [TypeArg] -> [Con] -> Maybe (Named Info) maybeReifyCon n _decs ty_name ty_args cons | Just (n', con) <- findCon n cons -- See Note [Use unSigType in maybeReifyCon] , let full_con_ty = unSigType $ con_to_type h98_tvbs h98_res_ty con = Just (n', DataConI n full_con_ty ty_name) | Just (n', rec_sel_info) <- findRecSelector n cons , let (tvbs, sel_ty, con_res_ty) = extract_rec_sel_info rec_sel_info -- See Note [Use unSigType in maybeReifyCon] full_sel_ty = unSigType $ maybeForallT tvbs [] $ mkArrows [con_res_ty] sel_ty -- we don't try to ferret out naughty record selectors. = Just (n', VarI n full_sel_ty Nothing) where extract_rec_sel_info :: RecSelInfo -> ([TyVarBndrSpec], Type, Type) -- Returns ( Selector type variable binders -- , Record field type -- , constructor result type ) extract_rec_sel_info rec_sel_info = case rec_sel_info of RecSelH98 sel_ty -> ( changeTVFlags SpecifiedSpec h98_tvbs , sel_ty , h98_res_ty ) RecSelGADT mb_con_tvbs sel_ty con_res_ty -> let -- If the GADT constructor type signature explicitly quantifies -- its type variables, make sure to use that same order in the -- record selector's type. con_tvbs' = case mb_con_tvbs of Just con_tvbs -> con_tvbs Nothing -> changeTVFlags SpecifiedSpec $ freeVariablesWellScoped [con_res_ty, sel_ty] in ( con_tvbs' , sel_ty , con_res_ty ) h98_tvbs = freeVariablesWellScoped $ map probablyWrongUnTypeArg ty_args h98_res_ty = applyType (ConT ty_name) ty_args maybeReifyCon _ _ _ _ _ = Nothing #if __GLASGOW_HASKELL__ >= 801 -- | Attempt to reify the type of a pattern synonym record selector @n@. -- The algorithm for computing this type works as follows: -- -- 1. Reify the type of the parent pattern synonym. Broadly speaking, this -- will look something like: -- -- @ -- pattern P :: forall . req_cxt => -- forall . prov_cxt => -- arg_ty_1 -> ... -> arg_ty_k -> res -- @ -- -- 2. Check if @P@ is a record pattern synonym. If it isn't a record pattern -- synonym, return 'Nothing'. If it is a record pattern synonym, it will -- have @k@ record selectors @sel_1@, ..., @sel_k@. -- -- 3. Check if @n@ is equal to some @sel_i@. If it isn't equal to any of them, -- return @Nothing@. If it is equal to some @sel_i@, then return 'Just' -- @sel_i@ paired with the following type: -- -- @ -- sel_i :: forall . req_cxt => res -> arg_ty_i -- @ maybeReifyPatSynRecSelector :: Name -> [Dec] -> Name -> PatSynArgs -> Maybe (Named Type) maybeReifyPatSynRecSelector n decs pat_syn_name pat_syn_args = case pat_syn_args of -- Part (2) in the Haddocks RecordPatSyn fld_names -> firstMatch match_pat_syn_rec_sel $ zip fld_names pat_syn_ty_vis_args _ -> Nothing where -- Part (3) in the Haddocks match_pat_syn_rec_sel :: (Name, Type) -> Maybe (Named Type) match_pat_syn_rec_sel (n', field_ty) | n `nameMatches` n' = Just ( n' , -- See Note [Use unSigType in maybeReifyCon] unSigType $ maybeForallT pat_syn_ty_tvbs pat_syn_ty_req_cxt $ ArrowT `AppT` pat_syn_ty_res `AppT` field_ty ) match_pat_syn_rec_sel _ = Nothing -- The type of the pattern synonym to which this record selector belongs, -- as described in part (1) in the Haddocks. pat_syn_ty :: Type pat_syn_ty = case findPatSynType pat_syn_name decs of Just ty -> ty Nothing -> no_type n pat_syn_ty_args :: FunArgs pat_syn_ty_res :: Type (pat_syn_ty_args, pat_syn_ty_res) = unravelType pat_syn_ty -- Decompose a pattern synonym type into the constituent parts described in -- part (1) in the Haddocks. The Haddocks present an idealized form of -- pattern synonym type signature where the required and provided foralls -- and contexts are made explicit. In reality, some of these parts may be -- omitted, so we have to be careful to handle every combination of -- explicit and implicit parts. pat_syn_ty_tvbs :: [TyVarBndrSpec] pat_syn_ty_req_cxt :: Cxt pat_syn_ty_vis_args :: [Type] (pat_syn_ty_tvbs, pat_syn_ty_req_cxt, pat_syn_ty_vis_args) = case pat_syn_ty_args of -- Both the required foralls and context are explicit. -- -- The provided foralls and context may be explicit or implicit, but it -- doesn't really matter, as the type of a pattern synonym record -- selector only cares about the required foralls and context. -- Similarly for all cases below this one. FAForalls (ForallInvis req_tvbs) (FACxt req_cxt args) -> ( req_tvbs , req_cxt , mapMaybe vis_arg_anon_maybe $ filterVisFunArgs args ) -- Only the required foralls are explicit. We can assume that there is -- no required context due to the case above not matching. FAForalls (ForallInvis req_tvbs) args -> ( req_tvbs , [] , mapMaybe vis_arg_anon_maybe $ filterVisFunArgs args ) -- The required context is explicit, but the required foralls are -- implicit. As a result, the order of type variables in the outer -- forall in the type of the pattern synonym is determined by the usual -- left-to-right scoped sort. -- -- Note that there may be explicit, provided foralls in this case. For -- example, consider this example: -- -- @ -- data T a where -- MkT :: b -> T (Maybe b) -- -- pattern X :: Show a => forall b. (a ~ Maybe b) => b -> T a -- pattern X{unX} = MkT unX -- @ -- -- You might worry that the type of @unX@ would need to mention @b@. -- But actually, you can't use @unX@ as a top-level record selector in -- the first place! If you try to do so, GHC will throw the following -- error: -- -- @ -- Cannot use record selector `unX' as a function due to escaped type variables -- @ -- -- As a result, we choose not to care about this corner case. We could -- imagine trying to detect this sort of thing here and throwing a -- similar error message, but detecting which type variables do or do -- not escape is tricky in general. (See the Haddocks for -- getRecordSelectors in L.H.TH.Desugar for more on this point.) As a -- result, we don't even bother trying. Similarly for the case below. FACxt req_cxt args -> ( changeTVFlags SpecifiedSpec $ freeVariablesWellScoped [pat_syn_ty] , req_cxt , mapMaybe vis_arg_anon_maybe $ filterVisFunArgs args ) -- The required foralls are implicit. We can assume that there is no -- required context due to the case above not matching. args -> ( changeTVFlags SpecifiedSpec $ freeVariablesWellScoped [pat_syn_ty] , [] , mapMaybe vis_arg_anon_maybe $ filterVisFunArgs args ) vis_arg_anon_maybe :: VisFunArg -> Maybe Type vis_arg_anon_maybe (VisFAAnon ty) = Just ty vis_arg_anon_maybe (VisFADep{}) = Nothing #endif {- Note [Use unSigType in maybeReifyCon] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Make sure to call unSigType on the type of a reified data constructor or record selector. Otherwise, if you have this: data D (a :: k) = MkD { unD :: Proxy a } Then the type of unD will be reified as: unD :: forall k (a :: k). D (a :: k) -> Proxy a This is contrast to GHC's own reification, which will produce `D a` (without the explicit kind signature) as the type of the first argument. -} -- Reverse-engineer the type of a data constructor. con_to_type :: [TyVarBndrUnit] -- The type variables bound by a data type head. -- Only used for Haskell98-style constructors. -> Type -- The constructor result type. -- Only used for Haskell98-style constructors. -> Con -> Type con_to_type h98_tvbs h98_result_ty con = case go con of (is_gadt, ty) | is_gadt -> ty | otherwise -> maybeForallT (changeTVFlags SpecifiedSpec h98_tvbs) [] ty where -- Note that we deliberately ignore linear types and use (->) everywhere. -- See [Gracefully handling linear types] in L.H.TH.Desugar.Core. go :: Con -> (Bool, Type) -- The Bool is True when dealing with a GADT go (NormalC _ stys) = (False, mkArrows (map snd stys) h98_result_ty) go (RecC _ vstys) = (False, mkArrows (map thdOf3 vstys) h98_result_ty) go (InfixC t1 _ t2) = (False, mkArrows (map snd [t1, t2]) h98_result_ty) go (ForallC bndrs cxt c) = liftSnd (ForallT bndrs cxt) (go c) go (GadtC _ stys rty) = (True, mkArrows (map snd stys) rty) go (RecGadtC _ vstys rty) = (True, mkArrows (map thdOf3 vstys) rty) mkVarI :: Name -> [Dec] -> Info mkVarI n decs = mkVarITy n (maybe (no_type n) snd $ findType n decs) mkVarITy :: Name -> Type -> Info mkVarITy n ty = VarI n ty Nothing findType :: Name -> [Dec] -> Maybe (Named Type) findType n = firstMatch match_type where match_type (SigD n' ty) | n `nameMatches` n' = Just (n', ty) match_type _ = Nothing #if __GLASGOW_HASKELL__ >= 801 mkPatSynI :: Name -> [Dec] -> Info mkPatSynI n decs = PatSynI n (fromMaybe (no_type n) $ findPatSynType n decs) findPatSynType :: Name -> [Dec] -> Maybe PatSynType findPatSynType n = firstMatch match_pat_syn_type where match_pat_syn_type (PatSynSigD n' psty) | n `nameMatches` n' = Just psty match_pat_syn_type _ = Nothing #endif no_type :: Name -> Type no_type n = error $ "No type information found in local declaration for " ++ show n findInstances :: Name -> [Dec] -> [Dec] findInstances n = map stripInstanceDec . concatMap match_instance where match_instance d@(InstanceD _ _ ty _) | ConT n' <- ty_head ty , n `nameMatches` n' = [d] #if __GLASGOW_HASKELL__ >= 807 match_instance (DataInstD ctxt _ lhs mk cons derivs) | ConT n' <- ty_head lhs , n `nameMatches` n' = [d] where mtvbs = rejig_data_inst_tvbs ctxt lhs mk d = DataInstD ctxt mtvbs lhs mk cons derivs match_instance (NewtypeInstD ctxt _ lhs mk con derivs) | ConT n' <- ty_head lhs , n `nameMatches` n' = [d] where mtvbs = rejig_data_inst_tvbs ctxt lhs mk d = NewtypeInstD ctxt mtvbs lhs mk con derivs #else match_instance d@(DataInstD _ n' _ _ _ _) | n `nameMatches` n' = [d] match_instance d@(NewtypeInstD _ n' _ _ _ _) | n `nameMatches` n' = [d] #endif #if __GLASGOW_HASKELL__ >= 807 match_instance (TySynInstD (TySynEqn _ lhs rhs)) | ConT n' <- ty_head lhs , n `nameMatches` n' = [d] where mtvbs = rejig_tvbs [lhs, rhs] d = TySynInstD (TySynEqn mtvbs lhs rhs) #else match_instance d@(TySynInstD n' _) | n `nameMatches` n' = [d] #endif match_instance (InstanceD _ _ _ decs) = concatMap match_instance decs match_instance _ = [] #if __GLASGOW_HASKELL__ >= 807 -- See Note [Rejigging reified type family equations variable binders] -- for why this is necessary. rejig_tvbs :: [Type] -> Maybe [TyVarBndrUnit] rejig_tvbs ts = let tvbs = freeVariablesWellScoped ts in if null tvbs then Nothing else Just tvbs rejig_data_inst_tvbs :: Cxt -> Type -> Maybe Kind -> Maybe [TyVarBndrUnit] rejig_data_inst_tvbs cxt lhs mk = rejig_tvbs $ cxt ++ [lhs] ++ maybeToList mk #endif ty_head = fst . unfoldType {- Note [Rejigging reified type family equations variable binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When reifying a type family instance (on GHC 8.8 or later), which quantified type variables do you use? This might seem like a strange question to ask since these instances already come equipped with a field of type `Maybe [TyVarBndr]`, but it's not always the case that you want to use exactly that field. Here is an example to better explain it: class C a where type T b a instance C (Maybe a) where type forall b. T b (Maybe a) = a If the above instance were quoted, it would give you `Just [PlainTV b]`. But if you were to reify ''T (and therefore retrieve the instance for T), you wouldn't want to use that as your list of type variable binders! This is because reifiying any type family always presents the information as though the type family were top-level. Therefore, reifying T (in GHC, at least) would yield: type family T b a type instance forall b a. T b (Maybe a) = a Note that we quantify over `b` *and* `a` here, not just `b`. To emulate this GHC quirk, whenever we reify any type family instance, we just ignore the field of type `Maybe [TyVarBndr]` and quantify over the instance afresh. It's a bit tedious, but it gets the job done. (This is accomplished by the rejig_tvbs function.) -} -- Consider the following class declaration: -- -- [d| class C a where -- method :: a -> b -> a |] -- -- When reifying C locally, quantifyClassDecMethods serves two purposes: -- -- 1. It quantifies the class method's local type variables. To illustrate this -- point, this is how GHC would reify C: -- -- class C a where -- method :: forall b. a -> b -> a -- -- Notice the presence of the explicit `forall b.`. quantifyClassDecMethods -- performs this explicit quantification if necessary (as in the case in the -- local C declaration, where `b` is implicitly quantified.) -- 2. It emulates a quirk in the way old versions of GHC would reify class -- declarations (Trac #15551). On versions of GHC older than 8.8, it would -- reify C like so: -- -- class C a where -- method :: forall a. C a => forall b. a -> b -> a -- -- Notice how GHC has added the (totally extraneous) `forall a. C a =>` -- part! This is weird, but our primary goal in this module is to mimic -- GHC's reification, so we play the part by adding the `forall`/class -- context to each class method in quantifyClassDecMethods. -- -- Since Trac #15551 was fixed in GHC 8.8, this function doesn't perform -- this step on 8.7 or later. quantifyClassDecMethods :: Dec -> Dec quantifyClassDecMethods (ClassD cxt cls_name cls_tvbs fds sub_decs) = ClassD cxt cls_name cls_tvbs fds sub_decs' where sub_decs' = mapMaybe go sub_decs go (SigD n ty) = Just $ SigD n $ quantifyClassMethodType cls_name cls_tvbs prepend_cls ty go d@(TySynInstD {}) = Just d go d@(OpenTypeFamilyD {}) = Just d go d@(DataFamilyD {}) = Just d go _ = Nothing -- See (2) in the comments for quantifyClassDecMethods. prepend_cls :: Bool #if __GLASGOW_HASKELL__ >= 807 prepend_cls = False #else prepend_cls = True #endif quantifyClassDecMethods dec = dec -- Add explicit quantification to a class method's type if necessary. In this -- example: -- -- [d| class C a where -- method :: a -> b -> a |] -- -- If one invokes `quantifyClassMethodType C [a] prepend (a -> b -> a)`, then -- the output will be: -- -- 1. `forall a. C a => forall b. a -> b -> a` (if `prepend` is True) -- 2. `forall b. a -> b -> a` (if `prepend` is False) -- -- Whether you want `prepend` to be True or False depends on the situation. -- When reifying an entire type class, like C, one does not need to prepend a -- class context to each of the bundled method types (see the comments for -- quantifyClassDecMethods), so False is appropriate. When one is only reifying -- a single class method, like `method`, then one needs the class context to -- appear in the reified type, so `True` is appropriate. quantifyClassMethodType :: Name -- ^ The class name. -> [TyVarBndrUnit] -- ^ The class's type variable binders. -> Bool -- ^ If 'True', prepend a class predicate. -> Type -- ^ The method type. -> Type quantifyClassMethodType cls_name cls_tvbs prepend meth_ty = add_cls_cxt quantified_meth_ty where add_cls_cxt :: Type -> Type add_cls_cxt | prepend = ForallT (changeTVFlags SpecifiedSpec all_cls_tvbs) cls_cxt | otherwise = id cls_cxt :: Cxt cls_cxt = [foldl AppT (ConT cls_name) (map tvbToType cls_tvbs)] quantified_meth_ty :: Type quantified_meth_ty | null meth_tvbs = meth_ty | ForallT meth_tvbs' meth_ctxt meth_tau <- meth_ty = ForallT (meth_tvbs ++ meth_tvbs') meth_ctxt meth_tau | otherwise = ForallT meth_tvbs [] meth_ty meth_tvbs :: [TyVarBndrSpec] meth_tvbs = changeTVFlags SpecifiedSpec $ List.deleteFirstsBy ((==) `on` tvName) (freeVariablesWellScoped [meth_ty]) all_cls_tvbs -- Explicitly quantify any kind variables bound by the class, if any. all_cls_tvbs :: [TyVarBndrUnit] all_cls_tvbs = freeVariablesWellScoped $ map tvbToTypeWithSig cls_tvbs stripInstanceDec :: Dec -> Dec stripInstanceDec (InstanceD over cxt ty _) = InstanceD over cxt ty [] stripInstanceDec dec = dec mkArrows :: [Type] -> Type -> Type mkArrows [] res_ty = res_ty mkArrows (t:ts) res_ty = AppT (AppT ArrowT t) $ mkArrows ts res_ty maybeForallT :: [TyVarBndrSpec] -> Cxt -> Type -> Type maybeForallT tvbs cxt ty | null tvbs && null cxt = ty | ForallT tvbs2 cxt2 ty2 <- ty = ForallT (tvbs ++ tvbs2) (cxt ++ cxt2) ty2 | otherwise = ForallT tvbs cxt ty findCon :: Name -> [Con] -> Maybe (Named Con) findCon n = firstMatch match_con where match_con :: Con -> Maybe (Named Con) match_con con = case con of NormalC n' _ | n `nameMatches` n' -> Just (n', con) RecC n' _ | n `nameMatches` n' -> Just (n', con) InfixC _ n' _ | n `nameMatches` n' -> Just (n', con) ForallC _ _ c -> case match_con c of Just (n', _) -> Just (n', con) Nothing -> Nothing GadtC nms _ _ -> gadt_case con nms RecGadtC nms _ _ -> gadt_case con nms _ -> Nothing gadt_case :: Con -> [Name] -> Maybe (Named Con) gadt_case con nms = case List.find (n `nameMatches`) nms of Just n' -> Just (n', con) Nothing -> Nothing data RecSelInfo = RecSelH98 Type -- The record field's type | RecSelGADT (Maybe [TyVarBndrSpec]) -- If the data constructor explicitly quantifies its type -- variables with a forall, this will be Just. Otherwise, -- this will be Nothing. Type -- The record field's type Type -- The GADT return type findRecSelector :: Name -> [Con] -> Maybe (Named RecSelInfo) findRecSelector n = firstMatch (match_con Nothing) where match_con :: Maybe [TyVarBndrSpec] -> Con -> Maybe (Named RecSelInfo) match_con mb_tvbs con = case con of RecC _ vstys -> fmap (liftSnd RecSelH98) $ firstMatch match_rec_sel vstys RecGadtC _ vstys ret_ty -> fmap (liftSnd (\field_ty -> RecSelGADT (fmap (filter_ret_tvs ret_ty) mb_tvbs) field_ty ret_ty)) $ firstMatch match_rec_sel vstys ForallC tvbs _ c -> -- This is the only recursive case, and it is also the place where -- the type variable binders are determined (hence the use of Just -- below). Note that GHC forbids nested foralls in GADT constructor -- type signatures, so it is guaranteed that if a type variable in -- the rest of the type signature appears free, then its binding site -- can be found in one of these binders found in this case. match_con (Just tvbs) c _ -> Nothing match_rec_sel (n', _, sel_ty) | n `nameMatches` n' = Just (n', sel_ty) match_rec_sel _ = Nothing -- There may be type variables in the type of a GADT constructor that do -- not appear in the type of a record selector. For example, consider: -- -- data G a where -- MkG :: forall a b. { x :: a, y :: b } -> G a -- -- The type of `x` will only quantify `a` and not `b`: -- -- x :: forall a. G a -> a -- -- Accordingly, we must filter out any type variables in the GADT -- constructor type that do not appear free in the return type. Note that -- this implies that we cannot support reifying the type of `y`, as `b` -- does not appear free in `G a`. This does not bother us, however, as we -- make no attempt to support naughty record selectors. (See the Haddocks -- for getRecordSelectors in L.H.TH.Desugar for more on this point.) -- -- This mirrors the implementation of mkOneRecordSelector in GHC: -- https://gitlab.haskell.org/ghc/ghc/-/blob/37cfe3c0f4fb16189bbe3bb735f758cd6e3d9157/compiler/GHC/Tc/TyCl/Utils.hs#L908-909 filter_ret_tvs :: Type -> [TyVarBndrSpec] -> [TyVarBndrSpec] filter_ret_tvs ret_ty = filter (\tvb -> tvName tvb `Set.member` ret_fvs) where ret_fvs = Set.fromList $ freeVariables [ret_ty] --------------------------------- -- Reifying fixities --------------------------------- -- | Like 'reifyWithLocals_maybe', but for fixities. Note that a return value -- of @Nothing@ might mean that the name is not in scope, or it might mean -- that the name has no assigned fixity. (Use 'reifyWithLocals_maybe' if -- you really need to tell the difference.) reifyFixityWithLocals :: DsMonad q => Name -> q (Maybe Fixity) reifyFixityWithLocals name = qRecover (return . reifyFixityInDecs name =<< localDeclarations) (qReifyFixity name) -------------------------------------- -- Reifying types -------------------------------------- -- -- This section allows GHC <8.9 to call reifyFixity #if __GLASGOW_HASKELL__ < 809 qReifyType :: forall m. Quasi m => Name -> m Type qReifyType name = do info <- qReify name case infoType info <|> info_kind info of Just t -> return t Nothing -> fail $ "Could not reify the full type of " ++ nameBase name where info_kind :: Info -> Maybe Kind info_kind info = do dec <- case info of ClassI d _ -> Just d TyConI d -> Just d FamilyI d _ -> Just d _ -> Nothing match_cusk name dec {- | @reifyType nm@ attempts to find the type or kind of @nm@. For example, @reifyType 'not@ returns @Bool -> Bool@, and @reifyType ''Bool@ returns @Type@. This works even if there's no explicit signature and the type or kind is inferred. -} reifyType :: Name -> Q Type reifyType = qReifyType #endif -- | Like 'reifyTypeWithLocals_maybe', but throws an exception upon failure, -- warning the user about separating splices. reifyTypeWithLocals :: DsMonad q => Name -> q Type reifyTypeWithLocals name = do m_info <- reifyTypeWithLocals_maybe name case m_info of Nothing -> reifyFail name Just i -> return i -- | Like 'reifyWithLocals_maybe' but for types and kinds. Note that a return -- value of @Nothing@ might mean that the name is not in scope, or it might -- mean that the full type of the name cannot be determined. (Use -- 'reifyWithLocals_maybe' if you really need to tell the difference.) reifyTypeWithLocals_maybe :: DsMonad q => Name -> q (Maybe Type) reifyTypeWithLocals_maybe name = do #if __GLASGOW_HASKELL__ >= 809 cusks <- qIsExtEnabled CUSKs #else -- On earlier GHCs, the behavior of -XCUSKs was the norm. let cusks = True #endif qRecover (return . reifyTypeInDecs cusks name =<< localDeclarations) (Just `fmap` qReifyType name) -- | Look through a list of declarations and return its full type, if -- available. reifyTypeInDecs :: Bool -> Name -> [Dec] -> Maybe Type reifyTypeInDecs cusks name decs = (reifyInDecs name decs >>= infoType) <|> findKind cusks name decs -- Extract the type information (if any) contained in an Info. infoType :: Info -> Maybe Type infoType info = case info of ClassOpI _ t _ -> Just t DataConI _ t _ -> Just t VarI _ t _ -> Just t TyVarI _ t -> Just t #if __GLASGOW_HASKELL__ >= 802 PatSynI _ t -> Just t #endif _ -> Nothing -- Like findType, but instead searching for kind signatures. -- This mostly searches through `KiSigD`s, but if the -XCUSKs extension is -- enabled, this also retrieves kinds for declarations with CUSKs. findKind :: Bool -- Is -XCUSKs enabled? -> Name -> [Dec] -> Maybe Kind findKind cusks name decls = firstMatch (match_kind_sig name decls) decls <|> whenAlt cusks (firstMatch (match_cusk name) decls) -- Look for a declaration's kind by searching for its standalone kind -- signature, if available. match_kind_sig :: Name -> [Dec] -> Dec -> Maybe Kind match_kind_sig n decs (ClassD _ n' tvbs _ sub_decs) -- If a class has a standalone kind signature, then we can determine the -- full kind of its associated types in 99% of cases. -- See Note [The limitations of standalone kind signatures] for what -- happens in the other 1% of cases. | Just ki <- firstMatch (find_kind_sig n') decs , let (arg_kis, _res_ki) = unravelType ki mb_vis_arg_kis = map vis_arg_kind_maybe $ filterVisFunArgs arg_kis cls_tvb_kind_map = Map.fromList [ (tvName tvb, tvb_kind) | (tvb, mb_vis_arg_ki) <- zip tvbs mb_vis_arg_kis , Just tvb_kind <- [mb_vis_arg_ki <|> tvb_kind_maybe tvb] ] = firstMatch (find_assoc_type_kind n cls_tvb_kind_map) sub_decs match_kind_sig n _ dec = find_kind_sig n dec find_kind_sig :: Name -> Dec -> Maybe Kind #if __GLASGOW_HASKELL__ >= 809 find_kind_sig n (KiSigD n' ki) | n `nameMatches` n' = Just ki #endif find_kind_sig _ _ = Nothing -- Compute a declaration's kind by retrieving its CUSK, if it has one. -- This is only done when -XCUSKs is enabled, or on older GHCs where -- CUSKs were the only means of specifying this information. match_cusk :: Name -> Dec -> Maybe Kind match_cusk n (DataD _ n' tvbs m_ki _ _) | n `nameMatches` n' = datatype_kind tvbs m_ki match_cusk n (NewtypeD _ n' tvbs m_ki _ _) | n `nameMatches` n' = datatype_kind tvbs m_ki match_cusk n (DataFamilyD n' tvbs m_ki) | n `nameMatches` n' = open_ty_fam_kind tvbs m_ki match_cusk n (OpenTypeFamilyD (TypeFamilyHead n' tvbs res_sig _)) | n `nameMatches` n' = open_ty_fam_kind tvbs (res_sig_to_kind res_sig) match_cusk n (ClosedTypeFamilyD (TypeFamilyHead n' tvbs res_sig _) _) | n `nameMatches` n' = closed_ty_fam_kind tvbs (res_sig_to_kind res_sig) match_cusk n (TySynD n' tvbs rhs) | n `nameMatches` n' = ty_syn_kind tvbs rhs match_cusk n (ClassD _ n' tvbs _ sub_decs) | n `nameMatches` n' = class_kind tvbs | -- An associated type family can only have a CUSK if its parent class -- also has a CUSK. all tvb_is_kinded tvbs , let cls_tvb_kind_map = Map.fromList [ (tvName tvb, tvb_kind) | tvb <- tvbs , Just tvb_kind <- [tvb_kind_maybe tvb] ] = firstMatch (find_assoc_type_kind n cls_tvb_kind_map) sub_decs #if __GLASGOW_HASKELL__ >= 906 match_cusk n (TypeDataD n' tvbs m_ki _) | n `nameMatches` n' = datatype_kind tvbs m_ki #endif match_cusk _ _ = Nothing -- Uncover the kind of an associated type family. There is an invariant -- that this function should only ever be called when the kind of the -- parent class is known (i.e., if it has a standalone kind signature or a -- CUSK). Despite this, it is possible for this function to return Nothing. -- See Note [The limitations of standalone kind signatures]. find_assoc_type_kind :: Name -> Map Name Kind -> Dec -> Maybe Kind find_assoc_type_kind n cls_tvb_kind_map sub_dec = case sub_dec of DataFamilyD n' tf_tvbs m_ki | n `nameMatches` n' -> build_kind (map ascribe_tf_tvb_kind tf_tvbs) (default_res_ki m_ki) OpenTypeFamilyD (TypeFamilyHead n' tf_tvbs res_sig _) | n `nameMatches` n' -> build_kind (map ascribe_tf_tvb_kind tf_tvbs) (default_res_ki $ res_sig_to_kind res_sig) _ -> Nothing where ascribe_tf_tvb_kind :: TyVarBndrUnit -> TyVarBndrUnit ascribe_tf_tvb_kind tvb = elimTV (\tvn -> kindedTV tvn $ fromMaybe StarT $ Map.lookup tvn cls_tvb_kind_map) (\_ _ -> tvb) tvb -- Data types have CUSKs when: -- -- 1. All of their type variables have explicit kinds. -- 2. All kind variables in the result kind are explicitly quantified. datatype_kind :: [TyVarBndrUnit] -> Maybe Kind -> Maybe Kind datatype_kind tvbs m_ki = whenAlt (all tvb_is_kinded tvbs && ki_fvs_are_bound) $ build_kind tvbs (default_res_ki m_ki) where ki_fvs_are_bound :: Bool ki_fvs_are_bound = let ki_fvs = Set.fromList $ foldMap freeVariables m_ki tvb_vars = Set.fromList $ freeVariables $ map tvbToTypeWithSig tvbs in ki_fvs `Set.isSubsetOf` tvb_vars -- Classes have CUSKs when all of their type variables have explicit kinds. class_kind :: [TyVarBndrUnit] -> Maybe Kind class_kind tvbs = whenAlt (all tvb_is_kinded tvbs) $ build_kind tvbs ConstraintT -- Open type families and data families always have CUSKs. Type variables -- without explicit kinds default to Type, as does the return kind if it -- is not specified. open_ty_fam_kind :: [TyVarBndrUnit] -> Maybe Kind -> Maybe Kind open_ty_fam_kind tvbs m_ki = build_kind (map default_tvb tvbs) (default_res_ki m_ki) -- Closed type families have CUSKs when: -- -- 1. All of their type variables have explicit kinds. -- 2. An explicit return kind is supplied. closed_ty_fam_kind :: [TyVarBndrUnit] -> Maybe Kind -> Maybe Kind closed_ty_fam_kind tvbs m_ki = case m_ki of Just ki -> whenAlt (all tvb_is_kinded tvbs) $ build_kind tvbs ki Nothing -> Nothing -- Type synonyms have CUSKs when: -- -- 1. All of their type variables have explicit kinds. -- 2. The right-hand-side type is annotated with an explicit kind. ty_syn_kind :: [TyVarBndrUnit] -> Type -> Maybe Kind ty_syn_kind tvbs rhs = case rhs of SigT _ ki -> whenAlt (all tvb_is_kinded tvbs) $ build_kind tvbs ki _ -> Nothing -- Attempt to construct the full kind of a type-level declaration from its -- type variable binders and return kind. Do note that the result type of -- this function is `Maybe Kind` because there are situations where even -- this amount of information is not sufficient to determine the full kind. -- See Note [The limitations of standalone kind signatures]. build_kind :: [TyVarBndrUnit] -> Kind -> Maybe Kind build_kind arg_kinds res_kind = fmap quantifyType $ fst $ foldr go (Just res_kind, Set.fromList (freeVariables res_kind)) arg_kinds where go :: TyVarBndrUnit -> (Maybe Kind, Set Name) -> (Maybe Kind, Set Name) go tvb (res, res_fvs) = elimTV (\n -> ( if n `Set.member` res_fvs then forall_vis tvb res else Nothing -- We have a type variable binder without an -- explicit kind that is not used dependently, so -- we cannot build a kind from it. This is the -- only case where we return Nothing. , res_fvs )) (\n k -> ( if n `Set.member` res_fvs then forall_vis tvb res else fmap (ArrowT `AppT` k `AppT`) res , Set.fromList (freeVariables k) `Set.union` res_fvs )) tvb forall_vis :: TyVarBndrUnit -> Maybe Kind -> Maybe Kind #if __GLASGOW_HASKELL__ >= 809 forall_vis tvb m_ki = fmap (ForallVisT [tvb]) m_ki -- One downside of this approach is that we generate kinds like this: -- -- forall a -> forall b -> forall c -> (a, b, c) -- -- Instead of this more compact kind: -- -- forall a b c -> (a, b, c) -- -- Thankfully, the difference is only cosmetic. #else forall_vis _ _ = Nothing #endif tvb_is_kinded :: TyVarBndr_ flag -> Bool tvb_is_kinded = isJust . tvb_kind_maybe tvb_kind_maybe :: TyVarBndr_ flag -> Maybe Kind tvb_kind_maybe = elimTV (\_ -> Nothing) (\_ k -> Just k) vis_arg_kind_maybe :: VisFunArg -> Maybe Kind vis_arg_kind_maybe (VisFADep tvb) = tvb_kind_maybe tvb vis_arg_kind_maybe (VisFAAnon k) = Just k default_tvb :: TyVarBndrUnit -> TyVarBndrUnit default_tvb tvb = elimTV (\n -> kindedTV n StarT) (\_ _ -> tvb) tvb default_res_ki :: Maybe Kind -> Kind default_res_ki = fromMaybe StarT res_sig_to_kind :: FamilyResultSig -> Maybe Kind res_sig_to_kind NoSig = Nothing res_sig_to_kind (KindSig k) = Just k res_sig_to_kind (TyVarSig tvb) = tvb_kind_maybe tvb whenAlt :: Alternative f => Bool -> f a -> f a whenAlt b fa = if b then fa else empty {- Note [The limitations of standalone kind signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A current limitation of StandaloneKindSignatures is that they cannot be applied to associated type families. This can have some surprising consequences. Consider the following code, taken from https://gitlab.haskell.org/ghc/ghc/issues/17072#note_221324: type C :: forall a -> a -> Constraint class C a b where type T a :: Type The parent class C has a standalone kind signature, so GHC treats its associated types as if they had CUSKs. Can th-desugar figure out the kind that GHC gives to T? Unfortunately, the answer is "not easily". This is because `type T a` says nothing about the kind of `a`, so th-desugar's only other option is to inspect the kind signature for C. Even this is for naught, as the `forall a -> ...` part doesn't state the kind of `a` either! The only way to know that the kind of `a` should be Type is to infer that from the rest of the kind (`a -> Constraint`), but this gets perilously close to requiring full kind inference, which is rather unwieldy in Template Haskell. In cases like T, we simply give up and return Nothing when trying to reify its kind. It's not ideal, but them's the breaks when you try to extract kinds from syntax. There is a rather simple workaround available: just write `type C :: forall (a :: Type) -> a -> Constraint` instead. -} -------------------------------------- -- Looking up name value and type names -------------------------------------- -- | Like 'lookupValueName' from Template Haskell, but looks also in 'Names' of -- not-yet-typechecked declarations. To establish this list of not-yet-typechecked -- declarations, use 'withLocalDeclarations'. Returns 'Nothing' if no value -- with the same name can be found. lookupValueNameWithLocals :: DsMonad q => String -> q (Maybe Name) lookupValueNameWithLocals = lookupNameWithLocals False -- | Like 'lookupTypeName' from Template Haskell, but looks also in 'Names' of -- not-yet-typechecked declarations. To establish this list of not-yet-typechecked -- declarations, use 'withLocalDeclarations'. Returns 'Nothing' if no type -- with the same name can be found. lookupTypeNameWithLocals :: DsMonad q => String -> q (Maybe Name) lookupTypeNameWithLocals = lookupNameWithLocals True lookupNameWithLocals :: forall q. DsMonad q => Bool -> String -> q (Maybe Name) lookupNameWithLocals ns s = do mb_name <- qLookupName ns s case mb_name of j_name@(Just{}) -> return j_name Nothing -> consult_locals where built_name = mkName s consult_locals = do decs <- localDeclarations let mb_infos = map (reifyInDec built_name decs) decs infos = catMaybes mb_infos firstMatchM (if ns then find_type_name else find_value_name) infos -- These functions work over Named Infos so we can avoid performing -- tiresome pattern-matching to retrieve the name associated with each Info. find_type_name, find_value_name :: Named Info -> q (Maybe Name) find_type_name (n, info) = do name_space <- lookupInfoNameSpace info pure $ case name_space of TcClsName -> Just n VarName -> Nothing DataName -> Nothing find_value_name (n, info) = do name_space <- lookupInfoNameSpace info pure $ case name_space of VarName -> Just n DataName -> Just n TcClsName -> Nothing -- | Like TH's @lookupValueName@, but if this name is not bound, then we assume -- it is declared in the current module. -- -- Unlike 'mkDataName', this also consults the local declarations in scope when -- determining if the name is currently bound. mkDataNameWithLocals :: DsMonad q => String -> q Name mkDataNameWithLocals = mkNameWith lookupValueNameWithLocals mkNameG_d -- | Like TH's @lookupTypeName@, but if this name is not bound, then we assume -- it is declared in the current module. -- -- Unlike 'mkTypeName', this also consults the local declarations in scope when -- determining if the name is currently bound. mkTypeNameWithLocals :: DsMonad q => String -> q Name mkTypeNameWithLocals = mkNameWith lookupTypeNameWithLocals mkNameG_tc -- | Determines a `Name`'s 'NameSpace'. If the 'NameSpace' is attached to -- the 'Name' itself (i.e., it is unambiguous), then that 'NameSpace' is -- immediately returned. Otherwise, reification is used to lookup up the -- 'NameSpace' (consulting local declarations if necessary). -- -- Note that if a 'Name' lives in two different 'NameSpaces' (which can -- genuinely happen--for instance, @'mkName' \"==\"@, where @==@ is both -- a function and a type family), then this function will simply return -- whichever 'NameSpace' is discovered first via reification. If you wish -- to find a 'Name' in a particular 'NameSpace', use the -- 'lookupValueNameWithLocals' or 'lookupTypeNameWithLocals' functions. reifyNameSpace :: DsMonad q => Name -> q (Maybe NameSpace) reifyNameSpace n@(Name _ nf) = case nf of -- NameGs are simple, as they have a NameSpace attached. NameG ns _ _ -> pure $ Just ns -- For other names, we must use reification to determine what NameSpace -- it lives in (if any). _ -> do mb_info <- reifyWithLocals_maybe n traverse lookupInfoNameSpace mb_info -- | Look up a name's 'NameSpace' from its 'Info'. lookupInfoNameSpace :: DsMonad q => Info -> q NameSpace lookupInfoNameSpace info = case info of ClassI{} -> pure TcClsName TyConI{} -> pure TcClsName FamilyI{} -> pure TcClsName PrimTyConI{} -> pure TcClsName TyVarI{} -> pure TcClsName ClassOpI{} -> pure VarName VarI{} -> pure VarName DataConI _dc_name _dc_ty parent_name -> do -- DataConI usually refers to a value-level Name, but it could also refer -- to a type-level 'Name' if the data constructor corresponds to a -- @type data@ declaration. In order to know for sure, we must perform -- some additional reification. mb_parent_info <- reifyWithLocals_maybe parent_name pure $ case mb_parent_info of #if __GLASGOW_HASKELL__ >= 906 Just (TyConI (TypeDataD {})) -> TcClsName #endif _ -> DataName #if __GLASGOW_HASKELL__ >= 801 PatSynI{} -> pure DataName #endif th-desugar-1.15/Language/Haskell/TH/Desugar/Subst.hs0000644000000000000000000001266307346545000020353 0ustar0000000000000000{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Language.Haskell.TH.Desugar.Subst -- Copyright : (C) 2018 Richard Eisenberg -- License : BSD-style (see LICENSE) -- Maintainer : Ryan Scott -- Stability : experimental -- Portability : non-portable -- -- Capture-avoiding substitutions on 'DType's -- ---------------------------------------------------------------------------- module Language.Haskell.TH.Desugar.Subst ( DSubst, -- * Capture-avoiding substitution substTy, substForallTelescope, substTyVarBndrs, unionSubsts, unionMaybeSubsts, -- * Matching a type template against a type IgnoreKinds(..), matchTy ) where import qualified Data.List as L import qualified Data.Map as M import qualified Data.Set as S import Language.Haskell.TH.Desugar.AST import Language.Haskell.TH.Syntax import Language.Haskell.TH.Desugar.Util -- | A substitution is just a map from names to types type DSubst = M.Map Name DType -- | Capture-avoiding substitution on types substTy :: Quasi q => DSubst -> DType -> q DType substTy vars (DForallT tele ty) = do (vars', tele') <- substForallTelescope vars tele ty' <- substTy vars' ty return $ DForallT tele' ty' substTy vars (DConstrainedT cxt ty) = DConstrainedT <$> mapM (substTy vars) cxt <*> substTy vars ty substTy vars (DAppT t1 t2) = DAppT <$> substTy vars t1 <*> substTy vars t2 substTy vars (DAppKindT t k) = DAppKindT <$> substTy vars t <*> substTy vars k substTy vars (DSigT ty ki) = DSigT <$> substTy vars ty <*> substTy vars ki substTy vars (DVarT n) | Just ty <- M.lookup n vars = return ty | otherwise = return $ DVarT n substTy _ ty@(DConT _) = return ty substTy _ ty@DArrowT = return ty substTy _ ty@(DLitT _) = return ty substTy _ ty@DWildCardT = return ty substForallTelescope :: Quasi q => DSubst -> DForallTelescope -> q (DSubst, DForallTelescope) substForallTelescope vars tele = case tele of DForallVis tvbs -> do (vars', tvbs') <- substTyVarBndrs vars tvbs return (vars', DForallVis tvbs') DForallInvis tvbs -> do (vars', tvbs') <- substTyVarBndrs vars tvbs return (vars', DForallInvis tvbs') substTyVarBndrs :: Quasi q => DSubst -> [DTyVarBndr flag] -> q (DSubst, [DTyVarBndr flag]) substTyVarBndrs = mapAccumLM substTvb substTvb :: Quasi q => DSubst -> DTyVarBndr flag -> q (DSubst, DTyVarBndr flag) substTvb vars (DPlainTV n flag) = do new_n <- qNewName (nameBase n) return (M.insert n (DVarT new_n) vars, DPlainTV new_n flag) substTvb vars (DKindedTV n flag k) = do new_n <- qNewName (nameBase n) k' <- substTy vars k return (M.insert n (DVarT new_n) vars, DKindedTV new_n flag k') -- | Computes the union of two substitutions. Fails if both subsitutions map -- the same variable to different types. unionSubsts :: DSubst -> DSubst -> Maybe DSubst unionSubsts a b = let shared_key_set = M.keysSet a `S.intersection` M.keysSet b matches_up = S.foldr (\name -> ((a M.! name) == (b M.! name) &&)) True shared_key_set in if matches_up then return (a `M.union` b) else Nothing --------------------------- -- Matching -- | Ignore kind annotations in @matchTy@? data IgnoreKinds = YesIgnore | NoIgnore -- | @matchTy ign tmpl targ@ matches a type template @tmpl@ against a type -- target @targ@. This returns a Map from names of type variables in the -- type template to types if the types indeed match up, or @Nothing@ otherwise. -- In the @Just@ case, it is guaranteed that every type variable mentioned -- in the template is mapped by the returned substitution. -- -- The first argument @ign@ tells @matchTy@ whether to ignore kind signatures -- in the template. A kind signature in the template might mean that a type -- variable has a more restrictive kind than otherwise possible, and that -- mapping that type variable to a type of a different kind could be disastrous. -- So, if we don't ignore kind signatures, this function returns @Nothing@ if -- the template has a signature anywhere. If we do ignore kind signatures, it's -- possible the returned map will be ill-kinded. Use at your own risk. matchTy :: IgnoreKinds -> DType -> DType -> Maybe DSubst matchTy _ (DVarT var_name) arg = Just $ M.singleton var_name arg -- if a pattern has a kind signature, it's really easy to get -- this wrong. matchTy ign (DSigT ty _ki) arg = case ign of YesIgnore -> matchTy ign ty arg NoIgnore -> Nothing -- but we can safely ignore kind signatures on the target matchTy ign pat (DSigT ty _ki) = matchTy ign pat ty matchTy _ (DForallT {}) _ = error "Cannot match a forall in a pattern" matchTy _ _ (DForallT {}) = error "Cannot match a forall in a target" matchTy ign (DAppT pat1 pat2) (DAppT arg1 arg2) = unionMaybeSubsts [matchTy ign pat1 arg1, matchTy ign pat2 arg2] matchTy _ (DConT pat_con) (DConT arg_con) | pat_con == arg_con = Just M.empty matchTy _ DArrowT DArrowT = Just M.empty matchTy _ (DLitT pat_lit) (DLitT arg_lit) | pat_lit == arg_lit = Just M.empty matchTy _ _ _ = Nothing unionMaybeSubsts :: [Maybe DSubst] -> Maybe DSubst unionMaybeSubsts = L.foldl' union_subst1 (Just M.empty) where union_subst1 :: Maybe DSubst -> Maybe DSubst -> Maybe DSubst union_subst1 ma mb = do a <- ma b <- mb unionSubsts a b th-desugar-1.15/Language/Haskell/TH/Desugar/Sweeten.hs0000644000000000000000000004046507346545000020666 0ustar0000000000000000{- Language/Haskell/TH/Desugar/Sweeten.hs (c) Richard Eisenberg 2013 rae@cs.brynmawr.edu Converts desugared TH back into real TH. -} {-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskellQuotes #-} ----------------------------------------------------------------------------- -- | -- Module : Language.Haskell.TH.Desugar.Sweeten -- Copyright : (C) 2014 Richard Eisenberg -- License : BSD-style (see LICENSE) -- Maintainer : Ryan Scott -- Stability : experimental -- Portability : non-portable -- -- The functions in this module convert desugared Template Haskell back into -- proper Template Haskell. -- ---------------------------------------------------------------------------- module Language.Haskell.TH.Desugar.Sweeten ( expToTH, matchToTH, patToTH, decsToTH, decToTH, letDecToTH, typeToTH, conToTH, foreignToTH, pragmaToTH, ruleBndrToTH, clauseToTH, tvbToTH, cxtToTH, predToTH, derivClauseToTH, #if __GLASGOW_HASKELL__ >= 801 patSynDirToTH, #endif typeArgToTH ) where import Prelude hiding (exp) import Control.Arrow import Language.Haskell.TH hiding (Extension(..), cxt) import Language.Haskell.TH.Datatype.TyVarBndr import Language.Haskell.TH.Desugar.AST import Language.Haskell.TH.Desugar.Core (DTypeArg(..)) import Language.Haskell.TH.Desugar.Util expToTH :: DExp -> Exp expToTH (DVarE n) = VarE n expToTH (DConE n) = ConE n expToTH (DLitE l) = LitE l expToTH (DAppE e1 e2) = AppE (expToTH e1) (expToTH e2) expToTH (DLamE names exp) = LamE (map VarP names) (expToTH exp) expToTH (DCaseE exp matches) = CaseE (expToTH exp) (map matchToTH matches) expToTH (DLetE decs exp) = LetE (map letDecToTH decs) (expToTH exp) expToTH (DSigE exp ty) = SigE (expToTH exp) (typeToTH ty) expToTH (DStaticE exp) = StaticE (expToTH exp) #if __GLASGOW_HASKELL__ >= 801 expToTH (DAppTypeE exp ty) = AppTypeE (expToTH exp) (typeToTH ty) #else -- In the event that we're on a version of Template Haskell without support for -- type applications, we will simply drop the applied type. expToTH (DAppTypeE exp _) = expToTH exp #endif matchToTH :: DMatch -> Match matchToTH (DMatch pat exp) = Match (patToTH pat) (NormalB (expToTH exp)) [] patToTH :: DPat -> Pat patToTH (DLitP lit) = LitP lit patToTH (DVarP n) = VarP n patToTH (DConP n _tys pats) = ConP n #if __GLASGOW_HASKELL__ >= 901 (map typeToTH _tys) #endif (map patToTH pats) patToTH (DTildeP pat) = TildeP (patToTH pat) patToTH (DBangP pat) = BangP (patToTH pat) patToTH (DSigP pat ty) = SigP (patToTH pat) (typeToTH ty) patToTH DWildP = WildP decsToTH :: [DDec] -> [Dec] decsToTH = map decToTH -- | This returns a list of @Dec@s because GHC 7.6.3 does not have -- a one-to-one mapping between 'DDec' and @Dec@. decToTH :: DDec -> Dec decToTH (DLetDec d) = letDecToTH d decToTH (DDataD Data cxt n tvbs _mk cons derivings) = DataD (cxtToTH cxt) n (map tvbToTH tvbs) (fmap typeToTH _mk) (map conToTH cons) (concatMap derivClauseToTH derivings) decToTH (DDataD Newtype cxt n tvbs _mk [con] derivings) = NewtypeD (cxtToTH cxt) n (map tvbToTH tvbs) (fmap typeToTH _mk) (conToTH con) (concatMap derivClauseToTH derivings) decToTH (DDataD Newtype _cxt _n _tvbs _mk _cons _derivings) = error "Newtype declaration without exactly 1 constructor." decToTH (DTySynD n tvbs ty) = TySynD n (map tvbToTH tvbs) (typeToTH ty) decToTH (DClassD cxt n tvbs fds decs) = ClassD (cxtToTH cxt) n (map tvbToTH tvbs) fds (decsToTH decs) decToTH (DInstanceD over _mtvbs cxt ty decs) = -- We deliberately avoid sweetening _mtvbs. See #151. instanceDToTH over cxt ty decs decToTH (DForeignD f) = ForeignD (foreignToTH f) decToTH (DOpenTypeFamilyD (DTypeFamilyHead n tvbs frs ann)) = OpenTypeFamilyD (TypeFamilyHead n (map tvbToTH tvbs) (frsToTH frs) ann) decToTH (DDataFamilyD n tvbs mk) = DataFamilyD n (map tvbToTH tvbs) (fmap typeToTH mk) decToTH (DDataInstD nd cxt mtvbs lhs mk cons derivings) = let ndc = case (nd, cons) of (Newtype, [con]) -> DNewtypeCon con (Newtype, _) -> error "Newtype that doesn't have only one constructor" (Data, _) -> DDataCons cons (TypeData, _) -> error "Data family instance that is combined with `type data`" in dataInstDecToTH ndc cxt mtvbs lhs mk derivings #if __GLASGOW_HASKELL__ >= 807 decToTH (DTySynInstD eqn) = TySynInstD (snd $ tySynEqnToTH eqn) #else decToTH (DTySynInstD eqn) = let (n, eqn') = tySynEqnToTH eqn in TySynInstD n eqn' #endif decToTH (DClosedTypeFamilyD (DTypeFamilyHead n tvbs frs ann) eqns) = ClosedTypeFamilyD (TypeFamilyHead n (map tvbToTH tvbs) (frsToTH frs) ann) (map (snd . tySynEqnToTH) eqns) decToTH (DRoleAnnotD n roles) = RoleAnnotD n roles decToTH (DStandaloneDerivD mds _mtvbs cxt ty) = -- We deliberately avoid sweetening _mtvbs. See #151. standaloneDerivDToTH mds cxt ty decToTH (DDefaultSigD n ty) = DefaultSigD n (typeToTH ty) #if __GLASGOW_HASKELL__ >= 801 decToTH (DPatSynD n args dir pat) = PatSynD n args (patSynDirToTH dir) (patToTH pat) decToTH (DPatSynSigD n ty) = PatSynSigD n (typeToTH ty) #else decToTH DPatSynD{} = patSynErr decToTH DPatSynSigD{} = patSynErr #endif #if __GLASGOW_HASKELL__ >= 809 decToTH (DKiSigD n ki) = KiSigD n (typeToTH ki) #else decToTH (DKiSigD {}) = error "Standalone kind signatures supported only in GHC 8.10+" #endif #if __GLASGOW_HASKELL__ >= 903 decToTH (DDefaultD tys) = DefaultD (map typeToTH tys) #else decToTH (DDefaultD{}) = error "Default declarations supported only in GHC 9.4+" #endif #if __GLASGOW_HASKELL__ >= 906 decToTH (DDataD TypeData _cxt n tvbs mk cons _derivings) = -- NB: Due to the invariants on 'DDataD' and 'TypeData', _cxt and _derivings -- will be empty. TypeDataD n (map tvbToTH tvbs) (fmap typeToTH mk) (map conToTH cons) #else decToTH (DDataD TypeData _cxt _n _tvbs _mk _cons _derivings) = error "`type data` declarations supported only in GHC 9.6+" #endif #if __GLASGOW_HASKELL__ < 801 patSynErr :: a patSynErr = error "Pattern synonyms supported only in GHC 8.2+" #endif -- | Indicates whether something is a newtype or data type, bundling its -- constructor(s) along with it. data DNewOrDataCons = DNewtypeCon DCon | DDataCons [DCon] -- | Sweeten a 'DDataInstD'. dataInstDecToTH :: DNewOrDataCons -> DCxt -> Maybe [DTyVarBndrUnit] -> DType -> Maybe DKind -> [DDerivClause] -> Dec dataInstDecToTH ndc cxt _mtvbs lhs _mk derivings = case ndc of DNewtypeCon con -> #if __GLASGOW_HASKELL__ >= 807 NewtypeInstD (cxtToTH cxt) (fmap (fmap tvbToTH) _mtvbs) (typeToTH lhs) (fmap typeToTH _mk) (conToTH con) (concatMap derivClauseToTH derivings) #else NewtypeInstD (cxtToTH cxt) _n _lhs_args (fmap typeToTH _mk) (conToTH con) (concatMap derivClauseToTH derivings) #endif DDataCons cons -> #if __GLASGOW_HASKELL__ >= 807 DataInstD (cxtToTH cxt) (fmap (fmap tvbToTH) _mtvbs) (typeToTH lhs) (fmap typeToTH _mk) (map conToTH cons) (concatMap derivClauseToTH derivings) #else DataInstD (cxtToTH cxt) _n _lhs_args (fmap typeToTH _mk) (map conToTH cons) (concatMap derivClauseToTH derivings) #endif where _lhs' = typeToTH lhs (_n, _lhs_args) = case unfoldType _lhs' of (ConT n, lhs_args) -> (n, filterTANormals lhs_args) (_, _) -> error $ "Illegal data instance LHS: " ++ pprint _lhs' frsToTH :: DFamilyResultSig -> FamilyResultSig frsToTH DNoSig = NoSig frsToTH (DKindSig k) = KindSig (typeToTH k) frsToTH (DTyVarSig tvb) = TyVarSig (tvbToTH tvb) -- | Sweeten a 'DLetDec'. letDecToTH :: DLetDec -> Dec letDecToTH (DFunD name clauses) = FunD name (map clauseToTH clauses) letDecToTH (DValD pat exp) = ValD (patToTH pat) (NormalB (expToTH exp)) [] letDecToTH (DSigD name ty) = SigD name (typeToTH ty) letDecToTH (DInfixD f name) = InfixD f name letDecToTH (DPragmaD prag) = PragmaD (pragmaToTH prag) conToTH :: DCon -> Con conToTH (DCon [] [] n (DNormalC _ stys) rty) = GadtC [n] (map (second typeToTH) stys) (typeToTH rty) conToTH (DCon [] [] n (DRecC vstys) rty) = RecGadtC [n] (map (thirdOf3 typeToTH) vstys) (typeToTH rty) -- On GHC 8.0 or later, we sweeten every constructor to GADT syntax, so it is -- perfectly OK to put all of the quantified type variables -- (both universal and existential) in a ForallC. conToTH (DCon tvbs cxt n fields rty) = ForallC (map tvbToTH tvbs) (cxtToTH cxt) (conToTH $ DCon [] [] n fields rty) instanceDToTH :: Maybe Overlap -> DCxt -> DType -> [DDec] -> Dec instanceDToTH over cxt ty decs = InstanceD over (cxtToTH cxt) (typeToTH ty) (decsToTH decs) standaloneDerivDToTH :: Maybe DDerivStrategy -> DCxt -> DType -> Dec standaloneDerivDToTH _mds cxt ty = StandaloneDerivD #if __GLASGOW_HASKELL__ >= 802 (fmap derivStrategyToTH _mds) #endif (cxtToTH cxt) (typeToTH ty) foreignToTH :: DForeign -> Foreign foreignToTH (DImportF cc safety str n ty) = ImportF cc safety str n (typeToTH ty) foreignToTH (DExportF cc str n ty) = ExportF cc str n (typeToTH ty) pragmaToTH :: DPragma -> Pragma pragmaToTH (DInlineP n inl rm phases) = InlineP n inl rm phases pragmaToTH (DSpecialiseP n ty m_inl phases) = SpecialiseP n (typeToTH ty) m_inl phases pragmaToTH (DSpecialiseInstP ty) = SpecialiseInstP (typeToTH ty) #if __GLASGOW_HASKELL__ >= 807 pragmaToTH (DRuleP str mtvbs rbs lhs rhs phases) = RuleP str (fmap (fmap tvbToTH) mtvbs) (map ruleBndrToTH rbs) (expToTH lhs) (expToTH rhs) phases #else pragmaToTH (DRuleP str _ rbs lhs rhs phases) = RuleP str (map ruleBndrToTH rbs) (expToTH lhs) (expToTH rhs) phases #endif pragmaToTH (DAnnP target exp) = AnnP target (expToTH exp) pragmaToTH (DLineP n str) = LineP n str #if __GLASGOW_HASKELL__ < 801 pragmaToTH (DCompleteP {}) = error "COMPLETE pragmas only supported in GHC 8.2+" #else pragmaToTH (DCompleteP cls mty) = CompleteP cls mty #endif #if __GLASGOW_HASKELL__ >= 903 pragmaToTH (DOpaqueP n) = OpaqueP n #else pragmaToTH (DOpaqueP {}) = error "OPAQUE pragmas only supported in GHC 9.4+" #endif ruleBndrToTH :: DRuleBndr -> RuleBndr ruleBndrToTH (DRuleVar n) = RuleVar n ruleBndrToTH (DTypedRuleVar n ty) = TypedRuleVar n (typeToTH ty) #if __GLASGOW_HASKELL__ >= 807 -- | It's convenient to also return a 'Name' here, since some call sites make -- use of it. tySynEqnToTH :: DTySynEqn -> (Name, TySynEqn) tySynEqnToTH (DTySynEqn tvbs lhs rhs) = let lhs' = typeToTH lhs in case unfoldType lhs' of (ConT n, _lhs_args) -> (n, TySynEqn (fmap (fmap tvbToTH) tvbs) lhs' (typeToTH rhs)) (_, _) -> error $ "Illegal type instance LHS: " ++ pprint lhs' #else tySynEqnToTH :: DTySynEqn -> (Name, TySynEqn) tySynEqnToTH (DTySynEqn _ lhs rhs) = let lhs' = typeToTH lhs in case unfoldType lhs' of (ConT n, lhs_args) -> (n, TySynEqn (filterTANormals lhs_args) (typeToTH rhs)) (_, _) -> error $ "Illegal type instance LHS: " ++ pprint lhs' #endif clauseToTH :: DClause -> Clause clauseToTH (DClause pats exp) = Clause (map patToTH pats) (NormalB (expToTH exp)) [] typeToTH :: DType -> Type -- We need a special case for DForallT ForallInvis followed by DConstrainedT -- so that we may collapse them into a single ForallT when sweetening. -- See Note [Desugaring and sweetening ForallT] in L.H.T.Desugar.Core. typeToTH (DForallT (DForallInvis tvbs) (DConstrainedT ctxt ty)) = ForallT (map tvbToTH tvbs) (map predToTH ctxt) (typeToTH ty) typeToTH (DForallT tele ty) = case tele of DForallInvis tvbs -> ForallT (map tvbToTH tvbs) [] ty' DForallVis _tvbs -> #if __GLASGOW_HASKELL__ >= 809 ForallVisT (map tvbToTH _tvbs) ty' #else error "Visible dependent quantification supported only in GHC 8.10+" #endif where ty' = typeToTH ty typeToTH (DConstrainedT cxt ty) = ForallT [] (map predToTH cxt) (typeToTH ty) typeToTH (DAppT t1 t2) = AppT (typeToTH t1) (typeToTH t2) typeToTH (DSigT ty ki) = SigT (typeToTH ty) (typeToTH ki) typeToTH (DVarT n) = VarT n typeToTH (DConT n) = tyconToTH n typeToTH DArrowT = ArrowT typeToTH (DLitT lit) = LitT lit typeToTH DWildCardT = WildCardT #if __GLASGOW_HASKELL__ >= 807 typeToTH (DAppKindT t k) = AppKindT (typeToTH t) (typeToTH k) #else -- In the event that we're on a version of Template Haskell without support for -- kind applications, we will simply drop the applied kind. typeToTH (DAppKindT t _) = typeToTH t #endif tvbToTH :: DTyVarBndr flag -> TyVarBndr_ flag tvbToTH (DPlainTV n flag) = plainTVFlag n flag tvbToTH (DKindedTV n flag k) = kindedTVFlag n flag (typeToTH k) cxtToTH :: DCxt -> Cxt cxtToTH = map predToTH #if __GLASGOW_HASKELL__ >= 801 derivClauseToTH :: DDerivClause -> [DerivClause] derivClauseToTH (DDerivClause mds cxt) = [DerivClause (fmap derivStrategyToTH mds) (cxtToTH cxt)] #else derivClauseToTH :: DDerivClause -> Cxt derivClauseToTH (DDerivClause _ cxt) = cxtToTH cxt #endif #if __GLASGOW_HASKELL__ >= 801 derivStrategyToTH :: DDerivStrategy -> DerivStrategy derivStrategyToTH DStockStrategy = StockStrategy derivStrategyToTH DAnyclassStrategy = AnyclassStrategy derivStrategyToTH DNewtypeStrategy = NewtypeStrategy #if __GLASGOW_HASKELL__ >= 805 derivStrategyToTH (DViaStrategy ty) = ViaStrategy (typeToTH ty) #else derivStrategyToTH (DViaStrategy _) = error "DerivingVia supported only in GHC 8.6+" #endif #endif #if __GLASGOW_HASKELL__ >= 801 patSynDirToTH :: DPatSynDir -> PatSynDir patSynDirToTH DUnidir = Unidir patSynDirToTH DImplBidir = ImplBidir patSynDirToTH (DExplBidir clauses) = ExplBidir (map clauseToTH clauses) #endif predToTH :: DPred -> Pred predToTH (DAppT p t) = AppT (predToTH p) (typeToTH t) predToTH (DSigT p k) = SigT (predToTH p) (typeToTH k) predToTH (DVarT n) = VarT n predToTH (DConT n) = typeToTH (DConT n) predToTH DArrowT = ArrowT predToTH (DLitT lit) = LitT lit predToTH DWildCardT = WildCardT #if __GLASGOW_HASKELL__ >= 805 -- We need a special case for DForallT ForallInvis followed by DConstrainedT -- so that we may collapse them into a single ForallT when sweetening. -- See Note [Desugaring and sweetening ForallT] in L.H.T.Desugar.Core. predToTH (DForallT (DForallInvis tvbs) (DConstrainedT ctxt p)) = ForallT (map tvbToTH tvbs) (map predToTH ctxt) (predToTH p) predToTH (DForallT tele p) = case tele of DForallInvis tvbs -> ForallT (map tvbToTH tvbs) [] (predToTH p) DForallVis _ -> error "Visible dependent quantifier spotted at head of a constraint" predToTH (DConstrainedT cxt p) = ForallT [] (map predToTH cxt) (predToTH p) #else predToTH (DForallT {}) = error "Quantified constraints supported only in GHC 8.6+" predToTH (DConstrainedT {}) = error "Quantified constraints supported only in GHC 8.6+" #endif #if __GLASGOW_HASKELL__ >= 807 predToTH (DAppKindT p k) = AppKindT (predToTH p) (typeToTH k) #else -- In the event that we're on a version of Template Haskell without support for -- kind applications, we will simply drop the applied kind. predToTH (DAppKindT p _) = predToTH p #endif tyconToTH :: Name -> Type tyconToTH n | n == ''(->) = ArrowT -- Work around Trac #14888 | n == ''[] = ListT | n == ''(~) = EqualityT | n == '[] = PromotedNilT | n == '(:) = PromotedConsT | Just deg <- tupleNameDegree_maybe n = if isDataName n #if __GLASGOW_HASKELL__ >= 805 then PromotedTupleT deg #else then PromotedT n -- Work around Trac #14843 #endif else TupleT deg | Just deg <- unboxedTupleNameDegree_maybe n = UnboxedTupleT deg #if __GLASGOW_HASKELL__ >= 801 | Just deg <- unboxedSumNameDegree_maybe n = UnboxedSumT deg #endif | otherwise = ConT n typeArgToTH :: DTypeArg -> TypeArg typeArgToTH (DTANormal t) = TANormal (typeToTH t) typeArgToTH (DTyArg k) = TyArg (typeToTH k) th-desugar-1.15/Language/Haskell/TH/Desugar/Util.hs0000644000000000000000000005053407346545000020167 0ustar0000000000000000{- Language/Haskell/TH/Desugar/Util.hs (c) Richard Eisenberg 2013 rae@cs.brynmawr.edu Utility functions for th-desugar package. -} {-# LANGUAGE CPP, DeriveDataTypeable, DeriveGeneric, DeriveLift, RankNTypes, ScopedTypeVariables, TupleSections, AllowAmbiguousTypes, TemplateHaskellQuotes, TypeApplications #-} module Language.Haskell.TH.Desugar.Util ( newUniqueName, impossible, nameOccursIn, allNamesIn, mkTypeName, mkDataName, mkNameWith, isDataName, stripVarP_maybe, extractBoundNamesStmt, concatMapM, mapAccumLM, mapMaybeM, expectJustM, stripPlainTV_maybe, thirdOf3, splitAtList, extractBoundNamesDec, extractBoundNamesPat, tvbToType, tvbToTypeWithSig, tvbToTANormalWithSig, nameMatches, thdOf3, liftFst, liftSnd, firstMatch, firstMatchM, unboxedSumDegree_maybe, unboxedSumNameDegree_maybe, tupleDegree_maybe, tupleNameDegree_maybe, unboxedTupleDegree_maybe, unboxedTupleNameDegree_maybe, splitTuple_maybe, topEverywhereM, isInfixDataCon, isTypeKindName, typeKindName, unSigType, unfoldType, ForallTelescope(..), FunArgs(..), VisFunArg(..), filterVisFunArgs, ravelType, unravelType, TypeArg(..), applyType, filterTANormals, probablyWrongUnTypeArg, bindIP, DataFlavor(..) ) where import Prelude hiding (mapM, foldl, concatMap, any) import Language.Haskell.TH hiding ( cxt ) import Language.Haskell.TH.Datatype.TyVarBndr import qualified Language.Haskell.TH.Desugar.OSet as OS import Language.Haskell.TH.Desugar.OSet (OSet) import Language.Haskell.TH.Syntax import qualified Control.Monad.Fail as Fail import Data.Foldable import qualified Data.Kind as Kind import Data.Generics ( Data, Typeable, everything, extM, gmapM, mkQ ) import Data.Traversable import Data.Maybe import GHC.Classes ( IP ) import GHC.Generics ( Generic ) import Unsafe.Coerce ( unsafeCoerce ) ---------------------------------------- -- TH manipulations ---------------------------------------- -- | Like newName, but even more unique (unique across different splices), -- and with unique @nameBase@s. Precondition: the string is a valid Haskell -- alphanumeric identifier (could be upper- or lower-case). newUniqueName :: Quasi q => String -> q Name newUniqueName str = do n <- qNewName str qNewName $ show n -- | @mkNameWith lookup_fun mkName_fun str@ looks up the exact 'Name' of @str@ -- using the function @lookup_fun@. If it finds 'Just' the 'Name', meaning -- that it is bound in the current scope, then it is returned. If it finds -- 'Nothing', it assumes that @str@ is declared in the current module, and -- uses @mkName_fun@ to construct the appropriate 'Name' to return. mkNameWith :: Quasi q => (String -> q (Maybe Name)) -> (String -> String -> String -> Name) -> String -> q Name mkNameWith lookup_fun mkName_fun str = do m_name <- lookup_fun str case m_name of Just name -> return name Nothing -> do Loc { loc_package = pkg, loc_module = modu } <- qLocation return $ mkName_fun pkg modu str -- | Like TH's @lookupTypeName@, but if this name is not bound, then we assume -- it is declared in the current module. mkTypeName :: Quasi q => String -> q Name mkTypeName = mkNameWith (qLookupName True) mkNameG_tc -- | Like TH's @lookupDataName@, but if this name is not bound, then we assume -- it is declared in the current module. mkDataName :: Quasi q => String -> q Name mkDataName = mkNameWith (qLookupName False) mkNameG_d -- | Is this name a data constructor name? A 'False' answer means "unsure". isDataName :: Name -> Bool isDataName (Name _ (NameG DataName _ _)) = True isDataName _ = False -- | Extracts the name out of a variable pattern, or returns @Nothing@ stripVarP_maybe :: Pat -> Maybe Name stripVarP_maybe (VarP name) = Just name stripVarP_maybe _ = Nothing -- | Extracts the name out of a @PlainTV@, or returns @Nothing@ stripPlainTV_maybe :: TyVarBndr_ flag -> Maybe Name stripPlainTV_maybe = elimTV Just (\_ _ -> Nothing) -- | Report that a certain TH construct is impossible impossible :: Fail.MonadFail q => String -> q a impossible err = Fail.fail (err ++ "\n This should not happen in Haskell.\n Please email rae@cs.brynmawr.edu with your code if you see this.") -- | Convert a 'TyVarBndr' into a 'Type', dropping the kind signature -- (if it has one). tvbToType :: TyVarBndr_ flag -> Type tvbToType = VarT . tvName -- | Convert a 'TyVarBndr' into a 'Type', preserving the kind signature -- (if it has one). tvbToTypeWithSig :: TyVarBndr_ flag -> Type tvbToTypeWithSig = elimTV VarT (\n k -> SigT (VarT n) k) -- | Convert a 'TyVarBndr' into a 'TypeArg' (specifically, a 'TANormal'), -- preserving the kind signature (if it has one). tvbToTANormalWithSig :: TyVarBndr_ flag -> TypeArg tvbToTANormalWithSig = TANormal . tvbToTypeWithSig -- | Do two names name the same thing? nameMatches :: Name -> Name -> Bool nameMatches n1@(Name occ1 flav1) n2@(Name occ2 flav2) | NameS <- flav1 = occ1 == occ2 | NameS <- flav2 = occ1 == occ2 | NameQ mod1 <- flav1 , NameQ mod2 <- flav2 = mod1 == mod2 && occ1 == occ2 | NameQ mod1 <- flav1 , NameG _ _ mod2 <- flav2 = mod1 == mod2 && occ1 == occ2 | NameG _ _ mod1 <- flav1 , NameQ mod2 <- flav2 = mod1 == mod2 && occ1 == occ2 | otherwise = n1 == n2 -- | Extract the degree of a tuple tupleDegree_maybe :: String -> Maybe Int tupleDegree_maybe s = do '(' : s1 <- return s (commas, ")") <- return $ span (== ',') s1 let degree | "" <- commas = 0 | otherwise = length commas + 1 return degree -- | Extract the degree of a tuple name tupleNameDegree_maybe :: Name -> Maybe Int tupleNameDegree_maybe = tupleDegree_maybe . nameBase -- | Extract the degree of an unboxed sum unboxedSumDegree_maybe :: String -> Maybe Int unboxedSumDegree_maybe = unboxedSumTupleDegree_maybe '|' -- | Extract the degree of an unboxed sum name unboxedSumNameDegree_maybe :: Name -> Maybe Int unboxedSumNameDegree_maybe = unboxedSumDegree_maybe . nameBase -- | Extract the degree of an unboxed tuple unboxedTupleDegree_maybe :: String -> Maybe Int unboxedTupleDegree_maybe = unboxedSumTupleDegree_maybe ',' -- | Extract the degree of an unboxed sum or tuple unboxedSumTupleDegree_maybe :: Char -> String -> Maybe Int unboxedSumTupleDegree_maybe sep s = do '(' : '#' : s1 <- return s (seps, "#)") <- return $ span (== sep) s1 let degree | "" <- seps = 0 | otherwise = length seps + 1 return degree -- | Extract the degree of an unboxed tuple name unboxedTupleNameDegree_maybe :: Name -> Maybe Int unboxedTupleNameDegree_maybe = unboxedTupleDegree_maybe . nameBase -- | If the argument is a tuple type, return the components splitTuple_maybe :: Type -> Maybe [Type] splitTuple_maybe t = go [] t where go args (t1 `AppT` t2) = go (t2:args) t1 go args (t1 `SigT` _k) = go args t1 go args (ConT con_name) | Just degree <- tupleNameDegree_maybe con_name , length args == degree = Just args go args (TupleT degree) | length args == degree = Just args go _ _ = Nothing -- | The type variable binders in a @forall@. This is not used by the TH AST -- itself, but this is used as an intermediate data type in 'FAForalls'. data ForallTelescope = ForallVis [TyVarBndrUnit] -- ^ A visible @forall@ (e.g., @forall a -> {...}@). -- These do not have any notion of specificity, so we use -- '()' as a placeholder value in the 'TyVarBndr's. | ForallInvis [TyVarBndrSpec] -- ^ An invisible @forall@ (e.g., @forall a {b} c -> {...}@), -- where each binder has a 'Specificity'. deriving (Eq, Show, Data) -- | The list of arguments in a function 'Type'. data FunArgs = FANil -- ^ No more arguments. | FAForalls ForallTelescope FunArgs -- ^ A series of @forall@ed type variables followed by a dot (if -- 'ForallInvis') or an arrow (if 'ForallVis'). For example, -- the type variables @a1 ... an@ in @forall a1 ... an. r@. | FACxt Cxt FunArgs -- ^ A series of constraint arguments followed by @=>@. For example, -- the @(c1, ..., cn)@ in @(c1, ..., cn) => r@. | FAAnon Type FunArgs -- ^ An anonymous argument followed by an arrow. For example, the @a@ -- in @a -> r@. deriving (Eq, Show, Data) -- | A /visible/ function argument type (i.e., one that must be supplied -- explicitly in the source code). This is in contrast to /invisible/ -- arguments (e.g., the @c@ in @c => r@), which are instantiated without -- the need for explicit user input. data VisFunArg = VisFADep TyVarBndrUnit -- ^ A visible @forall@ (e.g., @forall a -> a@). | VisFAAnon Type -- ^ An anonymous argument followed by an arrow (e.g., @a -> r@). deriving (Eq, Show, Data) -- | Filter the visible function arguments from a list of 'FunArgs'. filterVisFunArgs :: FunArgs -> [VisFunArg] filterVisFunArgs FANil = [] filterVisFunArgs (FAForalls tele args) = case tele of ForallVis tvbs -> map VisFADep tvbs ++ args' ForallInvis _ -> args' where args' = filterVisFunArgs args filterVisFunArgs (FACxt _ args) = filterVisFunArgs args filterVisFunArgs (FAAnon t args) = VisFAAnon t:filterVisFunArgs args -- | Reconstruct an arrow 'Type' from its argument and result types. ravelType :: FunArgs -> Type -> Type ravelType FANil res = res -- We need a special case for FAForalls ForallInvis followed by FACxt so that we may -- collapse them into a single ForallT when raveling. -- See Note [Desugaring and sweetening ForallT] in L.H.T.Desugar.Core. ravelType (FAForalls (ForallInvis tvbs) (FACxt p args)) res = ForallT tvbs p (ravelType args res) ravelType (FAForalls (ForallInvis tvbs) args) res = ForallT tvbs [] (ravelType args res) ravelType (FAForalls (ForallVis _tvbs) _args) _res = #if __GLASGOW_HASKELL__ >= 809 ForallVisT _tvbs (ravelType _args _res) #else error "Visible dependent quantification supported only on GHC 8.10+" #endif ravelType (FACxt cxt args) res = ForallT [] cxt (ravelType args res) ravelType (FAAnon t args) res = AppT (AppT ArrowT t) (ravelType args res) -- | Decompose a function 'Type' into its arguments (the 'FunArgs') and its -- result type (the 'Type). unravelType :: Type -> (FunArgs, Type) unravelType (ForallT tvbs cxt ty) = let (args, res) = unravelType ty in (FAForalls (ForallInvis tvbs) (FACxt cxt args), res) unravelType (AppT (AppT ArrowT t1) t2) = let (args, res) = unravelType t2 in (FAAnon t1 args, res) #if __GLASGOW_HASKELL__ >= 809 unravelType (ForallVisT tvbs ty) = let (args, res) = unravelType ty in (FAForalls (ForallVis tvbs) args, res) #endif unravelType t = (FANil, t) -- | Remove all of the explicit kind signatures from a 'Type'. unSigType :: Type -> Type unSigType (SigT t _) = t unSigType (AppT f x) = AppT (unSigType f) (unSigType x) unSigType (ForallT tvbs ctxt t) = ForallT tvbs (map unSigPred ctxt) (unSigType t) unSigType (InfixT t1 n t2) = InfixT (unSigType t1) n (unSigType t2) unSigType (UInfixT t1 n t2) = UInfixT (unSigType t1) n (unSigType t2) unSigType (ParensT t) = ParensT (unSigType t) #if __GLASGOW_HASKELL__ >= 807 unSigType (AppKindT t k) = AppKindT (unSigType t) (unSigType k) unSigType (ImplicitParamT n t) = ImplicitParamT n (unSigType t) #endif unSigType t = t -- | Remove all of the explicit kind signatures from a 'Pred'. unSigPred :: Pred -> Pred unSigPred = unSigType -- | Decompose an applied type into its individual components. For example, this: -- -- @ -- Proxy \@Type Char -- @ -- -- would be unfolded to this: -- -- @ -- ('ConT' ''Proxy, ['TyArg' ('ConT' ''Type), 'TANormal' ('ConT' ''Char)]) -- @ unfoldType :: Type -> (Type, [TypeArg]) unfoldType = go [] where go :: [TypeArg] -> Type -> (Type, [TypeArg]) go acc (ForallT _ _ ty) = go acc ty go acc (AppT ty1 ty2) = go (TANormal ty2:acc) ty1 go acc (SigT ty _) = go acc ty go acc (ParensT ty) = go acc ty #if __GLASGOW_HASKELL__ >= 807 go acc (AppKindT ty ki) = go (TyArg ki:acc) ty #endif go acc ty = (ty, acc) -- | An argument to a type, either a normal type ('TANormal') or a visible -- kind application ('TyArg'). -- -- 'TypeArg' is useful when decomposing an application of a 'Type' to its -- arguments (e.g., in 'unfoldType'). data TypeArg = TANormal Type | TyArg Kind deriving (Eq, Show, Data) -- | Apply one 'Type' to a list of arguments. applyType :: Type -> [TypeArg] -> Type applyType = foldl apply where apply :: Type -> TypeArg -> Type apply f (TANormal x) = f `AppT` x apply f (TyArg _x) = #if __GLASGOW_HASKELL__ >= 807 f `AppKindT` _x #else -- VKA isn't supported, so -- conservatively drop the argument f #endif -- | Filter the normal type arguments from a list of 'TypeArg's. filterTANormals :: [TypeArg] -> [Type] filterTANormals = mapMaybe getTANormal where getTANormal :: TypeArg -> Maybe Type getTANormal (TANormal t) = Just t getTANormal (TyArg {}) = Nothing -- | Extract the underlying 'Type' or 'Kind' from a 'TypeArg'. This forgets -- information about whether a type is a normal argument or not, so use with -- caution. probablyWrongUnTypeArg :: TypeArg -> Type probablyWrongUnTypeArg (TANormal t) = t probablyWrongUnTypeArg (TyArg k) = k ---------------------------------------- -- Free names, etc. ---------------------------------------- -- | Check if a name occurs anywhere within a TH tree. nameOccursIn :: Data a => Name -> a -> Bool nameOccursIn n = everything (||) $ mkQ False (== n) -- | Extract all Names mentioned in a TH tree. allNamesIn :: Data a => a -> [Name] allNamesIn = everything (++) $ mkQ [] (:[]) -- | Extract the names bound in a @Stmt@ extractBoundNamesStmt :: Stmt -> OSet Name extractBoundNamesStmt (BindS pat _) = extractBoundNamesPat pat extractBoundNamesStmt (LetS decs) = foldMap extractBoundNamesDec decs extractBoundNamesStmt (NoBindS _) = OS.empty extractBoundNamesStmt (ParS stmtss) = foldMap (foldMap extractBoundNamesStmt) stmtss #if __GLASGOW_HASKELL__ >= 807 extractBoundNamesStmt (RecS stmtss) = foldMap extractBoundNamesStmt stmtss #endif -- | Extract the names bound in a @Dec@ that could appear in a @let@ expression. extractBoundNamesDec :: Dec -> OSet Name extractBoundNamesDec (FunD name _) = OS.singleton name extractBoundNamesDec (ValD pat _ _) = extractBoundNamesPat pat extractBoundNamesDec _ = OS.empty -- | Extract the names bound in a @Pat@ extractBoundNamesPat :: Pat -> OSet Name extractBoundNamesPat (LitP _) = OS.empty extractBoundNamesPat (VarP name) = OS.singleton name extractBoundNamesPat (TupP pats) = foldMap extractBoundNamesPat pats extractBoundNamesPat (UnboxedTupP pats) = foldMap extractBoundNamesPat pats extractBoundNamesPat (ConP _ #if __GLASGOW_HASKELL__ >= 901 _ #endif pats) = foldMap extractBoundNamesPat pats extractBoundNamesPat (InfixP p1 _ p2) = extractBoundNamesPat p1 `OS.union` extractBoundNamesPat p2 extractBoundNamesPat (UInfixP p1 _ p2) = extractBoundNamesPat p1 `OS.union` extractBoundNamesPat p2 extractBoundNamesPat (ParensP pat) = extractBoundNamesPat pat extractBoundNamesPat (TildeP pat) = extractBoundNamesPat pat extractBoundNamesPat (BangP pat) = extractBoundNamesPat pat extractBoundNamesPat (AsP name pat) = OS.singleton name `OS.union` extractBoundNamesPat pat extractBoundNamesPat WildP = OS.empty extractBoundNamesPat (RecP _ field_pats) = let (_, pats) = unzip field_pats in foldMap extractBoundNamesPat pats extractBoundNamesPat (ListP pats) = foldMap extractBoundNamesPat pats extractBoundNamesPat (SigP pat _) = extractBoundNamesPat pat extractBoundNamesPat (ViewP _ pat) = extractBoundNamesPat pat #if __GLASGOW_HASKELL__ >= 801 extractBoundNamesPat (UnboxedSumP pat _ _) = extractBoundNamesPat pat #endif ---------------------------------------- -- General utility ---------------------------------------- -- dirty implementation of explicit-to-implicit conversion newtype MagicIP name a r = MagicIP (IP name a => r) -- | Get an implicit param constraint (@IP name a@, which is the desugared -- form of @(?name :: a)@) from an explicit value. -- -- This function is only available with GHC 8.0 or later. bindIP :: forall name a r. a -> (IP name a => r) -> r bindIP val k = (unsafeCoerce (MagicIP @name k) :: a -> r) val -- like GHC's splitAtList :: [a] -> [b] -> ([b], [b]) splitAtList [] x = ([], x) splitAtList (_ : t) (x : xs) = let (as, bs) = splitAtList t xs in (x : as, bs) splitAtList (_ : _) [] = ([], []) thdOf3 :: (a,b,c) -> c thdOf3 (_,_,c) = c liftFst :: (a -> b) -> (a, c) -> (b, c) liftFst f (a,c) = (f a, c) liftSnd :: (a -> b) -> (c, a) -> (c, b) liftSnd f (c,a) = (c, f a) thirdOf3 :: (a -> b) -> (c, d, a) -> (c, d, b) thirdOf3 f (c, d, a) = (c, d, f a) -- lift concatMap into a monad -- could this be more efficient? -- | Concatenate the result of a @mapM@ concatMapM :: (Monad monad, Monoid monoid, Traversable t) => (a -> monad monoid) -> t a -> monad monoid concatMapM fn list = do bss <- mapM fn list return $ fold bss -- like GHC's -- | Monadic version of mapAccumL mapAccumLM :: Monad m => (acc -> x -> m (acc, y)) -- ^ combining function -> acc -- ^ initial state -> [x] -- ^ inputs -> m (acc, [y]) -- ^ final state, outputs mapAccumLM _ s [] = return (s, []) mapAccumLM f s (x:xs) = do (s1, x') <- f s x (s2, xs') <- mapAccumLM f s1 xs return (s2, x' : xs') -- like GHC's mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b] mapMaybeM _ [] = return [] mapMaybeM f (x:xs) = do y <- f x ys <- mapMaybeM f xs return $ case y of Nothing -> ys Just z -> z : ys expectJustM :: Fail.MonadFail m => String -> Maybe a -> m a expectJustM _ (Just x) = return x expectJustM err Nothing = Fail.fail err firstMatch :: (a -> Maybe b) -> [a] -> Maybe b firstMatch f xs = listToMaybe $ mapMaybe f xs firstMatchM :: Monad m => (a -> m (Maybe b)) -> [a] -> m (Maybe b) firstMatchM f xs = listToMaybe <$> mapMaybeM f xs -- | Semi-shallow version of 'everywhereM' - does not recurse into children of nodes of type @a@ (only applies the handler to them). -- -- >>> topEverywhereM (pure . fmap (*10) :: [Integer] -> Identity [Integer]) ([1,2,3] :: [Integer], "foo" :: String) -- Identity ([10,20,30],"foo") -- -- >>> everywhereM (mkM (pure . fmap (*10) :: [Integer] -> Identity [Integer])) ([1,2,3] :: [Integer], "foo" :: String) -- Identity ([10,200,3000],"foo") topEverywhereM :: (Typeable a, Data b, Monad m) => (a -> m a) -> b -> m b topEverywhereM handler = gmapM (topEverywhereM handler) `extM` handler -- Checks if a String names a valid Haskell infix data constructor -- (i.e., does it begin with a colon?). isInfixDataCon :: String -> Bool isInfixDataCon (':':_) = True isInfixDataCon _ = False -- | Returns 'True' if the argument 'Name' is that of 'Kind.Type' -- (or @*@ or 'Kind.★', to support older GHCs). isTypeKindName :: Name -> Bool isTypeKindName n = n == typeKindName #if __GLASGOW_HASKELL__ < 805 || n == starKindName || n == uniStarKindName #endif -- | The 'Name' of the kind 'Kind.Type'. -- 2. The kind @*@ on older GHCs. typeKindName :: Name typeKindName = ''Kind.Type #if __GLASGOW_HASKELL__ < 805 -- | The 'Name' of the kind @*@. starKindName :: Name starKindName = ''(Kind.*) -- | The 'Name' of the kind 'Kind.★'. uniStarKindName :: Name uniStarKindName = ''(Kind.★) #endif -- | Is a data type or data instance declaration a @newtype@ declaration, a -- @data@ declaration, or a @type data@ declaration? data DataFlavor = Newtype -- ^ @newtype@ | Data -- ^ @data@ | TypeData -- ^ @type data@ deriving (Eq, Show, Data, Generic, Lift) th-desugar-1.15/README.md0000644000000000000000000001131607346545000013155 0ustar0000000000000000`th-desugar` Package ==================== [![Hackage](https://img.shields.io/hackage/v/th-desugar.svg)](http://hackage.haskell.org/package/th-desugar) [![Build Status](https://github.com/goldfirere/th-desugar/workflows/Haskell-CI/badge.svg)](https://github.com/goldfirere/th-desugar/actions?query=workflow%3AHaskell-CI) This package provides the `Language.Haskell.TH.Desugar` module, which desugars Template Haskell's rich encoding of Haskell syntax into a simpler encoding. This desugaring discards surface syntax information (such as the use of infix operators) but retains the original meaning of the TH code. The intended use of this package is as a preprocessor for more advanced code manipulation tools. Note that the input to any of the `ds...` functions should be produced from a TH quote, using the syntax `[| ... |]`. If the input to these functions is a hand-coded TH syntax tree, the results may be unpredictable. In particular, it is likely that promoted datatypes will not work as expected. One explicit goal of this package is to reduce the burden of supporting multiple GHC / TH versions. Thus, the desugared language is the same across all GHC versions, and any inconsistencies are handled internally. The package was designed for use with the `singletons` package, so some design decisions are based on that use case, when more than one design choice was possible. I will try to keep this package up-to-date with respect to changes in GHC. The minimum supported version of GHC is 8.0, which was chosen to avoid various Template Haskell bugs in older GHC versions that affect how this library desugars code. If this choice negatively impacts you, please submit a bug report. Known limitations ----------------- ## Limited support for kind inference `th-desugar` sometimes has to construct types for certain Haskell entities. For instance, `th-desugar` desugars all Haskell98-style constructors to use GADT syntax, so the following: ```haskell data T (a :: k) = MkT (Proxy a) ``` Will be desugared to something like this: ```haskell data T (a :: k) where MkT :: forall k (a :: k). Proxy a -> T (a :: k) ``` Notice that `k` is explicitly quantified in the type of `MkT`. This is due to an additional pass that `th-desugar` performs over the type variable binders of `T` to extract all implicitly quantified variables and make them explicit. This makes the desugared types forwards-compatible with a [future version of GHC](https://github.com/goldfirere/ghc-proposals/blob/bbefbee6fc0cddb10bbacc85f79e66c2706ce13f/proposals/0000-no-kind-vars.rst) that requires all kind variables in a top-level `forall` to be explicitly quantified. This process of extracting all implicitly quantified kind variables is not perfect, however. There are some obscure programs that will cause `th-desugar` to produce type variable binders that are ill scoped. Here is one example: ```haskell data P k (a :: k) data Foo (a :: Proxy j) (b :: k) c = MkFoo c (P k j) ``` If you squint hard at `MkFoo`, you'll notice that `j :: k`. However, this relationship is not expressed _syntactically_, which means that `th-desugar` will not be aware of it. Therefore, `th-desugar` will desugar `Foo` to: ```haskell data Foo (a :: Proxy j) (b :: k) c where MkFoo :: forall j k (a :: Proxy j) (b :: k) c. c -> P k j -> Foo (a :: Proxy j) (b :: k) c ``` This is incorrect since `k` must come before `j` in order to be well scoped. There is a workaround to this issue, however: add more explicit kind information. If you had instead written this: ```haskell data Foo (a :: Proxy (j :: k)) (b :: k) c = MkFoo c (P k j) ``` Then the fact that `j :: k` is expressed directly in the AST, so `th-desugar` is able to pick up on it and pick `forall k j (a :: Proxy j) (b :: k) c. <...>` as the telescope for the type of `MkFoo`. The following constructs are known to be susceptible to this issue: 1. Desugared Haskell98-style constructors 2. Locally reified class methods 3. Locally reified record selectors 4. Locally reified data constructors 5. Locally reified type family instances (on GHC 8.8 and later, in which the Template Haskell AST supports explicit `foralls` in type family equations) ## Limited support for linear types Currently, the `th-desugar` AST deliberately makes it impossible to represent linear types, and desugaring a linear function arrow will simply turn into a normal function arrow `(->)`. This choice is partly motivated by issues in the way that linear types interact with Template Haskell, which sometimes make it impossible to tell whether a reified function type is linear or not. See, for instance, [GHC#18378](https://gitlab.haskell.org/ghc/ghc/-/issues/18378). th-desugar-1.15/Setup.hs0000644000000000000000000000006007346545000013324 0ustar0000000000000000import Distribution.Simple main = defaultMain th-desugar-1.15/Test/0000755000000000000000000000000007346545000012613 5ustar0000000000000000th-desugar-1.15/Test/Dec.hs0000644000000000000000000000220107346545000013635 0ustar0000000000000000{- Tests for the th-desugar package (c) Richard Eisenberg 2013 rae@cs.brynmawr.edu -} {-# LANGUAGE TemplateHaskell, GADTs, PolyKinds, TypeFamilies, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, DataKinds, CPP, RankNTypes, StandaloneDeriving, DefaultSignatures, ConstraintKinds, RoleAnnotations, DeriveAnyClass #-} {-# OPTIONS_GHC -Wno-orphans -Wno-name-shadowing -Wno-redundant-constraints #-} module Dec where import qualified Splices as S import Splices ( unqualify ) $(S.dectest1) $(S.dectest2) $(S.dectest3) $(S.dectest4) $(S.dectest5) $(S.dectest6) $(S.dectest7) $(S.dectest8) $(S.dectest9) $(S.dectest10) $(S.dectest11) $(S.dectest12) $(S.dectest13) $(S.dectest14) $(S.dectest15) #if __GLASGOW_HASKELL__ >= 802 $(S.dectest16) $(S.dectest17) #endif #if __GLASGOW_HASKELL__ >= 809 $(S.dectest18) #endif $(fmap unqualify S.instance_test) $(fmap unqualify S.imp_inst_test1) $(fmap unqualify S.imp_inst_test2) $(fmap unqualify S.imp_inst_test3) $(fmap unqualify S.imp_inst_test4) $(S.rec_sel_test) th-desugar-1.15/Test/DsDec.hs0000644000000000000000000000530207346545000014131 0ustar0000000000000000{- Tests for the th-desugar package (c) Richard Eisenberg 2013 rae@cs.brynmawr.edu -} {-# LANGUAGE TemplateHaskell, GADTs, PolyKinds, TypeFamilies, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, DataKinds, CPP, RankNTypes, StandaloneDeriving, DefaultSignatures, ConstraintKinds, RoleAnnotations, DeriveAnyClass #-} #if __GLASGOW_HASKELL__ >= 801 {-# LANGUAGE DerivingStrategies #-} #endif {-# OPTIONS_GHC -Wno-orphans -Wno-incomplete-patterns -Wno-name-shadowing -Wno-redundant-constraints #-} module DsDec where import qualified Splices as S import Splices ( dsDecSplice, unqualify ) import Language.Haskell.TH.Desugar import Language.Haskell.TH.Syntax ( qReport ) import Control.Monad $(dsDecSplice S.dectest1) $(dsDecSplice S.dectest2) $(dsDecSplice S.dectest3) $(dsDecSplice S.dectest4) $(dsDecSplice S.dectest5) $(dsDecSplice S.dectest6) $(dsDecSplice S.dectest7) $(dsDecSplice S.dectest8) $(dsDecSplice S.dectest9) $(dsDecSplice (fmap unqualify S.instance_test)) $(dsDecSplice (fmap unqualify S.imp_inst_test1)) $(dsDecSplice (fmap unqualify S.imp_inst_test2)) $(dsDecSplice (fmap unqualify S.imp_inst_test3)) $(dsDecSplice (fmap unqualify S.imp_inst_test4)) $(dsDecSplice S.dectest10) $(dsDecSplice S.dectest11) $(dsDecSplice S.standalone_deriving_test) #if __GLASGOW_HASKELL__ >= 801 $(dsDecSplice S.deriv_strat_test) #endif $(dsDecSplice S.dectest12) $(dsDecSplice S.dectest13) $(dsDecSplice S.dectest14) $(dsDecSplice S.dectest15) #if __GLASGOW_HASKELL__ >= 802 $(return $ decsToTH [S.ds_dectest16]) $(return $ decsToTH [S.ds_dectest17]) #endif #if __GLASGOW_HASKELL__ >= 809 $(dsDecSplice S.dectest18) #endif $(do decs <- S.rec_sel_test withLocalDeclarations decs $ do [DDataD nd [] name [DPlainTV tvbName ()] k cons []] <- dsDecs decs recsels <- getRecordSelectors cons let num_sels = length recsels `div` 2 -- ignore type sigs when (num_sels /= S.rec_sel_test_num_sels) $ qReport True $ "Wrong number of record selectors extracted.\n" ++ "Wanted " ++ show S.rec_sel_test_num_sels ++ ", Got " ++ show num_sels let unrecord c@(DCon _ _ _ (DNormalC {}) _) = c unrecord (DCon tvbs cxt con_name (DRecC fields) rty) = let (_names, stricts, types) = unzip3 fields fields' = zip stricts types in DCon tvbs cxt con_name (DNormalC False fields') rty plaindata = [DDataD nd [] name [DPlainTV tvbName ()] k (map unrecord cons) []] return (decsToTH plaindata ++ map letDecToTH recsels)) th-desugar-1.15/Test/ReifyTypeCUSKs.hs0000644000000000000000000001004007346545000015733 0ustar0000000000000000{-# 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)) th-desugar-1.15/Test/ReifyTypeSigs.hs0000644000000000000000000000454307346545000015723 0ustar0000000000000000{-# 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) th-desugar-1.15/Test/Run.hs0000644000000000000000000010560707346545000013724 0ustar0000000000000000{- Tests for the th-desugar package (c) Richard Eisenberg 2013 rae@cs.brynmawr.edu -} {-# LANGUAGE TemplateHaskell, UnboxedTuples, ParallelListComp, CPP, RankNTypes, TypeFamilies, DataKinds, ConstraintKinds, PolyKinds, MultiParamTypeClasses, FlexibleInstances, ExistentialQuantification, ScopedTypeVariables, GADTs, ViewPatterns, TupleSections, TypeOperators, PartialTypeSignatures, PatternSynonyms, TypeApplications #-} {-# OPTIONS -Wno-incomplete-patterns -Wno-overlapping-patterns -Wno-unused-matches -Wno-type-defaults -Wno-missing-signatures -Wno-unused-do-bind -Wno-missing-fields -Wno-incomplete-record-updates -Wno-partial-type-signatures -Wno-redundant-constraints #-} #if __GLASGOW_HASKELL__ >= 805 {-# LANGUAGE DerivingVia #-} {-# LANGUAGE QuantifiedConstraints #-} #endif #if __GLASGOW_HASKELL__ >= 809 {-# LANGUAGE StandaloneKindSignatures #-} #endif #if __GLASGOW_HASKELL__ >= 906 {-# LANGUAGE TypeData #-} #endif module Main where import Prelude hiding ( exp ) import Test.HUnit import Test.Hspec hiding ( runIO ) -- import Test.Hspec.HUnit import Splices import qualified DsDec import qualified Dec import Dec ( RecordSel ) import ReifyTypeCUSKs import ReifyTypeSigs import T159Decs ( t159A, t159B ) import Language.Haskell.TH.Desugar import qualified Language.Haskell.TH.Desugar.OSet as OS import Language.Haskell.TH.Desugar.Expand ( expandUnsoundly ) import Language.Haskell.TH import qualified Language.Haskell.TH.Syntax as Syn ( NameSpace(..), lift ) import Control.Exception ( ErrorCall ) import Control.Monad import qualified Data.Map as M import Data.Proxy #if __GLASGOW_HASKELL__ >= 900 import Prelude as P #endif -- | -- Convert a HUnit test suite to a spec. This can be used to run existing -- HUnit tests with Hspec. fromHUnitTest :: Test -> Spec -- copied from https://github.com/hspec/hspec/blob/master/hspec-contrib/src/Test/Hspec/Contrib/HUnit.hs fromHUnitTest t = case t of TestList xs -> mapM_ go xs x -> go x where go :: Test -> Spec go t_ = case t_ of TestLabel s (TestCase e) -> it s e TestLabel s (TestList xs) -> describe s (mapM_ go xs) TestLabel s x -> describe s (go x) TestList xs -> describe "" (mapM_ go xs) TestCase e -> it "" e tests :: Test tests = test [ "sections" ~: $test1_sections @=? $(dsSplice test1_sections) , "lampats" ~: $test2_lampats @=? $(dsSplice test2_lampats) , "lamcase" ~: $test3_lamcase @=? $(dsSplice test3_lamcase) -- Must fix nested pattern-matching for this to work. Argh. -- , "tuples" ~: $test4_tuples @=? $(dsSplice test4_tuples) , "ifs" ~: $test5_ifs @=? $(dsSplice test5_ifs) , "ifs2" ~: $test6_ifs2 @=? $(dsSplice test6_ifs2) , "let" ~: $test7_let @=? $(dsSplice test7_let) , "case" ~: $test8_case @=? $(dsSplice test8_case) , "do" ~: $test9_do @=? $(dsSplice test9_do) , "comp" ~: $test10_comp @=? $(dsSplice test10_comp) , "parcomp" ~: $test11_parcomp @=? $(dsSplice test11_parcomp) , "parcomp2" ~: $test12_parcomp2 @=? $(dsSplice test12_parcomp2) , "sig" ~: $test13_sig @=? $(dsSplice test13_sig) , "record" ~: $test14_record @=? $(dsSplice test14_record) , "litp" ~: $test15_litp @=? $(dsSplice test15_litp) , "tupp" ~: $test16_tupp @=? $(dsSplice test16_tupp) , "infixp" ~: $test17_infixp @=? $(dsSplice test17_infixp) , "tildep" ~: $test18_tildep @=? $(dsSplice test18_tildep) , "bangp" ~: $test19_bangp @=? $(dsSplice test19_bangp) , "asp" ~: $test20_asp @=? $(dsSplice test20_asp) , "wildp" ~: $test21_wildp @=? $(dsSplice test21_wildp) , "listp" ~: $test22_listp @=? $(dsSplice test22_listp) #if __GLASGOW_HASKELL__ >= 801 , "sigp" ~: $test23_sigp @=? $(dsSplice test23_sigp) #endif , "fun" ~: $test24_fun @=? $(dsSplice test24_fun) , "fun2" ~: $test25_fun2 @=? $(dsSplice test25_fun2) , "forall" ~: $test26_forall @=? $(dsSplice test26_forall) , "kisig" ~: $test27_kisig @=? $(dsSplice test27_kisig) , "tupt" ~: $test28_tupt @=? $(dsSplice test28_tupt) , "listt" ~: $test29_listt @=? $(dsSplice test29_listt) , "promoted" ~: $test30_promoted @=? $(dsSplice test30_promoted) , "constraint" ~: $test31_constraint @=? $(dsSplice test31_constraint) , "tylit" ~: $test32_tylit @=? $(dsSplice test32_tylit) , "tvbs" ~: $test33_tvbs @=? $(dsSplice test33_tvbs) , "let_as" ~: $test34_let_as @=? $(dsSplice test34_let_as) , "pred" ~: $test37_pred @=? $(dsSplice test37_pred) , "pred2" ~: $test38_pred2 @=? $(dsSplice test38_pred2) , "eq" ~: $test39_eq @=? $(dsSplice test39_eq) , "wildcard" ~: $test40_wildcards@=? $(dsSplice test40_wildcards) #if __GLASGOW_HASKELL__ >= 801 , "typeapps" ~: $test41_typeapps @=? $(dsSplice test41_typeapps) , "scoped_tvs" ~: $test42_scoped_tvs @=? $(dsSplice test42_scoped_tvs) , "ubx_sums" ~: $test43_ubx_sums @=? $(dsSplice test43_ubx_sums) #endif , "let_pragma" ~: $test44_let_pragma @=? $(dsSplice test44_let_pragma) -- , "empty_rec" ~: $test45_empty_record_con @=? $(dsSplice test45_empty_record_con) -- This one can't be tested by this means, because it contains an "undefined" #if __GLASGOW_HASKELL__ >= 803 , "over_label" ~: $test46_overloaded_label @=? $(dsSplice test46_overloaded_label) #endif , "do_partial_match" ~: $test47_do_partial_match @=? $(dsSplice test47_do_partial_match) #if __GLASGOW_HASKELL__ >= 805 , "quantified_constraints" ~: $test48_quantified_constraints @=? $(dsSplice test48_quantified_constraints) #endif #if __GLASGOW_HASKELL__ >= 807 , "implicit_params" ~: $test49_implicit_params @=? $(dsSplice test49_implicit_params) , "vka" ~: $test50_vka @=? $(dsSplice test50_vka) #endif #if __GLASGOW_HASKELL__ >= 809 , "tuple_sections" ~: $test51_tuple_sections @=? $(dsSplice test51_tuple_sections) #endif #if __GLASGOW_HASKELL__ >= 900 , "qual_do" ~: $test52_qual_do @=? $(dsSplice test52_qual_do) #endif #if __GLASGOW_HASKELL__ >= 901 , "vta_in_con_pats" ~: $test53_vta_in_con_pats @=? $(dsSplice test53_vta_in_con_pats) #endif #if __GLASGOW_HASKELL__ >= 902 , "overloaded_record_dot" ~: $test54_overloaded_record_dot @=? $(dsSplice test54_overloaded_record_dot) #endif #if __GLASGOW_HASKELL__ >= 903 , "opaque_pragma" ~: $test55_opaque_pragma @=? $(dsSplice test55_opaque_pragma) , "lambda_cases" ~: $test56_lambda_cases @=? $(dsSplice test56_lambda_cases) #endif ] test35a = $test35_expand test35b = $(test35_expand >>= dsExp >>= expand >>= return . expToTH) test36a = $test36_expand test36b = $(test36_expand >>= dsExp >>= expand >>= return . expToTH) test_e3a = $test_expand3 test_e3b = $(test_expand3 >>= dsExp >>= expand >>= return . expToTH) test_e4a = $test_expand4 test_e4b = $(test_expand4 >>= dsExp >>= expand >>= return . expToTH) test_e5a = $test_expand5 test_e5b = $(test_expand5 >>= dsExp >>= expand >>= return . expToTH) test_e6a = $test_expand6 test_e6b = $(test_expand6 >>= dsExp >>= expand >>= return . expToTH) test_e7a = $test_expand7 test_e7b = $(test_expand7 >>= dsExp >>= expand >>= return . expToTH) test_e7c = $(test_expand7 >>= dsExp >>= expandUnsoundly >>= return . expToTH) #if __GLASGOW_HASKELL__ < 801 test_e8a = $(test_expand8 >>= dsExp >>= expand >>= return . expToTH) -- This won't expand on recent GHCs now that GHC Trac #8953 is fixed for -- closed type families. #endif test_e8b = $(test_expand8 >>= dsExp >>= expandUnsoundly >>= return . expToTH) test_e9a = $test_expand9 -- requires GHC #9262 test_e9b = $(test_expand9 >>= dsExp >>= expand >>= return . expToTH) test_e10a = $test_expand10 test_e10b = $(test_expand10 >>= dsExp >>= expand >>= return . expToTH) hasSameType :: a -> a -> Bool hasSameType _ _ = True test_expand :: Bool test_expand = and [ hasSameType test35a test35b , hasSameType test36a test36b , hasSameType test_e3a test_e3b , hasSameType test_e4a test_e4b , hasSameType test_e5a test_e5b , hasSameType test_e6a test_e6b , hasSameType test_e7a test_e7b , hasSameType test_e7a test_e7c #if __GLASGOW_HASKELL__ < 801 , hasSameType test_e8a test_e8a #endif , hasSameType test_e8b test_e8b , hasSameType test_e9a test_e9b , hasSameType test_e10a test_e10b ] test_dec :: [Bool] test_dec = $(do bools <- mapM testDecSplice dec_test_nums return $ ListE bools) $( do fuzzType <- mkTypeName "Fuzz" fuzzData <- mkDataName "Fuzz" let tySynDecs = TySynD (mkName "FuzzSyn") [] (ConT fuzzType) dataSynDecs = TySynD (mkName "FuzzDataSyn") [] (ConT fuzzData) fuzzDecs <- [d| data Fuzz = Fuzz |] return $ tySynDecs : dataSynDecs : fuzzDecs ) test_mkName :: Bool test_mkName = and [ hasSameType (Proxy :: Proxy FuzzSyn) (Proxy :: Proxy Fuzz) , hasSameType (Proxy :: Proxy FuzzDataSyn) (Proxy :: Proxy 'Fuzz) ] test_bug8884 :: Bool test_bug8884 = $(do info <- reify ''Poly dinfo@(DTyConI (DOpenTypeFamilyD (DTypeFamilyHead _name _tvbs (DKindSig resK) _ann)) (Just [DTySynInstD (DTySynEqn _ lhs _rhs)])) <- dsInfo info let isTypeKind (DConT n) = isTypeKindName n isTypeKind _ = False case (isTypeKind resK, lhs) of (True, _ `DAppT` DSigT (DVarT _) (DVarT _)) -> [| True |] _ -> do runIO $ do putStrLn "Failed bug8884 test:" putStrLn $ show dinfo [| False |] ) flatten_dvald :: Bool flatten_dvald = let s1 = $(flatten_dvald_test) s2 = $(do expr <- flatten_dvald_test DLetE ddecs dexpr <- dsExp expr flattened <- fmap concat $ mapM flattenDValD ddecs return $ expToTH $ DLetE flattened dexpr ) in s1 == s2 test_rec_sels :: Bool test_rec_sels = and $(do bools <- mapM testRecSelTypes [1..rec_sel_test_num_sels] return $ ListE bools) test_standalone_deriving :: Bool test_standalone_deriving = (MkBlarggie 5 'x') == (MkBlarggie 5 'x') test_deriving_strategies :: Bool #if __GLASGOW_HASKELL__ >= 801 test_deriving_strategies = compare (MkBlarggie 5 'x') (MkBlarggie 5 'x') == EQ #else test_deriving_strategies = True #endif test_local_tyfam_expansion :: Bool test_local_tyfam_expansion = $(do fam_name <- newName "Fam" let orig_ty = DConT fam_name exp_ty <- withLocalDeclarations (decsToTH [ DOpenTypeFamilyD (DTypeFamilyHead fam_name [] DNoSig Nothing) , DTySynInstD (DTySynEqn Nothing (DConT fam_name) (DConT ''Int)) ]) (expandType orig_ty) orig_ty `eqTHSplice` exp_ty) test_stuck_tyfam_expansion :: Bool test_stuck_tyfam_expansion = $(do fam_name <- newName "F" x <- newName "x" k <- newName "k" let orig_ty = DConT fam_name `DAppT` DConT '() -- F '() exp_ty <- withLocalDeclarations (decsToTH [ -- type family F (x :: k) :: k DOpenTypeFamilyD (DTypeFamilyHead fam_name [DKindedTV x () (DVarT k)] (DKindSig (DVarT k)) Nothing) -- type instance F (x :: ()) = x , DTySynInstD (DTySynEqn Nothing (DConT fam_name `DAppT` DSigT (DVarT x) (DConT ''())) (DVarT x)) ]) (expandType orig_ty) orig_ty `eqTHSplice` exp_ty) test_t85 :: Bool test_t85 = $(do let orig_ty = (DConT ''Constant `DAppT` DConT ''Int `DAppT` DConT 'True) `DSigT` (DConT ''Constant `DAppT` DConT ''Char `DAppT` DConT ''Bool) expected_ty = DConT 'True `DSigT` DConT ''Bool expanded_ty <- expandType orig_ty expected_ty `eqTHSplice` expanded_ty) test_t92 :: Bool test_t92 = $(do a <- newName "a" f <- newName "f" let t = DForallT (DForallInvis [DPlainTV f SpecifiedSpec]) (DVarT f `DAppT` DVarT a) toposortTyVarsOf [t] `eqTHSplice` [DPlainTV a ()]) test_t97 :: Bool test_t97 = $(do a <- newName "a" k <- newName "k" let orig_ty = DForallT (DForallInvis [DKindedTV a SpecifiedSpec (DConT ''Constant `DAppT` DConT ''Int `DAppT` DVarT k)]) (DVarT a) expected_ty = DForallT (DForallInvis [DKindedTV a SpecifiedSpec (DVarT k)]) (DVarT a) expanded_ty <- expandType orig_ty expected_ty `eqTHSplice` expanded_ty) test_getDataD_kind_sig :: Bool test_getDataD_kind_sig = 3 == $(do data_name <- newName "TestData" a <- newName "a" let type_kind = DConT typeKindName data_kind_sig = DArrowT `DAppT` type_kind `DAppT` (DArrowT `DAppT` type_kind `DAppT` type_kind) (_, tvbs, _) <- withLocalDeclarations [decToTH (DDataD Data [] data_name [DPlainTV a ()] (Just data_kind_sig) [] [])] (getDataD "th-desugar: Impossible" data_name) [| $(Syn.lift (length tvbs)) |]) test_t100 :: Bool test_t100 = $(do decs <- [d| data T b where MkT :: forall a. { unT :: a } -> T a |] info <- withLocalDeclarations decs (dsReify (mkName "unT")) let -- forall a. T a -> a exp_ty = DForallT (DForallInvis [DPlainTV (mkName "a") SpecifiedSpec]) $ DArrowT `DAppT` (DConT (mkName "T") `DAppT` DVarT (mkName "a")) `DAppT` DVarT (mkName "a") case info of Just (DVarI _ actual_ty _) -> exp_ty `eqTHSplice` actual_ty _ -> [| False |]) test_t102 :: [Bool] test_t102 = $(do decs1 <- [d| data Foo x where MkFoo :: forall a. { unFoo :: a } -> Foo a |] let b1 = withLocalDeclarations decs1 $ do [DDataD _ _ _ _ _ cons1 _] <- dsDecs decs1 recs1 <- getRecordSelectors cons1 (length recs1 `div` 2) `eqTHSplice` 1 decs2 <- [d| data HList l where Nil :: HList '[] (:>) :: { hhead :: x, htail :: HList xs } -> HList (x ': xs) |] let b2 = withLocalDeclarations decs2 $ do [DDataD _ _ _ _ _ cons2 _] <- dsDecs decs2 recs2 <- getRecordSelectors cons2 (length recs2 `div` 2) `eqTHSplice` 2 [| [$b1, $b2] |]) test_t103 :: Bool test_t103 = $(do decs <- [d| data P (a :: k) = MkP |] [DDataD _ _ _ _ _ [DCon tvbs _ _ _ _] _] <- dsDecs decs case tvbs of [DPlainTV k SpecifiedSpec, DKindedTV a SpecifiedSpec (DVarT k')] | nameBase k == "k" , nameBase a == "a" , k == k' -> [| True |] | otherwise -> [| False |]) test_t112 :: [Bool] test_t112 = $(do a <- newName "a" b <- newName "b" let aVar = DVarT a bVar = DVarT b aTvb = DPlainTV a () bTvb = DPlainTV b () fvsABExpected = [aTvb, bTvb] fvsABActual = toposortTyVarsOf [aVar, bVar] fvsBAExpected = [bTvb, aTvb] fvsBAActual = toposortTyVarsOf [bVar, aVar] eqAB = fvsABExpected `eqTH` fvsABActual eqBA = fvsBAExpected `eqTH` fvsBAActual [| [eqAB, eqBA] |]) test_t132 :: Bool test_t132 = $(do let c = mkName "C" m = mkName "m" a = mkName "a" fixity = Fixity 5 InfixR -- Defines a class with a fixity declaration inside, i.e., -- -- class C a where -- infixr 5 `m` -- m :: a -- -- We define this by hand to avoid GHC#17608 on pre-9.0 GHCs. decs = sweeten [ DClassD [] c [DPlainTV a ()] [] [ DLetDec (DInfixD fixity m) , DLetDec (DSigD m (DVarT a)) ] ] expected = Just fixity actual <- withLocalDeclarations decs (reifyFixityWithLocals m) expected `eqTHSplice` actual) #if __GLASGOW_HASKELL__ >= 801 -- Test local reification of pattern synonym record selectors. test_t137 :: [Bool] test_t137 = $(do a <- newName "a" b <- newName "b" let aVarT = DVarT a aVarP = DVarP a bVarT = DVarT b bVarP = DVarP b aTvb = DPlainTV a SpecifiedSpec bTvb = DPlainTV b SpecifiedSpec p1 = mkName "P1" unP1a = mkName "unP1a" unP1b = mkName "unP1b" p2 = mkName "P2" unP2a = mkName "unP2a" unP2b = mkName "unP2b" p3 = mkName "P3" unP3a = mkName "unP3a" unP3b = mkName "unP3b" tupleTy = DConT (tupleTypeName 2) `DAppT` aVarT `DAppT` bVarT showCxt = [DConT ''Show `DAppT` aVarT] patSynSigDBodyTy = DArrowT `DAppT` aVarT `DAppT` (DArrowT `DAppT` bVarT `DAppT` tupleTy) -- pattern P{unPa, unPb} = (unPa, unPb) mkPatSynD :: Name -> Name -> Name -> DDec mkPatSynD p unPa unPb = DPatSynD p (RecordPatSyn [unPa, unPb]) DImplBidir (DConP (tupleDataName 2) [] [aVarP, bVarP]) decs :: [Dec] decs = sweeten [ -- pattern P1 :: a -> b -> (a, b) DPatSynSigD p1 patSynSigDBodyTy , mkPatSynD p1 unP1a unP1b -- pattern P2 :: Show a => a -> b -> (a, b) , DPatSynSigD p2 $ DConstrainedT showCxt patSynSigDBodyTy , mkPatSynD p2 unP2a unP2b -- pattern P3 :: forall b a. Show a => a -> b -> (a, b) , DPatSynSigD p3 $ DForallT (DForallInvis [bTvb, aTvb]) $ DConstrainedT showCxt patSynSigDBodyTy , mkPatSynD p3 unP3a unP3b ] -- Pair each pattern synonym record selector name with the type that -- local reification should produce. expecteds :: [(Name, DType)] expecteds = [ (unP1a, DForallT (DForallInvis [aTvb, bTvb]) $ DArrowT `DAppT` tupleTy `DAppT` aVarT) , (unP1b, DForallT (DForallInvis [aTvb, bTvb]) $ DArrowT `DAppT` tupleTy `DAppT` bVarT) -- The reified types below use (DForallInvis []) due to the way -- that ForallT is desugared. -- See Note [Desugaring and sweetening ForallT] in -- Language.Haskell.TH.Desugar.Core. , (unP2a, DForallT (DForallInvis []) $ DConstrainedT showCxt $ DArrowT `DAppT` tupleTy `DAppT` aVarT) , (unP2b, DForallT (DForallInvis []) $ DConstrainedT showCxt $ DArrowT `DAppT` tupleTy `DAppT` bVarT) , (unP3a, DForallT (DForallInvis [bTvb, aTvb]) $ DConstrainedT showCxt $ DArrowT `DAppT` tupleTy `DAppT` aVarT) , (unP3b, DForallT (DForallInvis [bTvb, aTvb]) $ DConstrainedT showCxt $ DArrowT `DAppT` tupleTy `DAppT` bVarT) ] expected_eq_actual :: (Name, DType) -> DsM Q Bool expected_eq_actual (sel_name, expected_ty) = do let expected_info = Just $ DVarI sel_name expected_ty Nothing actual_info <- dsReify sel_name pure $ expected_info `eqTH` actual_info bs <- withLocalDeclarations decs $ mapM expected_eq_actual expecteds Syn.lift bs) #endif test_t154 :: Bool test_t154 = $(do decs <- [d| data T where (:$$:) :: Int -> Int -> T |] ddecs <- dsDecs decs let mb_is_infix = case ddecs of [DDataD _ _ _ _ _ [DCon _ _ _ (DNormalC is_infix _) _] _] -> Just is_infix _ -> Nothing mb_is_infix `eqTHSplice` Just False) -- Regression test for #159 which ensures that non-exhaustive functions throw -- a runtime error before forcing their arguments. test_t159 :: Expectation test_t159 = do -- NB: Catch ErrorCall here, not PatternMatchFail. This is because we desugar -- non-exhaustive patterns into a custom `error` expression. let testOne f = f (let x = x in x) `shouldThrow` \(_ :: ErrorCall) -> True testOne t159A testOne t159B #if __GLASGOW_HASKELL__ >= 906 test_t170 :: [Bool] test_t170 = $(do decs <- [d| type data TyData = MkTyData |] let test_TypeData_NameSpace nameStr = withLocalDeclarations decs $ do Just name <- lookupTypeNameWithLocals nameStr mbNS <- reifyNameSpace name mbNS `eqTHSplice` Just Syn.TcClsName let b1 = test_TypeData_NameSpace "TyData" let b2 = test_TypeData_NameSpace "MkTyData" [| [$b1, $b2] |]) #endif test_t171 :: Bool test_t171 = $(do a <- newName "a" b <- newName "b" c <- newName "c" x <- newName "x" y <- newName "y" let aVarT = DVarT a bVarT = DVarT b cVarT = DVarT c aTvb = DPlainTV a SpecifiedSpec bTvb = DPlainTV b SpecifiedSpec cTvb = DPlainTV c SpecifiedSpec t = mkName "T" mkT = mkName "mkT" getT1 = mkName "getT1" getT2 = mkName "getT2" dec = -- data T x y where -- MkT :: forall b a c. { getT1 :: b, getT2 :: c } -> T a b DDataD Data [] t [DPlainTV x (), DPlainTV y ()] Nothing [ DCon [bTvb, aTvb, cTvb] [] mkT (DRecC [ ( getT1 , Bang NoSourceUnpackedness NoSourceStrictness , bVarT ) , ( getT2 , Bang NoSourceUnpackedness NoSourceStrictness , cVarT ) ]) res_ty ] [] res_ty = DConT t `DAppT` aVarT `DAppT` bVarT expected_ty = DForallT (DForallInvis [bTvb, aTvb]) $ DArrowT `DAppT` res_ty `DAppT` bVarT withLocalDeclarations (sweeten [dec]) $ do Just (DVarI _ actual_ty _) <- dsReify getT1 expected_ty `eqTHSplice` actual_ty) -- Unit tests for functions that compute free variables (e.g., fvDType) test_fvs :: [Bool] test_fvs = $(do a <- newName "a" let -- (Show a => Show (Maybe a)) => String ty1 = DConstrainedT [DConstrainedT [DConT ''Show `DAppT` DVarT a] (DConT ''Show `DAppT` (DConT ''Maybe `DAppT` DVarT a))] (DConT ''String) b1 = fvDType ty1 `eqTH` OS.singleton a -- #93 [| [b1] |]) test_kind_substitution :: [Bool] test_kind_substitution = $(do a <- newName "a" b <- newName "b" c <- newName "c" k <- newName "k" let subst = M.singleton a (DVarT b) -- (Nothing :: Maybe a) ty1 = DSigT (DConT 'Nothing) (DConT ''Maybe `DAppT` DVarT a) -- forall (c :: a). c ty2 = DForallT (DForallInvis [DKindedTV c SpecifiedSpec (DVarT a)]) (DVarT c) -- forall a (c :: a). c ty3 = DForallT (DForallInvis [ DPlainTV a SpecifiedSpec , DKindedTV c SpecifiedSpec (DVarT a) ]) (DVarT c) -- forall (a :: k) k (b :: k). Proxy b -> Proxy a ty4 = DForallT (DForallInvis [ DKindedTV a SpecifiedSpec (DVarT k) , DPlainTV k SpecifiedSpec , DKindedTV b SpecifiedSpec (DVarT k) ]) (DArrowT `DAppT` (DConT ''Proxy `DAppT` DVarT b) `DAppT` (DConT ''Proxy `DAppT` DVarT a)) substTy1 <- substTy subst ty1 substTy2 <- substTy subst ty2 substTy3 <- substTy subst ty3 substTy4 <- substTy subst ty4 let freeVars1 = fvDType substTy1 freeVars2 = fvDType substTy2 freeVars3 = fvDType substTy3 freeVars4 = fvDType substTy4 b1 = freeVars1 `eqTH` OS.singleton b b2 = freeVars2 `eqTH` OS.singleton b b3 = freeVars3 `eqTH` OS.empty b4 = freeVars4 `eqTH` OS.singleton k [| [b1, b2, b3, b4] |]) test_lookup_value_type_names :: [Bool] test_lookup_value_type_names = $(do let nameStr = "***" valName <- newName nameStr typeName <- newName nameStr let tyDec = DTySynD typeName [] (DConT ''Bool) decs = decsToTH [ DLetDec (DSigD valName (DConT ''Bool)) , DLetDec (DValD (DVarP valName) (DConE 'False)) , tyDec ] lookupReify lookup_fun = withLocalDeclarations decs $ do Just n <- lookup_fun nameStr Just i <- dsReify n return i reifiedVal <- lookupReify lookupValueNameWithLocals reifiedType <- lookupReify lookupTypeNameWithLocals let b1 = reifiedVal `eqTH` DVarI valName (DConT ''Bool) Nothing let b2 = reifiedType `eqTH` DTyConI tyDec Nothing [| [b1, b2] |]) local_reifications :: [String] local_reifications = $(do decs <- reifyDecs m_infos <- withLocalDeclarations decs $ mapM reifyWithLocals_maybe reifyDecsNames let m_infos' = assumeStarT m_infos ListE <$> mapM (Syn.lift . show) (unqualify m_infos')) type T123G = Either () () type T123F = Either T123G T123G type T123E = Either T123F T123F type T123D = Either T123E T123E type T123C = Either T123D T123D type T123B = Either T123C T123C type T123A = Either T123B T123B $reifyDecs $(return []) -- somehow, this is necessary to get the staging correct for the -- reifications below. Weird. normal_reifications :: [String] normal_reifications = $(do infos <- mapM reify reifyDecsNames ListE <$> mapM (Syn.lift . show . Just) (dropTrailing0s $ delinearize $ unqualify infos)) zipWith3M :: Monad m => (a -> b -> c -> m d) -> [a] -> [b] -> [c] -> m [d] zipWith3M f (a:as) (b:bs) (c:cs) = liftM2 (:) (f a b c) (zipWith3M f as bs cs) zipWith3M _ _ _ _ = return [] simplCase :: [Bool] simplCase = $( do exps <- sequence simplCaseTests dexps <- mapM dsExp exps sexps <- mapM scExp dexps bools <- zipWithM (\e1 e2 -> [| $(return e1) == $(return e2) |]) exps (map sweeten sexps) return $ ListE bools ) test_roundtrip :: [Bool] test_roundtrip = $( do exprs <- sequence test_exprs ds_exprs1 <- mapM dsExp exprs let th_exprs1 = map expToTH ds_exprs1 ds_exprs2 <- mapM dsExp th_exprs1 let th_exprs2 = map expToTH ds_exprs2 ds_exprs3 <- mapM dsExp th_exprs2 let bools = zipWith eqTH ds_exprs2 ds_exprs3 Syn.lift bools ) test_matchTy :: [Bool] test_matchTy = [ matchTy NoIgnore (DVarT a) (DConT ''Bool) == Just (M.singleton a (DConT ''Bool)) , matchTy NoIgnore (DVarT a) (DVarT a) == Just (M.singleton a (DVarT a)) , matchTy NoIgnore (DVarT a) (DVarT b) == Just (M.singleton a (DVarT b)) , matchTy NoIgnore (DConT ''Either `DAppT` DVarT a `DAppT` DVarT b) (DConT ''Either `DAppT` DConT ''Int `DAppT` DConT ''Bool) == Just (M.fromList [(a, DConT ''Int), (b, DConT ''Bool)]) , matchTy NoIgnore (DConT ''Either `DAppT` DVarT a `DAppT` DVarT a) (DConT ''Either `DAppT` DConT ''Int `DAppT` DConT ''Int) == Just (M.singleton a (DConT ''Int)) , matchTy NoIgnore (DConT ''Either `DAppT` DVarT a `DAppT` DVarT a) (DConT ''Either `DAppT` DConT ''Int `DAppT` DConT ''Bool) == Nothing , matchTy NoIgnore (DConT ''Int) (DConT ''Bool) == Nothing , matchTy NoIgnore (DConT ''Int) (DConT ''Int) == Just M.empty , matchTy NoIgnore (DConT ''Int) (DVarT a) == Nothing , matchTy NoIgnore (DVarT a `DSigT` DConT ''Bool) (DConT ''Int) == Nothing , matchTy YesIgnore (DVarT a `DSigT` DConT ''Bool) (DConT ''Int) == Just (M.singleton a (DConT ''Int)) ] where a = mkName "a" b = mkName "b" -- Test that type synonym expansion is efficient test_t123 :: () test_t123 = $(do _ <- expand (DConT ''T123A) [| () |]) main :: IO () main = hspec $ do describe "th-desugar library" $ do it "compiles" $ True it "expands" $ test_expand zipWithM (\num success -> it ("passes dec test " ++ show num) success) dec_test_nums test_dec -- instance test 1 is part of dectest 6. it "passes instance test" $ $(do ty <- [t| Int -> Bool |] [inst1, inst2] <- reifyInstances ''Show [ty] inst1 `eqTHSplice` inst2) it "makes type names" $ test_mkName it "fixes bug 8884" $ test_bug8884 it "flattens DValDs" $ flatten_dvald it "extracts record selectors" $ test_rec_sels it "works with standalone deriving" $ test_standalone_deriving it "works with deriving strategies" $ test_deriving_strategies it "doesn't expand local type families" $ test_local_tyfam_expansion it "doesn't crash on a stuck type family application" $ test_stuck_tyfam_expansion it "expands type synonyms in kinds" $ test_t85 it "toposorts free variables in polytypes" $ test_t92 it "expands type synonyms in type variable binders" $ test_t97 it "reifies GADT record selectors correctly" $ test_t100 zipWithM (\b n -> it ("collects GADT record selectors correctly" ++ show n) b) test_t102 [1..] it "quantifies kind variables in desugared ADT constructors" $ test_t103 it "reifies data type return kinds accurately" $ test_getDataD_kind_sig zipWithM (\b n -> it ("toposorts free variables deterministically " ++ show n) b) test_t112 [1..] it "reifies fixity declarations inside of classes" $ test_t132 #if __GLASGOW_HASKELL__ >= 801 zipWithM (\b n -> it ("reifies local pattern synonym record selectors " ++ show n) b) test_t137 [1..] #endif zipWithM (\b n -> it ("computes free variables correctly " ++ show n) b) test_fvs [1..] it "desugars non-infix GADT constructors with symbolic names correctly" $ test_t154 it "desugars non-exhaustive expressions into code that errors at runtime" $ test_t159 #if __GLASGOW_HASKELL__ >= 906 zipWithM (\b n -> it ("looks up TypeData names in the type namespace correctly " ++ show n) b) test_t170 [1..] #endif it "locally reifies GADT record selector types with explicit foralls correctly" $ test_t171 -- Remove map pprints here after switch to th-orphans zipWithM (\t t' -> it ("can do Type->DType->Type of " ++ t) $ t == t') $(sequence round_trip_types >>= Syn.lift . map pprint) $(sequence round_trip_types >>= mapM (\ t -> withLocalDeclarations [] (dsType t >>= expandType >>= return . typeToTH)) >>= Syn.lift . map pprint) zipWith3M (\a b n -> it ("reifies local definition " ++ show n) $ a == b) local_reifications normal_reifications [1..] zipWithM (\b n -> it ("works on simplCase test " ++ show n) b) simplCase [1..] zipWithM (\b n -> it ("round-trip successfully on case " ++ show n) b) test_roundtrip [1..] zipWithM (\b n -> it ("lookups up local value and type names " ++ show n) b) test_lookup_value_type_names [1..] zipWithM (\b n -> it ("substitutes tyvar binder kinds " ++ show n) b) test_kind_substitution [1..] zipWithM (\b n -> it ("matches types " ++ show n) b) test_matchTy [1..] zipWithM (\b n -> it ("reifies kinds of declarations with CUSKs " ++ show n) b) test_reify_type_cusks [1..] zipWithM (\b n -> it ("reifies kinds of declarations without CUSKs " ++ show n) b) test_reify_type_no_cusks [1..] zipWithM (\b n -> it ("reifies the kinds of declarations with signatures " ++ show n) b) test_reify_kind_sigs [1..] fromHUnitTest tests th-desugar-1.15/Test/Splices.hs0000644000000000000000000006302307346545000014555 0ustar0000000000000000{- Tests for the th-desugar package (c) Richard Eisenberg 2013 rae@cs.brynmawr.edu -} {-# LANGUAGE TemplateHaskell, LambdaCase, MagicHash, UnboxedTuples, MultiWayIf, ParallelListComp, CPP, BangPatterns, ScopedTypeVariables, RankNTypes, TypeFamilies, ImpredicativeTypes, DataKinds, PolyKinds, GADTs, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, StandaloneDeriving, DefaultSignatures, ConstraintKinds, GADTs, ViewPatterns, TupleSections, NoMonomorphismRestriction, TypeOperators, TypeApplications #-} #if __GLASGOW_HASKELL__ >= 801 {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE UnboxedSums #-} #endif #if __GLASGOW_HASKELL__ >= 803 {-# LANGUAGE OverloadedLabels #-} {-# OPTIONS_GHC -Wno-orphans #-} -- IsLabel is an orphan #endif #if __GLASGOW_HASKELL__ >= 805 {-# LANGUAGE DerivingVia #-} {-# LANGUAGE QuantifiedConstraints #-} #endif #if __GLASGOW_HASKELL__ >= 807 {-# LANGUAGE ImplicitParams #-} #endif #if __GLASGOW_HASKELL__ >= 809 {-# LANGUAGE StandaloneKindSignatures #-} #endif #if __GLASGOW_HASKELL__ >= 900 {-# LANGUAGE QualifiedDo #-} #endif #if __GLASGOW_HASKELL__ >= 902 {-# LANGUAGE OverloadedRecordDot #-} #endif #if __GLASGOW_HASKELL__ >= 906 {-# LANGUAGE TypeData #-} #endif {-# OPTIONS_GHC -Wno-missing-signatures -Wno-type-defaults -Wno-name-shadowing #-} module Splices where import qualified Data.List as L import Data.Char import qualified Data.Kind as Kind (Type) import GHC.Exts import GHC.TypeLits import Language.Haskell.TH import Language.Haskell.TH.Datatype.TyVarBndr import Language.Haskell.TH.Desugar import Language.Haskell.TH.Syntax (Quasi) import Data.Generics #if __GLASGOW_HASKELL__ >= 803 import GHC.OverloadedLabels ( IsLabel(..) ) #endif import Prelude as P dsSplice :: Q Exp -> Q Exp dsSplice expq = expq >>= dsExp >>= (return . expToTH) dsDecSplice :: Q [Dec] -> Q [Dec] dsDecSplice decsQ = decsQ >>= dsDecs >>= (return . decsToTH) testDecSplice :: Int -> Q Exp testDecSplice n = do let dsName = mkName $ "DsDec.Dec" ++ show n regName = mkName $ "Dec.Dec" ++ show n infoDs <- reify dsName infoReg <- reify regName rolesDs <- reifyRoles dsName rolesReg <- reifyRoles regName fixityDs <- reifyFixity dsName fixityReg <- reifyFixity regName eqTHSplice (infoDs, rolesDs, fixityDs) (infoReg, rolesReg, fixityReg) unqualify :: Data a => a -> a unqualify = everywhere (mkT (mkName . nameBase)) assumeStarT :: Data a => a -> a assumeStarT = everywhere (mkT assume_spec . mkT assume_unit) where assume_spec :: TyVarBndrSpec -> TyVarBndrSpec #if __GLASGOW_HASKELL__ >= 900 assume_spec (PlainTV n spec) = KindedTV n spec StarT assume_spec (KindedTV n spec k) = KindedTV n spec (assumeStarT k) #else assume_spec = assume_unit #endif assume_unit :: TyVarBndrUnit -> TyVarBndrUnit assume_unit = elimTV (\n -> kindedTV n StarT) (\n k -> kindedTV n (assumeStarT k)) dropTrailing0s :: Data a => a -> a dropTrailing0s = everywhere (mkT (mkName . frob . nameBase)) where frob str | head str == 'r' = str | head str == 'R' = str | otherwise = L.dropWhileEnd isDigit str -- Because th-desugar does not support linear types, we must pretend like -- MulArrowT does not exist for testing purposes. -- See Note [Gracefully handling linear types] in L.H.TH.Desugar.Core. delinearize :: Data a => a -> a delinearize = everywhere (mkT no_mul) where no_mul :: Type -> Type #if __GLASGOW_HASKELL__ >= 900 no_mul (MulArrowT `AppT` _) = ArrowT #endif no_mul t = t eqTH :: (Data a, Show a) => a -> a -> Bool eqTH a b = show (unqualify a) == show (unqualify b) eqTHSplice :: (Quasi q, Data a, Show a) => a -> a -> q Exp eqTHSplice a b = runQ $ if a `eqTH` b then [| True |] else [| False |] test1_sections = [| map ((* 3) . (4 +) . (\x -> x * x)) [10, 11, 12] |] test2_lampats = [| (\(Just x) (Left z) -> x + z) (Just 5) (Left 10) |] test3_lamcase = [| foldr (-) 0 (map (\case { Just x -> x ; Nothing -> (-3) }) [Just 1, Nothing, Just 19, Nothing]) |] test4_tuples = [| (\(a, _) (# b, _ #) -> a + b) (1,2) (# 3, 4 #) |] test5_ifs = [| if (5 > 7) then "foo" else if | Nothing <- Just "bar", True -> "blargh" | otherwise -> "bum" |] test6_ifs2 = [| if | Nothing <- Nothing, False -> 3 | Just _ <- Just "foo" -> 5 |] test7_let = [| let { x :: Double; x = 5; f :: Double -> Double; f x = x + 1 } in f (x * 2) + x |] test8_case = [| case Just False of { Just True -> 1 ; Just _ -> 2 ; Nothing -> 3 } |] test9_do = [| show $ do { foo <- Just "foo" ; let fool = foo ++ "l" ; L.elemIndex 'o' fool ; x <- L.elemIndex 'l' fool ; return (x + 10) } |] test10_comp = [| [ (x, x+1) | x <- [1..10], x `mod` 2 == 0 ] |] test11_parcomp = [| [ (x,y) | x <- [1..10], x `mod` 2 == 0 | y <- [2,5..20] ] |] test12_parcomp2 = [| [ (x,y,z) | x <- [1..10], z <- [3..100], x + z `mod` 2 == 0 | y <- [2,5..20] ] |] test13_sig = [| show (read "[10, 11, 12]" :: [Int]) |] data Record = MkRecord1 { field1 :: Bool, field2 :: Int } | MkRecord2 { field2 :: Int, field3 :: Char } test14_record = [| let r1 = [MkRecord1 { field2 = 5, field1 = False }, MkRecord2 { field2 = 6, field3 = 'q' }] r2 = map (\r -> r { field2 = 18 }) r1 r3 = (head r2) { field1 = True } in map (\case MkRecord1 { field2 = some_int, field1 = some_bool } -> show some_int ++ show some_bool MkRecord2 { field2 = some_int, field3 = some_char } -> show some_int ++ show some_char) (r3 : r2) |] test15_litp = [| map (\case { 5 -> True ; _ -> False }) [5,6] |] test16_tupp = [| map (\(x,y,z) -> x + y + z) [(1,2,3),(4,5,6)] |] data InfixType = Int :+: Bool deriving (Show, Eq) test17_infixp = [| map (\(x :+: y) -> if y then x + 1 else x - 1) [5 :+: True, 10 :+: False] |] test18_tildep = [| map (\ ~() -> Nothing :: Maybe Int) [undefined, ()] |] test19_bangp = [| map (\ !() -> 5) [()] |] test20_asp = [| map (\ a@(b :+: c) -> (if c then b + 1 else b - 1, a)) [5 :+: True, 10 :+: False] |] test21_wildp = [| zipWith (\_ _ -> 10) [1,2,3] ['a','b','c'] |] test22_listp = [| map (\ [a,b,c] -> a + b + c) [[1,2,3],[4,5,6]] |] #if __GLASGOW_HASKELL__ >= 801 test23_sigp = [| map (\ (a :: Int) -> a + a) [5, 10] |] #endif test24_fun = [| let f (Just x) = x f Nothing = Nothing in f (Just (Just 10)) |] test25_fun2 = [| let f (Just x) | x > 0 = x | x < 0 = x + 10 f Nothing = 0 f _ = 18 in map f [Just (-5), Just 5, Just 10, Nothing, Just 0] |] test26_forall = [| let f :: Num a => a -> a f x = x + 10 in (f 5, f 3.0) |] test27_kisig = [| let f :: Proxy (a :: Bool) -> () f _ = () in (f (Proxy :: Proxy 'False), f (Proxy :: Proxy 'True)) |] test28_tupt = [| let f :: (a,b) -> a f (a,_) = a in map f [(1,'a'),(2,'b')] |] test29_listt = [| let f :: [[a]] -> a f = head . head in map f [ [[1]], [[2]] ] |] test30_promoted = [| let f :: Proxy '() -> Proxy '[Int, Bool] -> () f _ _ = () in f Proxy Proxy |] test31_constraint = [| let f :: Proxy (c :: Kind.Type -> Constraint) -> () f _ = () in [f (Proxy :: Proxy Eq), f (Proxy :: Proxy Show)] |] test32_tylit = [| let f :: Proxy (a :: Symbol) -> Proxy (b :: Nat) -> () f _ _ = () in f (Proxy :: Proxy "Hi there!") (Proxy :: Proxy 10) |] test33_tvbs = [| let f :: forall a (b :: Kind.Type -> Kind.Type). Monad b => a -> b a f = return in [f 1, f 2] :: [Maybe Int] |] test34_let_as = [| let a@(x, y) = (5, 6) in show x ++ show y ++ show a |] type Pair a = (a, a) test35_expand = [| let f :: Pair a -> a f = fst in f |] type Constant a b = b test36_expand = [| let f :: Constant Int (,) Bool Char -> Char f = snd in f |] test40_wildcards = [| let f :: (Show a, _) => a -> a -> _ f x y = if x == y then show x else "bad" in f True False :: String |] #if __GLASGOW_HASKELL__ >= 801 test41_typeapps = [| let f :: forall a. (a -> Bool) -> Bool f g = g (undefined @_ @a) in f (const True) |] test42_scoped_tvs = [| let f :: (Read a, Show a) => a -> String -> String f (_ :: b) (x :: String) = show (read x :: b) in f True "True" |] test43_ubx_sums = [| let f :: (# Bool | String #) -> Bool f (# b | #) = not b f (# | c #) = c == "c" in f (# | "a" #) |] #endif test44_let_pragma = [| let x :: Int x = 1 {-# INLINE x #-} in x |] test45_empty_record_con = [| let j :: Maybe Int j = Just{} in case j of Nothing -> j Just{} -> j |] #if __GLASGOW_HASKELL__ >= 803 data Label (l :: Symbol) = Get class Has a l b | a l -> b where from :: a -> Label l -> b data Point = Point Int Int deriving Show instance Has Point "x" Int where from (Point x _) _ = x instance Has Point "y" Int where from (Point _ y) _ = y instance Has a l b => IsLabel l (a -> b) where fromLabel x = from x (Get :: Label l) test46_overloaded_label = [| let p = Point 3 4 in #x p - #y p |] #endif test47_do_partial_match = [| do { Just () <- [Nothing]; return () } |] #if __GLASGOW_HASKELL__ >= 805 test48_quantified_constraints = [| let f :: forall f a. (forall x. Eq x => Eq (f x), Eq a) => f a -> f a -> Bool f = (==) in f (Proxy @Int) (Proxy @Int) |] #endif #if __GLASGOW_HASKELL__ >= 807 test49_implicit_params = [| let f :: (?x :: Int, ?y :: Int) => (Int, Int) f = let ?x = ?y ?y = ?x in (?x, ?y) in (let ?x = 42 ?y = 27 in f) |] test50_vka = [| let hrefl :: (:~~:) @Bool @Bool 'True 'True hrefl = HRefl in hrefl |] #endif #if __GLASGOW_HASKELL__ >= 809 test51_tuple_sections = [| let f1 :: String -> Char -> (String, Int, Char) f1 = (,5,) f2 :: String -> Char -> (# String, Int, Char #) f2 = (#,5,#) in case (#,#) (f1 "a" 'a') (f2 "b" 'b') of (#,#) ((,,) _ a _) ((#,,#) _ b _) -> a + b |] #endif #if __GLASGOW_HASKELL__ >= 900 test52_qual_do = [| P.do x <- [1, 2] y@1 <- [x] [1, 2] P.return y |] #endif #if __GLASGOW_HASKELL__ >= 901 test53_vta_in_con_pats = [| let f :: Maybe Int -> Int f (Just @Int x) = x f (Nothing @Int) = 42 in f (Just @Int 27) |] #endif #if __GLASGOW_HASKELL__ >= 902 data ORD1 = MkORD1 { unORD1 :: Int } data ORD2 = MkORD2 { unORD2 :: ORD1 } test54_overloaded_record_dot = [| let ord1 :: ORD1 ord1 = MkORD1 1 ord2 :: ORD2 ord2 = MkORD2 ord1 in (ord2.unORD2.unORD1, (.unORD2.unORD1) ord2) |] #endif #if __GLASGOW_HASKELL__ >= 903 test55_opaque_pragma = [| let f :: String -> String f x = x {-# OPAQUE f #-} in f "Hello, World!" |] test56_lambda_cases = [| (\cases (Just x) (Just y) -> x ++ y _ _ -> "") (Just "Hello") (Just "World") |] #endif type family TFExpand x type instance TFExpand Int = Bool type instance TFExpand (Maybe a) = [a] test_expand3 = [| let f :: TFExpand Int -> () f True = () in f |] test_expand4 = [| let f :: TFExpand (Maybe Bool) -> () f [True, False] = () in f |] type family ClosedTF a where ClosedTF Int = Bool ClosedTF x = Char test_expand5 = [| let f :: ClosedTF Int -> () f True = () in f |] test_expand6 = [| let f :: ClosedTF Double -> () f 'x' = () in f |] #if __GLASGOW_HASKELL__ >= 809 type PolyTF :: forall k. k -> Kind.Type #endif type family PolyTF (x :: k) :: Kind.Type where PolyTF (x :: Kind.Type) = Bool test_expand7 = [| let f :: PolyTF Int -> () f True = () in f |] test_expand8 = [| let f :: PolyTF IO -> () f True = () in f |] test_expand9 = [| let f :: TFExpand (Maybe (IO a)) -> IO () f actions = sequence_ actions in f |] type family TFExpandClosed a where TFExpandClosed (Maybe a) = [a] test_expand10 = [| let f :: TFExpandClosed (Maybe (IO a)) -> IO () f actions = sequence_ actions in f |] test37_pred = [| let f :: (Read a, (Show a, Num a)) => a -> a f x = read (show x) + x in (f 3, f 4.5) |] test38_pred2 = [| let f :: a b => Proxy a -> b -> b f _ x = x in (f (Proxy :: Proxy Show) False, f (Proxy :: Proxy Num) (3 :: Int)) |] test39_eq = [| let f :: (a ~ b) => a -> b f x = x in (f ()) |] dec_test_nums = [1..11] :: [Int] dectest1 = [d| data Dec1 where Foo :: Dec1 Bar :: Int -> Dec1 |] dectest2 = [d| data Dec2 a where MkDec2 :: forall a b. (Show b, Eq a) => a -> b -> Bool -> Dec2 a |] dectest3 = [d| data Dec3 a where MkDec3 :: forall a b. { foo :: a, bar :: b } -> Dec3 a type role Dec3 nominal |] dectest4 = [d| newtype Dec4 a where MkDec4 :: (a, Int) -> Dec4 a |] dectest5 = [d| type Dec5 a b = (a b, Maybe b) |] dectest6 = [d| class (Monad m1, Monad m2) => Dec6 (m1 :: Kind.Type -> Kind.Type) m2 | m1 -> m2 where lift :: forall a. m1 a -> m2 a type M2 m1 :: Kind.Type -> Kind.Type |] dectest7 = [d| type family Dec7 a (b :: Kind.Type) (c :: Bool) :: Kind.Type -> Kind.Type |] dectest8 = [d| type family Dec8 a |] dectest9 = [d| data family Dec9 a (b :: Kind.Type -> Kind.Type) :: Kind.Type -> Kind.Type |] dectest10 = [d| type family Dec10 a :: Kind.Type -> Kind.Type where Dec10 Int = Maybe Dec10 Bool = [] |] data Blarggie a = MkBlarggie Int a dectest11 = [d| class Dec11 a where meth13 :: a -> a -> Bool default meth13 :: Eq a => a -> a -> Bool meth13 = (==) |] standalone_deriving_test = [d| deriving instance Eq a => Eq (Blarggie a) |] #if __GLASGOW_HASKELL__ >= 801 deriv_strat_test = [d| deriving stock instance Ord a => Ord (Blarggie a) |] #endif dectest12 = [d| data Dec12 a where MkGInt :: Dec12 Int MkGOther :: Dec12 b |] dectest13 = [d| data Dec13 :: (Kind.Type -> Constraint) -> Kind.Type where MkDec13 :: c a => a -> Dec13 c |] dectest14 = [d| data InfixADT = Int `InfixADT` Int |] dectest15 = [d| infixl 5 :**:, :&&:, :^^:, `ActuallyPrefix` data InfixGADT a where (:**:) :: Int -> b -> InfixGADT (Maybe b) -- Only this one is infix (:&&:) :: { infixGADT1 :: b, infixGADT2 :: Int } -> InfixGADT [b] ActuallyPrefix :: Char -> Bool -> InfixGADT Double (:^^:) :: Int -> Int -> Int -> InfixGADT Int (:!!:) :: Char -> Char -> InfixGADT Char |] class ExCls a data ExData1 a data ExData2 a -- ds_dectest{16,17} demonstrate instance declarations with outermost foralls, -- a feature which Template Haskell itself does not yet support (see #151). -- For this reason, the closest we can get to this in TH is to construct -- equivalent Decs, dectest{16,17}, that drop the outermost foralls. The test -- suite ensures that this process happens automatically during sweetening by -- checking that the sweetened versions of ds_dectest{16,17} equal -- dectest{16,17}. ds_dectest16 = DInstanceD Nothing (Just [DPlainTV (mkName "a") ()]) [] (DConT ''ExCls `DAppT` (DConT ''ExData1 `DAppT` DVarT (mkName "a"))) [] dectest16 :: Q [Dec] dectest16 = return [ InstanceD Nothing [] (ConT ''ExCls `AppT` (ConT ''ExData1 `AppT` VarT (mkName "a"))) [] ] ds_dectest17 = DStandaloneDerivD Nothing (Just [DPlainTV (mkName "a") ()]) [] (DConT ''ExCls `DAppT` (DConT ''ExData2 `DAppT` DVarT (mkName "a"))) dectest17 :: Q [Dec] dectest17 = return [ StandaloneDerivD #if __GLASGOW_HASKELL__ >= 802 Nothing #endif [] (ConT ''ExCls `AppT` (ConT ''ExData2 `AppT` VarT (mkName "a"))) ] #if __GLASGOW_HASKELL__ >= 809 dectest18 = [d| data Dec18 :: forall k -> k -> Kind.Type where MkDec18 :: forall k (a :: k). Dec18 k a |] #endif instance_test = [d| instance (Show a, Show b) => Show (a -> b) where show _ = "function" |] class Dec6 a b where { lift :: a x -> b x; type M2 a } imp_inst_test1 = [d| instance Dec6 Maybe (Either ()) where lift Nothing = Left () lift (Just x) = Right x type M2 Maybe = Either () |] data family Dec9 a (b :: Kind.Type -> Kind.Type) :: Kind.Type -> Kind.Type imp_inst_test2 = [d| data instance Dec9 Int Maybe a where MkIMB :: [a] -> Dec9 Int Maybe a MkIMB2 :: forall a b. b a -> Dec9 Int Maybe a |] imp_inst_test3 = [d| newtype instance Dec9 Bool m x where MkBMX :: m x -> Dec9 Bool m x |] type family Dec8 a imp_inst_test4 = [d| type instance Dec8 Int = Bool |] -- used for bug8884 test type family Poly (a :: k) :: Kind.Type type instance Poly x = Int flatten_dvald_test = [| let (a,b,c) = ("foo", 4, False) in show a ++ show b ++ show c |] rec_sel_test = [d| data RecordSel a = Show a => MkRecord { recsel1 :: (Int, a) , recsel2 :: (forall b. b -> a) , recsel3 :: Bool } | MkRecord2 { recsel3 :: Bool , recsel4 :: (a, a) } |] rec_sel_test_num_sels = 4 :: Int testRecSelTypes :: Int -> Q Exp testRecSelTypes n = do VarI _ ty1 _ <- reify (mkName ("DsDec.recsel" ++ show n)) VarI _ ty2 _ <- reify (mkName ("Dec.recsel" ++ show n)) let ty1' = return $ unqualify ty1 ty2' = return $ unqualify ty2 [| let x :: $ty1' x _ = undefined y :: $ty2' y _ = undefined in $(return $ VarE $ mkName "hasSameType") (\d -> x d) (\d -> y d) |] -- used for expand reifyDecs :: Q [Dec] reifyDecs = [d| -- NB: Use a forall here! If you don't, when you splice r1 in and then reify -- it, GHC will add an explicit forall behind the scenes, which will cause an -- incongruity with the locally reified declaration (which would lack an -- explicit forall). r1 :: forall a. a -> a r1 x = x class R2 a b where r3 :: a -> b -> c -> a type R4 b a :: Kind.Type -- Only define this on GHC 8.0 or later, since TH had trouble quoting -- associated type family defaults before then. type R4 b a = Either a b data R5 a :: Kind.Type data R6 a = R7 { r8 :: a -> a, r9 :: Bool } instance R2 (R6 a) a where r3 = undefined type R4 a (R6 a) = a data R5 (R6 a) = forall b. Show b => R10 { r11 :: a, naughty :: b } type family R12 a b :: Kind.Type data family R13 a :: Kind.Type data instance R13 Int = R14 { r15 :: Bool } r16, r17 :: Int (r16, r17) = (5, 6) newtype R18 = R19 Bool type R20 = Bool type family R21 (a :: k) (b :: k) :: k where #if __GLASGOW_HASKELL__ >= 801 #if __GLASGOW_HASKELL__ >= 807 forall k (a :: k) (b :: k). #endif R21 (a :: k) (b :: k) = b #else -- Due to GHC Trac #12646, R21 will get reified without kind signatures on -- a and b on older GHCs, so we must reflect that here. R21 a b = b #endif class XXX a where r22 :: a -> a r22 = id -- test #32 data R23 a = MkR23 { getR23 :: a } r23Test :: R23 a -> a r23Test (MkR23 { getR23 = x }) = x #if __GLASGOW_HASKELL__ >= 801 pattern Point :: Int -> Int -> (Int, Int) pattern Point{x, y} = (x, y) data T a where MkT :: Eq b => a -> b -> T a foo :: Show a => a -> Bool foo x = show x == "foo" pattern P :: Show a => Eq b => b -> T a pattern P x <- MkT (foo -> True) x pattern HeadC :: a -> [a] pattern HeadC x <- x:_ where HeadC x = [x] class LL f where llMeth :: f a -> () instance LL [] where llMeth _ = () pattern LLMeth :: LL f => f a pattern LLMeth <- (llMeth -> ()) {-# COMPLETE LLMeth :: [] #-} llEx :: [a] -> Int llEx LLMeth = 5 #endif #if __GLASGOW_HASKELL__ >= 805 newtype Id a = MkId a deriving stock Eq newtype R24 a = MkR24 [a] deriving Eq via (Id [a]) #endif class R25 (f :: k -> Kind.Type) where r26 :: forall (a :: k). f a data R27 (a :: k) = R28 { r29 :: Proxy a } class R30 a where r31 :: a -> b -> a #if __GLASGOW_HASKELL__ >= 809 type R32 :: forall k -> k -> Kind.Type type family R32 :: forall k -> k -> Kind.Type where #endif data R33 a where R34 :: { r35 :: Int } -> R33 Int #if __GLASGOW_HASKELL__ >= 906 type data R36 a = R37 a type data R38 a where R39 :: forall a. a -> R38 a #endif |] reifyDecsNames :: [Name] reifyDecsNames = map mkName [ "r1" , "R4", "R5", "R6", "R7", "r8", "r9", "R10", "r11" , "R12", "R13", "R14", "r15", "r16", "r17", "R18", "R19", "R20" , "R21" , "r22" , "R25", "r26", "R28", "r29" , "R30", "r31" #if __GLASGOW_HASKELL__ >= 809 , "R32" #endif , "R33", "R34", "r35" #if __GLASGOW_HASKELL__ >= 906 , "R36", "R37", "R38", "R39" #endif ] simplCaseTests :: [Q Exp] simplCaseTests = [ [| map (\a -> case a :: [Int] of (_:_:_:_) -> (5 :: Int) _ -> 6) [[], [1], [1,2,3]] |] , [| let foo [] = True foo _ = False in (foo [], foo "hi") |] #if __GLASGOW_HASKELL__ >= 801 , [| let foo ([] :: String) = True foo (_ :: String) = False in foo "hello" |] #endif ] -- These foralls are needed because of bug trac9262, fixed in ghc-7.10. round_trip_types :: [TypeQ] round_trip_types = [ [t|forall a. a ~ Int => a|] , [t|forall a. [a]|] , [t|forall a b. (a,b)|] ] test_exprs :: [Q Exp] test_exprs = [ test1_sections , test2_lampats , test3_lamcase -- see above , test4_tuples , test5_ifs , test6_ifs2 , test7_let , test8_case , test9_do , test10_comp , test11_parcomp , test12_parcomp2 , test13_sig , test14_record , test15_litp , test16_tupp , test17_infixp , test18_tildep , test19_bangp , test20_asp , test21_wildp , test22_listp #if __GLASGOW_HASKELL__ >= 801 , test23_sigp #endif , test24_fun , test25_fun2 , test26_forall , test27_kisig , test28_tupt , test29_listt , test30_promoted , test31_constraint , test32_tylit , test33_tvbs , test34_let_as , test37_pred , test38_pred2 , test39_eq #if __GLASGOW_HASKELL__ >= 801 , test41_typeapps , test42_scoped_tvs , test43_ubx_sums #endif , test44_let_pragma , test45_empty_record_con #if __GLASGOW_HASKELL__ >= 803 , test46_overloaded_label #endif , test47_do_partial_match #if __GLASGOW_HASKELL__ >= 805 , test48_quantified_constraints #endif #if __GLASGOW_HASKELL__ >= 807 , test49_implicit_params , test50_vka #endif #if __GLASGOW_HASKELL__ >= 809 , test51_tuple_sections #endif #if __GLASGOW_HASKELL__ >= 900 , test52_qual_do #endif #if __GLASGOW_HASKELL__ >= 901 , test53_vta_in_con_pats #endif #if __GLASGOW_HASKELL__ >= 902 , test54_overloaded_record_dot #endif #if __GLASGOW_HASKELL__ >= 903 , test55_opaque_pragma , test56_lambda_cases #endif ] th-desugar-1.15/Test/T158Exp.hs0000644000000000000000000000103707346545000014266 0ustar0000000000000000{-# 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) th-desugar-1.15/Test/T159Decs.hs0000644000000000000000000000142107346545000014406 0ustar0000000000000000{-# OPTIONS_GHC -Wno-incomplete-patterns #-} {-# OPTIONS_GHC -Wno-unused-matches #-} -- | Defines two non-exhaustive functions that roundtrip through desugaring -- and sweetening. Both of these functions should desugar to definitions that -- throw a runtime exception before forcing their argument. -- -- Because these functions are non-exhaustive (and therefore emit warnings), we -- put them in their own module so that we can disable the appropriate warnings -- without needing to disable the warnings globally. module T159Decs ( t159A, t159B ) where import Splices ( dsDecSplice ) $(dsDecSplice [d| t159A, t159B :: () -> IO () t159A x | False = return () t159B x = case x of y | False -> return () |]) th-desugar-1.15/th-desugar.cabal0000644000000000000000000000723407346545000014731 0ustar0000000000000000name: th-desugar version: 1.15 cabal-version: >= 1.10 synopsis: Functions to desugar Template Haskell homepage: https://github.com/goldfirere/th-desugar category: Template Haskell author: Richard Eisenberg maintainer: Ryan Scott bug-reports: https://github.com/goldfirere/th-desugar/issues stability: experimental extra-source-files: README.md, CHANGES.md license: BSD3 license-file: LICENSE build-type: Simple tested-with: GHC == 8.0.2 , GHC == 8.2.2 , GHC == 8.4.4 , GHC == 8.6.5 , GHC == 8.8.4 , GHC == 8.10.7 , GHC == 9.0.2 , GHC == 9.2.6 , GHC == 9.4.4 , GHC == 9.6.1 description: This package provides the Language.Haskell.TH.Desugar module, which desugars Template Haskell's rich encoding of Haskell syntax into a simpler encoding. This desugaring discards surface syntax information (such as the use of infix operators) but retains the original meaning of the TH code. The intended use of this package is as a preprocessor for more advanced code manipulation tools. Note that the input to any of the ds... functions should be produced from a TH quote, using the syntax [| ... |]. If the input to these functions is a hand-coded TH syntax tree, the results may be unpredictable. In particular, it is likely that promoted datatypes will not work as expected. source-repository this type: git location: https://github.com/goldfirere/th-desugar.git tag: v1.10 source-repository head type: git location: https://github.com/goldfirere/th-desugar.git branch: master library build-depends: base >= 4.9 && < 5, ghc-prim, template-haskell >= 2.11 && < 2.21, containers >= 0.5, mtl >= 2.1 && < 2.4, ordered-containers >= 0.2.2, syb >= 0.4, th-abstraction >= 0.5 && < 0.6, th-orphans >= 0.13.7, transformers-compat >= 0.6.3 default-extensions: TemplateHaskell exposed-modules: Language.Haskell.TH.Desugar Language.Haskell.TH.Desugar.Expand Language.Haskell.TH.Desugar.Lift Language.Haskell.TH.Desugar.OMap Language.Haskell.TH.Desugar.OMap.Strict Language.Haskell.TH.Desugar.OSet Language.Haskell.TH.Desugar.Subst Language.Haskell.TH.Desugar.Sweeten other-modules: Language.Haskell.TH.Desugar.AST Language.Haskell.TH.Desugar.Core Language.Haskell.TH.Desugar.FV Language.Haskell.TH.Desugar.Match Language.Haskell.TH.Desugar.Reify Language.Haskell.TH.Desugar.Util default-language: Haskell2010 ghc-options: -Wall test-suite spec type: exitcode-stdio-1.0 ghc-options: -Wall default-language: Haskell2010 default-extensions: TemplateHaskell hs-source-dirs: Test main-is: Run.hs other-modules: Dec DsDec ReifyTypeCUSKs ReifyTypeSigs Splices T158Exp T159Decs build-depends: base >= 4 && < 5, template-haskell, containers >= 0.5, mtl >= 2.1, syb >= 0.4, HUnit >= 1.2, hspec >= 1.3, th-abstraction, th-desugar, th-orphans >= 0.13.9