th-desugar-1.10/0000755000000000000000000000000007346545000011667 5ustar0000000000000000th-desugar-1.10/CHANGES.md0000755000000000000000000003536307346545000013276 0ustar0000000000000000`th-desugar` release notes ========================== 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.10/LICENSE0000644000000000000000000000270507346545000012700 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.10/Language/Haskell/TH/0000755000000000000000000000000007346545000015310 5ustar0000000000000000th-desugar-1.10/Language/Haskell/TH/Desugar.hs0000644000000000000000000003652207346545000017246 0ustar0000000000000000{- Language/Haskell/TH/Desugar.hs (c) Richard Eisenberg 2013 rae@cs.brynmawr.edu -} {-# LANGUAGE CPP, MultiParamTypeClasses, FunctionalDependencies, TypeSynonymInstances, FlexibleInstances, LambdaCase #-} ----------------------------------------------------------------------------- -- | -- 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(..), DKind, DCxt, DPred, DTyVarBndr(..), DMatch(..), DClause(..), DDec(..), DDerivClause(..), DDerivStrategy(..), DPatSynDir(..), DPatSynType, Overlap(..), PatSynArgs(..), NewOrData(..), DTypeFamilyHead(..), DFamilyResultSig(..), InjectivityAnn(..), DCon(..), DConFields(..), DDeclaredInfix, DBangType, DVarBangType, Bang(..), SourceUnpackedness(..), SourceStrictness(..), DForeign(..), DPragma(..), DRuleBndr(..), DTySynEqn(..), DInfo(..), DInstanceDec, Role(..), AnnTarget(..), -- * The 'Desugar' class Desugar(..), -- * Main desugaring functions dsExp, dsDecs, dsType, dsInfo, dsPatOverExp, dsPatsOverExp, dsPatX, dsLetDecs, dsTvb, 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, #if __GLASGOW_HASKELL__ > 710 dsTypeFamilyHead, dsFamilyResultSig, #endif #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, -- | The following definitions allow you to register a list of -- @Dec@s to be used in reification queries. withLocalDeclarations, dsReify, reifyWithLocals_maybe, reifyWithLocals, reifyFixityWithLocals, 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, strictToBang, isTypeKindName, typeKindName, #if __GLASGOW_HASKELL__ >= 800 bindIP, #endif unravel, conExistentialTvbs, mkExtraDKindBinders, dTyVarBndrToDType, toposortTyVarsOf, -- ** 'TypeArg' TypeArg(..), applyType, filterTANormals, unfoldType, -- ** 'DTypeArg' DTypeArg(..), applyDType, filterDTANormals, unfoldDType, -- ** Extracting bound names extractBoundNamesStmt, extractBoundNamesDec, extractBoundNamesPat ) where 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 qualified Language.Haskell.TH.Desugar.OSet as OS 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 Data.List 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 `Type` and `Kind` are type synonyms, but they desugar -- to different types. 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 instance Desugar TyVarBndr DTyVarBndr where desugar = dsTvb sweeten = tvbToTH 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 ps -> DConP con (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' attempts to filter out \"naughty\" record selectors -- whose types mention existentially quantified type variables. But see the -- documentation for 'conExistentialTvbs' for limitations to this approach. -- See https://github.com/goldfirere/singletons/issues/180 for an example where -- the latter behavior can bite you. getRecordSelectors :: DsMonad q => DType -- ^ the type of the argument -> [DCon] -> q [DLetDec] getRecordSelectors arg_ty cons = merge_let_decs `fmap` concatMapM get_record_sels cons where get_record_sels con@(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" con_ex_tvbs <- conExistentialTvbs arg_ty con let con_univ_tvbs = deleteFirstsBy ((==) `on` dtvbName) con_tvbs con_ex_tvbs con_ex_tvb_set = OS.fromList $ map dtvbName con_ex_tvbs forall' = DForallT con_univ_tvbs [] num_pats = length fields return $ concat [ [ DSigD name (forall' $ DArrowT `DAppT` con_ret_ty `DAppT` field_ty) , DFunD name [DClause [DConP con_name (mk_field_pats n num_pats varName)] (DVarE varName)] ] | ((name, _strict, field_ty), n) <- zip fields [0..] , OS.null (fvDType field_ty `OS.intersection` con_ex_tvb_set) -- exclude "naughty" selectors ] 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 :: DsMonad q => DKind -> q [DTyVarBndr] mkExtraDKindBinders = expandType >=> mkExtraDKindBinders' -- | Returns all of a constructor's existentially quantified type variable -- binders. -- -- Detecting the presence of existentially quantified type variables in the -- context of Template Haskell is quite involved. Here is an example that -- we will use to explain how this works: -- -- @ -- data family Foo a b -- data instance Foo (Maybe a) b where -- MkFoo :: forall x y z. x -> y -> z -> Foo (Maybe x) [z] -- @ -- -- In @MkFoo@, @x@ is universally quantified, whereas @y@ and @z@ are -- existentially quantified. Note that @MkFoo@ desugars (in Core) to -- something like this: -- -- @ -- data instance Foo (Maybe a) b where -- MkFoo :: forall a b y z. (b ~ [z]). a -> y -> z -> Foo (Maybe a) b -- @ -- -- Here, we can see that @a@ appears in the desugared return type (it is a -- simple alpha-renaming of @x@), so it is universally quantified. On the other -- hand, neither @y@ nor @z@ appear in the desugared return type, so they are -- existentially quantified. -- -- This analysis would not have been possible without knowing what the original -- data declaration's type was (in this case, @Foo (Maybe a) b@), which is why -- we require it as an argument. Our algorithm for detecting existentially -- quantified variables is not too different from what was described above: -- we match the constructor's return type with the original data type, forming -- a substitution, and check which quantified variables are not part of the -- domain of the substitution. -- -- Be warned: this may overestimate which variables are existentially -- quantified when kind variables are involved. For instance, consider this -- example: -- -- @ -- data S k (a :: k) -- data T a where -- MkT :: forall k (a :: k). { foo :: Proxy (a :: k), bar :: S k a } -> T a -- @ -- -- Here, the kind variable @k@ does not appear syntactically in the return type -- @T a@, so 'conExistentialTvbs' would mistakenly flag @k@ as existential. -- -- There are various tricks we could employ to improve this, but ultimately, -- making this behave correctly with respect to @PolyKinds@ 100% of the time -- would amount to performing kind inference in Template Haskell, which is -- quite difficult. For the sake of simplicity, we have decided to stick with -- a dumb-but-predictable syntactic check. conExistentialTvbs :: DsMonad q => DType -- ^ The type of the original data declaration -> DCon -> q [DTyVarBndr] conExistentialTvbs data_ty (DCon tvbs _ _ _ ret_ty) = do data_ty' <- expandType data_ty ret_ty' <- expandType ret_ty case matchTy YesIgnore ret_ty' data_ty' of Nothing -> fail $ showString "Unable to match type " . showsPrec 11 ret_ty' . showString " with " . showsPrec 11 data_ty' $ "" Just gadtSubt -> return [ tvb | tvb <- tvbs , M.notMember (dtvbName tvb) gadtSubt ] th-desugar-1.10/Language/Haskell/TH/Desugar/0000755000000000000000000000000007346545000016702 5ustar0000000000000000th-desugar-1.10/Language/Haskell/TH/Desugar/AST.hs0000644000000000000000000002527107346545000017674 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, DeriveGeneric #-} module Language.Haskell.TH.Desugar.AST where import Data.Data hiding (Fixity) import GHC.Generics hiding (Fixity) import Language.Haskell.TH -- | 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, Typeable, Data, Generic) -- | Corresponds to TH's @Pat@ type. data DPat = DLitP Lit | DVarP Name | DConP Name [DPat] | DTildeP DPat | DBangP DPat | DSigP DPat DType | DWildP deriving (Eq, Show, Typeable, Data, Generic) -- | Corresponds to TH's @Type@ type, used to represent -- types and kinds. data DType = DForallT [DTyVarBndr] DCxt DType | DAppT DType DType | DAppKindT DType DKind | DSigT DType DKind | DVarT Name | DConT Name | DArrowT | DLitT TyLit | DWildCardT deriving (Eq, Show, Typeable, Data, Generic) -- | Kinds are types. Corresponds to TH's @Kind@ type DKind = DType -- | Predicates are types. Corresponds to TH's @Pred@ type DPred = DType -- | Corresponds to TH's @Cxt@ type DCxt = [DPred] -- | Corresponds to TH's @TyVarBndr@ data DTyVarBndr = DPlainTV Name | DKindedTV Name DKind deriving (Eq, Show, Typeable, Data, Generic) -- | Corresponds to TH's @Match@ type. data DMatch = DMatch DPat DExp deriving (Eq, Show, Typeable, Data, Generic) -- | Corresponds to TH's @Clause@ type. data DClause = DClause [DPat] DExp deriving (Eq, Show, Typeable, Data, Generic) -- | Declarations as used in a @let@ statement. data DLetDec = DFunD Name [DClause] | DValD DPat DExp | DSigD Name DType | DInfixD Fixity Name | DPragmaD DPragma deriving (Eq, Show, Typeable, Data, Generic) -- | Is it a @newtype@ or a @data@ type? data NewOrData = Newtype | Data deriving (Eq, Show, Typeable, Data, Generic) -- | Corresponds to TH's @Dec@ type. data DDec = DLetDec DLetDec | DDataD NewOrData DCxt Name [DTyVarBndr] (Maybe DKind) [DCon] [DDerivClause] | DTySynD Name [DTyVarBndr] DType | DClassD DCxt Name [DTyVarBndr] [FunDep] [DDec] | DInstanceD (Maybe Overlap) (Maybe [DTyVarBndr]) DCxt DType [DDec] | DForeignD DForeign | DOpenTypeFamilyD DTypeFamilyHead | DClosedTypeFamilyD DTypeFamilyHead [DTySynEqn] | DDataFamilyD Name [DTyVarBndr] (Maybe DKind) | DDataInstD NewOrData DCxt (Maybe [DTyVarBndr]) DType (Maybe DKind) [DCon] [DDerivClause] | DTySynInstD DTySynEqn | DRoleAnnotD Name [Role] | DStandaloneDerivD (Maybe DDerivStrategy) (Maybe [DTyVarBndr]) DCxt DType | DDefaultSigD Name DType | DPatSynD Name PatSynArgs DPatSynDir DPat | DPatSynSigD Name DPatSynType deriving (Eq, Show, Typeable, Data, Generic) #if __GLASGOW_HASKELL__ < 711 data Overlap = Overlappable | Overlapping | Overlaps | Incoherent deriving (Eq, Ord, Show, Typeable, Data, Generic) #endif -- | Corresponds to TH's '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, Typeable, Data, Generic) -- | Corresponds to TH's 'PatSynType' type type DPatSynType = DType #if __GLASGOW_HASKELL__ < 801 -- | Same as @PatSynArgs@ from TH; defined here for backwards compatibility. data PatSynArgs = PrefixPatSyn [Name] -- ^ @pattern P {x y z} = p@ | InfixPatSyn Name Name -- ^ @pattern {x P y} = p@ | RecordPatSyn [Name] -- ^ @pattern P { {x,y,z} } = p@ deriving (Eq, Show, Typeable, Data, Generic) #endif -- | Corresponds to TH's 'TypeFamilyHead' type data DTypeFamilyHead = DTypeFamilyHead Name [DTyVarBndr] DFamilyResultSig (Maybe InjectivityAnn) deriving (Eq, Show, Typeable, Data, Generic) -- | Corresponds to TH's 'FamilyResultSig' type data DFamilyResultSig = DNoSig | DKindSig DKind | DTyVarSig DTyVarBndr deriving (Eq, Show, Typeable, Data, Generic) #if __GLASGOW_HASKELL__ <= 710 data InjectivityAnn = InjectivityAnn Name [Name] deriving (Eq, Ord, Show, Typeable, Data, Generic) #endif -- | Corresponds to TH's 'Con' type. 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 [DTyVarBndr] DCxt Name DConFields DType -- ^ The GADT result type deriving (Eq, Show, Typeable, Data, Generic) -- | A list of fields either for a standard data constructor or a record -- data constructor. data DConFields = DNormalC DDeclaredInfix [DBangType] | DRecC [DVarBangType] deriving (Eq, Show, Typeable, Data, Generic) -- | 'True' if a constructor is declared infix. For normal ADTs, this means -- that is was written in infix style. For example, both of the constructors -- below are declared infix. -- -- @ -- data Infix = Int `Infix` Int | Int :*: Int -- @ -- -- Whereas neither of these constructors are declared infix: -- -- @ -- data Prefix = Prefix Int Int | (:+:) Int Int -- @ -- -- For GADTs, detecting whether a constructor is declared infix is a bit -- trickier, as one cannot write a GADT constructor "infix-style" like one -- can for normal ADT constructors. GHC considers a GADT constructor to be -- declared infix if it meets the following three criteria: -- -- 1. Its name uses operator syntax (e.g., @(:*:)@). -- 2. It has exactly two fields (without record syntax). -- 3. It has a programmer-specified fixity declaration. -- -- For example, in the following GADT: -- -- @ -- infixl 5 :**:, :&&:, :^^:, `ActuallyPrefix` -- data InfixGADT a where -- (:**:) :: Int -> b -> InfixGADT (Maybe b) -- Only this one is infix -- ActuallyPrefix :: Char -> Bool -> InfixGADT Double -- (:&&:) :: { infixGADT1 :: b, infixGADT2 :: Int } -> InfixGADT [b] -- (:^^:) :: Int -> Int -> Int -> InfixGADT Int -- (:!!:) :: Char -> Char -> InfixGADT Char -- @ -- -- Only the @(:**:)@ constructor is declared infix. The other constructors -- are not declared infix, because: -- -- * @ActuallyPrefix@ does not use operator syntax (criterion 1). -- * @(:&&:)@ uses record syntax (criterion 2). -- * @(:^^:)@ does not have exactly two fields (criterion 2). -- * @(:!!:)@ does not have a programmer-specified fixity declaration (criterion 3). type DDeclaredInfix = Bool -- | Corresponds to TH's @BangType@ type. type DBangType = (Bang, DType) -- | Corresponds to TH's @VarBangType@ type. type DVarBangType = (Name, Bang, DType) #if __GLASGOW_HASKELL__ <= 710 -- | Corresponds to TH's definition data SourceUnpackedness = NoSourceUnpackedness | SourceNoUnpack | SourceUnpack deriving (Eq, Ord, Show, Typeable, Data, Generic) -- | Corresponds to TH's definition data SourceStrictness = NoSourceStrictness | SourceLazy | SourceStrict deriving (Eq, Ord, Show, Typeable, Data, Generic) -- | Corresponds to TH's definition data Bang = Bang SourceUnpackedness SourceStrictness deriving (Eq, Ord, Show, Typeable, Data, Generic) #endif -- | Corresponds to TH's @Foreign@ type. data DForeign = DImportF Callconv Safety String Name DType | DExportF Callconv String Name DType deriving (Eq, Show, Typeable, Data, Generic) -- | Corresponds to TH's @Pragma@ type. data DPragma = DInlineP Name Inline RuleMatch Phases | DSpecialiseP Name DType (Maybe Inline) Phases | DSpecialiseInstP DType | DRuleP String (Maybe [DTyVarBndr]) [DRuleBndr] DExp DExp Phases | DAnnP AnnTarget DExp | DLineP Int String | DCompleteP [Name] (Maybe Name) deriving (Eq, Show, Typeable, Data, Generic) -- | Corresponds to TH's @RuleBndr@ type. data DRuleBndr = DRuleVar Name | DTypedRuleVar Name DType deriving (Eq, Show, Typeable, Data, Generic) -- | Corresponds to TH's @TySynEqn@ type (to store type family equations). data DTySynEqn = DTySynEqn (Maybe [DTyVarBndr]) DType DType deriving (Eq, Show, Typeable, Data, Generic) -- | Corresponds to TH's @Info@ type. data DInfo = DTyConI DDec (Maybe [DInstanceDec]) | DVarI Name DType (Maybe Name) -- ^ The @Maybe Name@ stores the name of the enclosing definition -- (datatype, for a data constructor; class, for a method), -- if any | DTyVarI Name DKind | DPrimTyConI Name Int Bool -- ^ The @Int@ is the arity; the @Bool@ is whether this tycon -- is unlifted. | DPatSynI Name DPatSynType deriving (Eq, Show, Typeable, Data, Generic) type DInstanceDec = DDec -- ^ Guaranteed to be an instance declaration -- | Corresponds to TH's @DerivClause@ type. data DDerivClause = DDerivClause (Maybe DDerivStrategy) DCxt deriving (Eq, Show, Typeable, Data, Generic) -- | Corresponds to TH's @DerivStrategy@ type. data DDerivStrategy = DStockStrategy -- ^ A \"standard\" derived instance | DAnyclassStrategy -- ^ @-XDeriveAnyClass@ | DNewtypeStrategy -- ^ @-XGeneralizedNewtypeDeriving@ | DViaStrategy DType -- ^ @-XDerivingVia@ deriving (Eq, Show, Typeable, Data, Generic) th-desugar-1.10/Language/Haskell/TH/Desugar/Core.hs0000644000000000000000000020261107346545000020130 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 TemplateHaskell, LambdaCase, CPP, ScopedTypeVariables, TupleSections, DeriveDataTypeable, DeriveGeneric #-} module Language.Haskell.TH.Desugar.Core where import Prelude hiding (mapM, foldl, foldr, all, elem, exp, concatMap, and) import Language.Haskell.TH hiding (match, clause, cxt) import Language.Haskell.TH.Syntax hiding (lift) import Language.Haskell.TH.Datatype ( resolveTypeSynonyms ) #if __GLASGOW_HASKELL__ < 709 import Control.Applicative #endif import Control.Monad hiding (forM_, mapM) import qualified Control.Monad.Fail as Fail import Control.Monad.Zip import Control.Monad.Writer hiding (forM_, mapM) import Data.Data (Data, Typeable) 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 (mapMaybe) import qualified Data.Set as S import Data.Set (Set) import Data.Traversable #if __GLASGOW_HASKELL__ > 710 import Data.Maybe (isJust) #endif #if __GLASGOW_HASKELL__ >= 800 import qualified Control.Monad.Fail as MonadFail #endif #if __GLASGOW_HASKELL__ >= 803 import GHC.OverloadedLabels ( fromLabel ) #endif #if __GLASGOW_HASKELL__ >= 807 import GHC.Classes (IP(..)) #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) = dsLam pats =<< dsExp exp dsExp (LamCaseE matches) = do x <- newUniqueName "x" matches' <- dsMatches x matches return $ DLamE [x] (DCaseE (DVarE x) matches') dsExp (TupE exps) = dsTup tupleDataName exps dsExp (UnboxedTupE exps) = dsTup unboxedTupleDataName exps dsExp (CondE e1 e2 e3) = dsExp (CaseE e1 [ Match (ConP 'True []) (NormalB e2) [] , Match (ConP 'False []) (NormalB e3) [] ]) dsExp (MultiIfE guarded_exps) = let failure = DAppE (DVarE 'error) (DLitE (StringL "Non-exhaustive guards in multi-way if")) in dsGuards guarded_exps failure dsExp (LetE decs exp) = 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' dsExp (DoE stmts) = dsDoStmts stmts dsExp (CompE stmts) = dsComp stmts dsExp (ArithSeqE (FromR exp)) = DAppE (DVarE 'enumFrom) <$> dsExp exp dsExp (ArithSeqE (FromThenR exp1 exp2)) = DAppE <$> (DAppE (DVarE 'enumFromThen) <$> dsExp exp1) <*> dsExp exp2 dsExp (ArithSeqE (FromToR exp1 exp2)) = DAppE <$> (DAppE (DVarE 'enumFromTo) <$> dsExp exp1) <*> dsExp exp2 dsExp (ArithSeqE (FromThenToR e1 e2 e3)) = DAppE <$> (DAppE <$> (DAppE (DVarE 'enumFromThenTo) <$> dsExp e1) <*> dsExp e2) <*> dsExp e3 dsExp (ListE exps) = go exps where go [] = return $ DConE '[] go (h : t) = DAppE <$> (DAppE (DConE '(:)) <$> dsExp h) <*> go t dsExp (SigE exp ty) = DSigE <$> dsExp exp <*> dsType ty dsExp (RecConE con_name field_exps) = do con <- dataConNameToCon con_name reordered <- 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 #if __GLASGOW_HASKELL__ >= 800 GadtC _names fields _ret_ty -> non_record fields RecGadtC _names fields _ret_ty -> reorder_fields fields #endif 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 #if __GLASGOW_HASKELL__ > 710 VarI _name ty _m_dec -> extract_first_arg ty #else VarI _name ty _m_dec _fixity -> extract_first_arg ty #endif _ -> impossible "Record update with an invalid field name." type_name <- extract_type_name applied_type (_, cons) <- getDataD "This seems to be an error in GHC." type_name let filtered_cons = filter_cons_with_names cons (map fst field_exps) exp' <- dsExp exp matches <- mapM con_to_dmatch filtered_cons let all_matches | length filtered_cons == length cons = matches | otherwise = matches ++ [error_match] return $ DCaseE exp' all_matches where extract_first_arg :: DsMonad q => Type -> q Type extract_first_arg (AppT (AppT ArrowT arg) _) = return arg extract_first_arg (ForallT _ _ t) = extract_first_arg t extract_first_arg (SigT t _) = extract_first_arg t extract_first_arg _ = impossible "Record selector not a function." extract_type_name :: DsMonad q => Type -> q Name extract_type_name (AppT t1 _) = extract_type_name t1 extract_type_name (SigT t _) = extract_type_name t extract_type_name (ConT n) = return n extract_type_name _ = impossible "Record selector domain not a datatype." filter_cons_with_names cons field_names = filter has_names cons where 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 #if __GLASGOW_HASKELL__ >= 800 has_names (RecGadtC _con_name args _ret_ty) = args_contain_names args #endif 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 #if __GLASGOW_HASKELL__ >= 800 -- 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 #endif con_to_dmatch (ForallC _ _ c) = con_to_dmatch c con_to_dmatch _ = impossible "Internal error within th-desugar." error_match = DMatch DWildP (DAppE (DVarE 'error) (DLitE (StringL "Non-exhaustive patterns in record update"))) fst_of_3 (x, _, _) = x #if __GLASGOW_HASKELL__ >= 709 dsExp (StaticE exp) = DStaticE <$> dsExp exp #endif #if __GLASGOW_HASKELL__ > 710 dsExp (UnboundVarE n) = return (DVarE n) #endif #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__ >= 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 dsLam (map VarP 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 -- | Desugar a lambda expression, where the body has already been desugared dsLam :: DsMonad q => [Pat] -> DExp -> q DExp dsLam = mkLam stripVarP_maybe dsPatsOverExp -- | 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 :: DsMonad q => [DPat] -> DExp -> q DExp mkDLamEFromDPats = mkLam stripDVarP_maybe (\pats exp -> return (pats, exp)) where stripDVarP_maybe :: DPat -> Maybe Name stripDVarP_maybe (DVarP n) = Just n stripDVarP_maybe _ = Nothing -- | Generalizes 'dsLam' and 'mkDLamEFromDPats' to work over an arbitrary -- pattern type. mkLam :: DsMonad q => (pat -> Maybe Name) -- ^ Should return @'Just' n@ if the argument is a -- variable pattern, and 'Nothing' otherwise. -> ([pat] -> DExp -> q ([DPat], DExp)) -- ^ Should process a list of @pat@ arguments and -- a 'DExp' body. (This might do some internal -- reorganization if there are as-patterns, as -- in the case of 'dsPatsOverExp'.) -> [pat] -> DExp -> q DExp mkLam mb_strip_var_pat process_pats_over_exp pats exp | Just names <- mapM mb_strip_var_pat pats = return $ DLamE names exp | otherwise = do arg_names <- replicateM (length pats) (newUniqueName "arg") let scrutinee = mkTupleDExp (map DVarE arg_names) (pats', exp') <- process_pats_over_exp pats exp let match = DMatch (mkTupleDPat pats') exp' return $ DLamE arg_names (DCaseE scrutinee [match]) -- | Desugar a list of matches for a @case@ statement dsMatches :: DsMonad q => Name -- ^ Name of the scrutinee, which must be a bare var -> [Match] -- ^ Matches of the @case@ statement -> q [DMatch] dsMatches scr = go where go :: DsMonad q => [Match] -> q [DMatch] go [] = return [] go (Match pat body where_decs : rest) = do rest' <- go rest let failure = DCaseE (DVarE scr) rest' -- this might be an empty case. exp' <- dsBody body where_decs failure (pat', exp'') <- dsPatOverExp pat exp' uni_pattern <- isUniversalPattern pat' -- incomplete attempt at #6 if uni_pattern then return [DMatch pat' exp''] else return (DMatch pat' exp'' : rest') -- | Desugar a @Body@ dsBody :: DsMonad q => Body -- ^ body to desugar -> [Dec] -- ^ "where" declarations -> DExp -- ^ what to do if the guards don't match -> q DExp dsBody (NormalB exp) decs _ = 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 :: String -> DExp -> [DMatch] -> DExp maybeDCaseE err _ [] = DAppE (DVarE 'error) (DLitE (StringL err)) maybeDCaseE _ scrut matches = DCaseE scrut matches -- | Desugar guarded expressions dsGuards :: DsMonad q => [(Guard, Exp)] -- ^ Guarded expressions -> DExp -- ^ What to do if none of the guards match -> q DExp dsGuards [] thing_inside = return thing_inside dsGuards ((NormalG gd, exp) : rest) thing_inside = dsGuards ((PatG [NoBindS gd], exp) : rest) thing_inside dsGuards ((PatG stmts, exp) : rest) thing_inside = do success <- dsExp exp failure <- dsGuards rest thing_inside dsGuardStmts stmts success failure -- | Desugar the @Stmt@s in a guard dsGuardStmts :: DsMonad q => [Stmt] -- ^ The @Stmt@s to desugar -> DExp -- ^ What to do if the @Stmt@s yield success -> DExp -- ^ What to do if the @Stmt@s yield failure -> q DExp dsGuardStmts [] success _failure = return success dsGuardStmts (BindS pat exp : rest) success failure = do success' <- dsGuardStmts rest success failure (pat', success'') <- dsPatOverExp pat success' exp' <- dsExp exp return $ DCaseE exp' [DMatch pat' success'', DMatch 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 :: DsMonad q => [Stmt] -> q DExp dsDoStmts [] = impossible "do-expression ended with something other than bare statement." dsDoStmts [NoBindS exp] = dsExp exp dsDoStmts (BindS pat exp : rest) = do rest' <- dsDoStmts rest dsBindS exp pat rest' "do expression" dsDoStmts (LetS decs : rest) = do (decs', ip_binder) <- dsLetDecs decs rest' <- dsDoStmts rest return $ DLetE decs' $ ip_binder rest' dsDoStmts (NoBindS exp : rest) = do exp' <- dsExp exp rest' <- dsDoStmts rest return $ DAppE (DAppE (DVarE '(>>)) exp') rest' dsDoStmts (ParS _ : _) = impossible "Parallel comprehension in a do-statement." #if __GLASGOW_HASKELL__ >= 807 dsDoStmts (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 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) <$> dsLam [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 => Exp -> Pat -> DExp -> String -> q DExp dsBindS 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_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 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 'MonadFail.fail #elif __GLASGOW_HASKELL__ >= 800 mk_fail_name = do mfd <- qIsExtEnabled MonadFailDesugaring return $ if mfd then 'MonadFail.fail else 'Prelude.fail #else mk_fail_name = return '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 (Pat, DExp) dsParComp [] = impossible "Empty list of parallel comprehension statements." dsParComp [r] = do let rv = foldMap extractBoundNamesStmt r dsR <- dsComp (r ++ [mk_tuple_stmt rv]) return (mk_tuple_pat rv, dsR) dsParComp (q : rest) = do let qv = foldMap extractBoundNamesStmt q (rest_pat, rest_exp) <- dsParComp rest dsQ <- dsComp (q ++ [mk_tuple_stmt qv]) let zipped = DAppE (DAppE (DVarE 'mzip) dsQ) rest_exp return (ConP (tupleDataName 2) [mk_tuple_pat qv, rest_pat], zipped) -- helper function for dsParComp mk_tuple_stmt :: OSet Name -> Stmt mk_tuple_stmt name_set = NoBindS (mkTupleExp (F.foldr ((:) . VarE) [] name_set)) -- helper function for dsParComp mk_tuple_pat :: OSet Name -> Pat mk_tuple_pat name_set = mkTuplePat (F.foldr ((:) . VarP) [] name_set) -- | Desugar a pattern, along with processing a (desugared) expression that -- is the entire scope of the variables bound in the pattern. dsPatOverExp :: DsMonad q => Pat -> DExp -> q (DPat, DExp) dsPatOverExp pat exp = do (pat', vars) <- runWriterT $ dsPat pat let name_decs = uncurry (zipWith (DValD . DVarP)) $ unzip vars return (pat', maybeDLetE name_decs exp) -- | Desugar multiple patterns. Like 'dsPatOverExp'. dsPatsOverExp :: DsMonad q => [Pat] -> DExp -> q ([DPat], DExp) dsPatsOverExp pats exp = do (pats', vars) <- runWriterT $ mapM dsPat pats let name_decs = uncurry (zipWith (DValD . DVarP)) $ unzip vars return (pats', maybeDLetE name_decs exp) -- | Desugar a pattern, returning a list of (Name, DExp) pairs of extra -- variables that must be bound within the scope of the pattern dsPatX :: DsMonad q => Pat -> q (DPat, [(Name, DExp)]) dsPatX = runWriterT . dsPat -- | Desugaring a pattern also returns the list of variables bound in as-patterns -- and the values they should be bound to. This variables must be brought into -- scope in the "body" of the pattern. type PatM q = WriterT [(Name, DExp)] q -- | Desugar a pattern. dsPat :: DsMonad q => Pat -> PatM q DPat dsPat (LitP lit) = return $ 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 dsPat (ConP name pats) = DConP name <$> mapM dsPat pats 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 #if __GLASGOW_HASKELL__ >= 800 GadtC _names fields _ret_ty -> non_record fields RecGadtC _names fields _ret_ty -> reorder_fields_pat fields #endif 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 pats) = foldl DAppE (DConE name) (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 pats) = DConP con_name <$> 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) #if __GLASGOW_HASKELL__ > 710 dsInfo (ClassOpI name ty parent) = #else dsInfo (ClassOpI name ty parent _fixity) = #endif DVarI name <$> dsType ty <*> pure (Just parent) dsInfo (TyConI dec) = do [ddec] <- dsDec dec return $ DTyConI ddec Nothing dsInfo (FamilyI dec instances) = do [ddec] <- dsDec dec dinstances <- dsDecs instances return $ DTyConI ddec (Just dinstances) dsInfo (PrimTyConI name arity unlifted) = return $ DPrimTyConI name arity unlifted #if __GLASGOW_HASKELL__ > 710 dsInfo (DataConI name ty parent) = DVarI name <$> dsType ty <*> pure (Just parent) dsInfo (VarI name ty Nothing) = DVarI name <$> dsType ty <*> pure Nothing dsInfo (VarI name _ (Just _)) = impossible $ "Declaration supplied with variable: " ++ show name #else dsInfo (DataConI name ty parent _fixity) = DVarI name <$> dsType ty <*> pure (Just parent) dsInfo (VarI name ty Nothing _fixity) = DVarI name <$> dsType ty <*> pure Nothing dsInfo (VarI name _ (Just _) _) = impossible $ "Declaration supplied with variable: " ++ show name #endif dsInfo (TyVarI name ty) = DTyVarI name <$> dsType ty #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 #if __GLASGOW_HASKELL__ > 710 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 #else dsDec (DataD cxt n tvbs cons derivings) = dsDataDec Data cxt n tvbs Nothing cons derivings dsDec (NewtypeD cxt n tvbs con derivings) = dsDataDec Newtype cxt n tvbs Nothing [con] derivings #endif dsDec (TySynD n tvbs ty) = (:[]) <$> (DTySynD n <$> mapM dsTvb tvbs <*> dsType ty) dsDec (ClassD cxt n tvbs fds decs) = (:[]) <$> (DClassD <$> dsCxt cxt <*> pure n <*> mapM dsTvb tvbs <*> pure fds <*> dsDecs decs) #if __GLASGOW_HASKELL__ >= 711 dsDec (InstanceD over cxt ty decs) = (:[]) <$> (DInstanceD over Nothing <$> dsCxt cxt <*> dsType ty <*> dsDecs decs) #else dsDec (InstanceD cxt ty decs) = (:[]) <$> (DInstanceD Nothing Nothing <$> dsCxt cxt <*> dsType ty <*> dsDecs decs) #endif dsDec d@(SigD {}) = dsTopLevelLetDec d dsDec (ForeignD f) = (:[]) <$> (DForeignD <$> dsForeign f) dsDec d@(InfixD {}) = dsTopLevelLetDec d dsDec d@(PragmaD {}) = dsTopLevelLetDec d #if __GLASGOW_HASKELL__ > 710 dsDec (OpenTypeFamilyD tfHead) = (:[]) <$> (DOpenTypeFamilyD <$> dsTypeFamilyHead tfHead) dsDec (DataFamilyD n tvbs m_k) = (:[]) <$> (DDataFamilyD n <$> mapM dsTvb tvbs <*> mapM dsType m_k) #else dsDec (FamilyD TypeFam n tvbs m_k) = do (:[]) <$> (DOpenTypeFamilyD <$> dsTypeFamilyHead n tvbs m_k) dsDec (FamilyD DataFam n tvbs m_k) = (:[]) <$> (DDataFamilyD n <$> mapM dsTvb tvbs <*> mapM dsType m_k) #endif #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 #elif __GLASGOW_HASKELL__ > 710 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 #else dsDec (DataInstD cxt n tys cons derivings) = dsDataInstDec Data cxt n Nothing (map TANormal tys) Nothing cons derivings dsDec (NewtypeInstD cxt n tys con derivings) = dsDataInstDec Newtype cxt n Nothing (map TANormal tys) Nothing [con] derivings #endif #if __GLASGOW_HASKELL__ >= 807 dsDec (TySynInstD eqn) = (:[]) <$> (DTySynInstD <$> dsTySynEqn unusedArgument eqn) #else dsDec (TySynInstD n eqn) = (:[]) <$> (DTySynInstD <$> dsTySynEqn n eqn) #endif #if __GLASGOW_HASKELL__ > 710 dsDec (ClosedTypeFamilyD tfHead eqns) = (:[]) <$> (DClosedTypeFamilyD <$> dsTypeFamilyHead tfHead <*> mapM (dsTySynEqn (typeFamilyHeadName tfHead)) eqns) #else dsDec (ClosedTypeFamilyD n tvbs m_k eqns) = do (:[]) <$> (DClosedTypeFamilyD <$> dsTypeFamilyHead n tvbs m_k <*> mapM (dsTySynEqn n) eqns) #endif dsDec (RoleAnnotD n roles) = return [DRoleAnnotD n roles] #if __GLASGOW_HASKELL__ >= 709 #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) #endif #if __GLASGOW_HASKELL__ >= 807 dsDec (ImplicitParamBindD {}) = impossible "Non-`let`-bound implicit param binding" #endif -- | Desugar a 'DataD' or 'NewtypeD'. dsDataDec :: DsMonad q => NewOrData -> Cxt -> Name -> [TyVarBndr] -> Maybe Kind -> [Con] -> [DerivingClause] -> q [DDec] dsDataDec nd cxt n tvbs mk cons derivings = do tvbs' <- mapM dsTvb tvbs let h98_tvbs = case mk of -- If there's an explicit return kind, we're dealing with a -- GADT, so this argument goes unused in dsCon. Just {} -> unusedArgument Nothing -> tvbs' h98_return_type = nonFamilyDataReturnType n tvbs' (:[]) <$> (DDataD nd <$> dsCxt cxt <*> pure n <*> pure tvbs' <*> mapM dsType mk <*> concatMapM (dsCon h98_tvbs h98_return_type) cons <*> mapM dsDerivClause derivings) -- | Desugar a 'DataInstD' or a 'NewtypeInstD'. dsDataInstDec :: DsMonad q => NewOrData -> Cxt -> Name -> Maybe [TyVarBndr] -> [TypeArg] -> Maybe Kind -> [Con] -> [DerivingClause] -> q [DDec] dsDataInstDec nd cxt n mtvbs tys mk cons derivings = do mtvbs' <- mapM (mapM dsTvb) 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) -- Like mkExtraDKindBinders, but accepts a Maybe Kind -- argument instead of DKind. mkExtraKindBinders :: DsMonad q => Maybe Kind -> q [DTyVarBndr] mkExtraKindBinders = maybe (pure (DConT typeKindName)) (runQ . resolveTypeSynonyms >=> dsType) >=> mkExtraDKindBinders' -- | Like mkExtraDKindBinders, but assumes kind synonyms have been expanded. mkExtraDKindBinders' :: Quasi q => DKind -> q [DTyVarBndr] mkExtraDKindBinders' = mkExtraKindBindersGeneric unravel DKindedTV #if __GLASGOW_HASKELL__ > 710 -- | Desugar a @FamilyResultSig@ dsFamilyResultSig :: DsMonad q => FamilyResultSig -> q DFamilyResultSig dsFamilyResultSig NoSig = return DNoSig dsFamilyResultSig (KindSig k) = DKindSig <$> dsType k dsFamilyResultSig (TyVarSig tvb) = DTyVarSig <$> dsTvb tvb -- | Desugar a @TypeFamilyHead@ dsTypeFamilyHead :: DsMonad q => TypeFamilyHead -> q DTypeFamilyHead dsTypeFamilyHead (TypeFamilyHead n tvbs result inj) = DTypeFamilyHead n <$> mapM dsTvb tvbs <*> dsFamilyResultSig result <*> pure inj typeFamilyHeadName :: TypeFamilyHead -> Name typeFamilyHeadName (TypeFamilyHead n _ _ _) = n #else -- | Desugar bits and pieces into a 'DTypeFamilyHead' dsTypeFamilyHead :: DsMonad q => Name -> [TyVarBndr] -> Maybe Kind -> q DTypeFamilyHead dsTypeFamilyHead n tvbs m_kind = do result_sig <- case m_kind of Nothing -> return DNoSig Just k -> DKindSig <$> dsType k DTypeFamilyHead n <$> mapM dsTvb tvbs <*> pure result_sig <*> pure Nothing #endif -- | Desugar @Dec@s that can appear in a @let@ expression. 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 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 = DAppE (DVarE 'error) (DLitE (StringL $ "Non-exhaustive patterns for " ++ pprint 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 => [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] dsCon univ_dtvbs data_type con = do dcons' <- dsCon' con return $ flip map dcons' $ \(n, dtvbs, dcxt, fields, m_gadt_type) -> case m_gadt_type of Nothing -> let ex_dtvbs = dtvbs expl_dtvbs = univ_dtvbs ++ ex_dtvbs impl_dtvbs = 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, [DTyVarBndr], 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 dsTvb 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) #if __GLASGOW_HASKELL__ > 710 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) #endif #if __GLASGOW_HASKELL__ > 710 -- | Desugar a @BangType@ (or a @StrictType@, if you're old-fashioned) dsBangType :: DsMonad q => BangType -> q DBangType dsBangType (b, ty) = (b, ) <$> dsType ty -- | Desugar a @VarBangType@ (or a @VarStrictType@, if you're old-fashioned) dsVarBangType :: DsMonad q => VarBangType -> q DVarBangType dsVarBangType (n, b, ty) = (n, b, ) <$> dsType ty #else -- | Desugar a @BangType@ (or a @StrictType@, if you're old-fashioned) dsBangType :: DsMonad q => StrictType -> q DBangType dsBangType (b, ty) = (strictToBang b, ) <$> dsType ty -- | Desugar a @VarBangType@ (or a @VarStrictType@, if you're old-fashioned) dsVarBangType :: DsMonad q => VarStrictType -> q DVarBangType dsVarBangType (n, b, ty) = (n, strictToBang b, ) <$> dsType ty #endif -- | Desugar a @Foreign@. dsForeign :: DsMonad q => Foreign -> q DForeign dsForeign (ImportF cc safety str n ty) = DImportF cc safety str n <$> dsType ty dsForeign (ExportF cc str n ty) = DExportF cc str n <$> dsType ty -- | Desugar a @Pragma@. dsPragma :: DsMonad q => Pragma -> q DPragma dsPragma (InlineP n inl rm phases) = return $ DInlineP n inl rm phases dsPragma (SpecialiseP n ty m_inl phases) = DSpecialiseP n <$> dsType ty <*> pure m_inl <*> pure phases dsPragma (SpecialiseInstP ty) = DSpecialiseInstP <$> dsType ty #if __GLASGOW_HASKELL__ >= 807 dsPragma (RuleP str mtvbs rbs lhs rhs phases) = DRuleP str <$> mapM (mapM dsTvb) 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 #if __GLASGOW_HASKELL__ >= 709 dsPragma (LineP n str) = return $ DLineP n str #endif #if __GLASGOW_HASKELL__ >= 801 dsPragma (CompleteP cls mty) = return $ DCompleteP cls mty #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 dsTvb) 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 => Name -- ^ Name of the function -> [Clause] -- ^ Clauses to desugar -> q [DClause] dsClauses _ [] = return [] dsClauses n (Clause pats (NormalB exp) where_decs : rest) = do -- this case is necessary to maintain the roundtrip property. rest' <- dsClauses n rest exp' <- dsExp exp (where_decs', 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 n clauses@(Clause outer_pats _ _ : _) = do arg_names <- replicateM (length outer_pats) (newUniqueName "arg") let scrutinee = mkTupleDExp (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 ("Non-exhaustive patterns in " ++ (show n)) scrutinee failure_matches exp <- dsBody body where_decs failure_exp (pats', exp') <- dsPatsOverExp pats exp uni_pats <- fmap getAll $ concatMapM (fmap All . isUniversalPattern) pats' let match = DMatch (mkTupleDPat pats') exp' if uni_pats then return [match] else return (match : failure_matches) -- | Desugar a type dsType :: DsMonad q => Type -> q DType dsType (ForallT tvbs preds ty) = DForallT <$> mapM dsTvb tvbs <*> dsCxt preds <*> dsType ty dsType (AppT t1 t2) = DAppT <$> dsType t1 <*> dsType t2 dsType (SigT ty ki) = DSigT <$> dsType ty <*> dsType ki dsType (VarT name) = return $ DVarT name dsType (ConT name) = return $ DConT name -- the only difference between ConT and PromotedT is the name lookup. Here, we assume -- that the TH quote mechanism figured out the right name. Note that lookupDataName name -- does not necessarily work, because `name` has its original module attached, which -- may not be in scope. dsType (PromotedT name) = return $ DConT name dsType (TupleT n) = return $ DConT (tupleTypeName n) dsType (UnboxedTupleT n) = return $ DConT (unboxedTupleTypeName n) dsType ArrowT = return DArrowT dsType ListT = return $ DConT ''[] dsType (PromotedTupleT n) = return $ DConT (tupleDataName n) dsType PromotedNilT = return $ DConT '[] dsType PromotedConsT = return $ DConT '(:) dsType StarT = return $ DConT typeKindName dsType ConstraintT = return $ DConT ''Constraint dsType (LitT lit) = return $ DLitT lit #if __GLASGOW_HASKELL__ >= 709 dsType EqualityT = return $ DConT ''(~) #endif #if __GLASGOW_HASKELL__ > 710 dsType (InfixT t1 n t2) = DAppT <$> (DAppT (DConT n) <$> dsType t1) <*> dsType t2 dsType (UInfixT _ _ _) = fail "Cannot desugar unresolved infix operators." dsType (ParensT t) = dsType t dsType WildCardT = return DWildCardT #endif #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 -- | Desugar a @TyVarBndr@ dsTvb :: DsMonad q => TyVarBndr -> q DTyVarBndr dsTvb (PlainTV n) = return $ DPlainTV n dsTvb (KindedTV n k) = DKindedTV n <$> dsType k -- | Desugar a @Cxt@ dsCxt :: DsMonad q => Cxt -> q DCxt dsCxt = concatMapM dsPred #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 #elif __GLASGOW_HASKELL__ >= 711 type DerivingClause = Pred dsDerivClause :: DsMonad q => DerivingClause -> q DDerivClause dsDerivClause p = DDerivClause Nothing <$> dsPred p #else type DerivingClause = Name dsDerivClause :: DsMonad q => DerivingClause -> q DDerivClause dsDerivClause n = pure $ DDerivClause Nothing [DConT n] #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 n clauses #endif -- | Desugar a @Pred@, flattening any internal tuples dsPred :: DsMonad q => Pred -> q DCxt #if __GLASGOW_HASKELL__ < 709 dsPred (ClassP n tys) = do ts' <- mapM dsType tys return [foldl DAppT (DConT n) ts'] dsPred (EqualP t1 t2) = do ts' <- mapM dsType [t1, t2] return [foldl DAppT (DConT ''(~)) ts'] #else dsPred t | Just ts <- splitTuple_maybe t = concatMapM dsPred ts dsPred (ForallT tvbs cxt p) = do ps' <- dsPred p case ps' of [p'] -> (:[]) <$> (DForallT <$> mapM dsTvb tvbs <*> dsCxt cxt <*> pure p') _ -> fail "Cannot desugar constraint tuples in the body of a quantified constraint" -- See Trac #15334. 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 ''(~)] #if __GLASGOW_HASKELL__ > 710 dsPred (InfixT t1 n t2) = (:[]) <$> (DAppT <$> (DAppT (DConT n) <$> dsType t1) <*> dsType t2) dsPred (UInfixT _ _ _) = fail "Cannot desugar unresolved infix operators." dsPred (ParensT t) = dsPred t dsPred WildCardT = return [DWildCardT] #endif #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 #endif -- | Like 'reify', but safer and desugared. Uses local declarations where -- available. dsReify :: DsMonad q => Name -> q (Maybe DInfo) dsReify = traverse dsInfo <=< reifyWithLocals_maybe -- create a list of expressions in the same order as the fields in the first argument -- but with the values as given in the second argument -- if a field is missing from the second argument, use the corresponding expression -- from the third argument reorderFields :: DsMonad q => 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." -- | Make a tuple 'DExp' from a list of 'DExp's. Avoids using a 1-tuple. mkTupleDExp :: [DExp] -> DExp mkTupleDExp [exp] = exp mkTupleDExp exps = foldl DAppE (DConE $ tupleDataName (length exps)) exps -- | Make a tuple 'Exp' from a list of 'Exp's. Avoids using a 1-tuple. mkTupleExp :: [Exp] -> Exp mkTupleExp [exp] = exp mkTupleExp exps = foldl AppE (ConE $ tupleDataName (length exps)) exps -- | Make a tuple 'DPat' from a list of 'DPat's. Avoids using a 1-tuple. mkTupleDPat :: [DPat] -> DPat mkTupleDPat [pat] = pat mkTupleDPat pats = DConP (tupleDataName (length pats)) pats -- | Make a tuple 'Pat' from a list of 'Pat's. Avoids using a 1-tuple. mkTuplePat :: [Pat] -> Pat mkTuplePat [pat] = pat mkTuplePat pats = ConP (tupleDataName (length pats)) pats -- | Is this pattern guaranteed to match? isUniversalPattern :: DsMonad q => DPat -> q Bool isUniversalPattern (DLitP {}) = return False isUniversalPattern (DVarP {}) = return True isUniversalPattern (DConP con_name pats) = do data_name <- dataConNameToDataName con_name (_tvbs, cons) <- getDataD "Internal error." data_name if length cons == 1 then fmap and $ mapM isUniversalPattern pats else return False isUniversalPattern (DTildeP {}) = return True isUniversalPattern (DBangP pat) = isUniversalPattern pat isUniversalPattern (DSigP pat _) = isUniversalPattern pat isUniversalPattern DWildP = return True -- | Apply one 'DExp' to a list of arguments applyDExp :: DExp -> [DExp] -> DExp applyDExp = foldl DAppE -- | Apply one 'DType' to a list of arguments applyDType :: DType -> [DTypeArg] -> DType applyDType = foldl apply where apply :: DType -> DTypeArg -> DType apply f (DTANormal x) = f `DAppT` x apply f (DTyArg x) = f `DAppKindT` x -- | An argument to a type, either a normal type ('DTANormal') or a visible -- kind application ('DTyArg'). -- -- 'DTypeArg' does not appear directly in the @th-desugar@ AST, but it is -- useful when decomposing an application of a 'DType' to its arguments. data DTypeArg = DTANormal DType | DTyArg DKind deriving (Eq, Show, Typeable, 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 -> 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 -- | Convert a 'Strict' to a 'Bang' in GHCs 7.x. This is just -- the identity operation in GHC 8.x, which has no 'Strict'. -- (This is included in GHC 8.x only for good Haddocking.) #if __GLASGOW_HASKELL__ <= 710 strictToBang :: Strict -> Bang strictToBang IsStrict = Bang NoSourceUnpackedness SourceStrict strictToBang NotStrict = Bang NoSourceUnpackedness NoSourceStrictness strictToBang Unpacked = Bang SourceUnpack SourceStrict #else strictToBang :: Bang -> Bang strictToBang = id #endif -- 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 -> [DTyVarBndr] -> 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] -> [DTyVarBndr] 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] -> [DTyVarBndr] 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 tvbs ctxt t) = go_tvbs tvbs (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_tvbs :: [DTyVarBndr] -> Map Name DKind -> Map Name DKind go_tvbs tvbs m = foldr go_tvb m tvbs go_tvb :: DTyVarBndr -> 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) -- An annoying wrinkle: GHCs before 8.0 don't support explicitly -- quantifying kinds, so something like @forall k (a :: k)@ would be -- rejected. To work around this, we filter out any binders whose names -- also appear in a kind on old GHCs. isKindBinderOnOldGHCs #if __GLASGOW_HASKELL__ >= 800 = const False #else = (`elem` kindVars) where kindVars = foldMap fvDType $ M.elems varKindSigs #endif in map ascribeWithKind $ filter (not . isKindBinderOnOldGHCs) $ scopedSort freeVars dtvbName :: DTyVarBndr -> Name dtvbName (DPlainTV n) = n dtvbName (DKindedTV n _) = n -- | Decompose a function type into its type variables, its context, its -- argument types, and its result type. unravel :: DType -> ([DTyVarBndr], [DPred], [DType], DType) unravel (DForallT tvbs cxt ty) = let (tvbs', cxt', tys, res) = unravel ty in (tvbs ++ tvbs', cxt ++ cxt', tys, res) unravel (DAppT (DAppT DArrowT t1) t2) = let (tvbs, cxt, tys, res) = unravel t2 in (tvbs, cxt, t1 : tys, res) unravel t = ([], [], [], t) -- | 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 'TyVarBndr', if one is present. extractTvbKind :: DTyVarBndr -> Maybe DKind extractTvbKind (DPlainTV _) = Nothing extractTvbKind (DKindedTV _ k) = Just k -- | 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" th-desugar-1.10/Language/Haskell/TH/Desugar/Expand.hs0000644000000000000000000002417007346545000020461 0ustar0000000000000000{- Language/Haskell/TH/Desugar/Expand.hs (c) Richard Eisenberg 2013 rae@cs.brynmawr.edu -} {-# LANGUAGE CPP, 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 Control.Monad #if __GLASGOW_HASKELL__ < 709 import Control.Applicative #endif import Language.Haskell.TH hiding (cxt) import Language.Haskell.TH.Syntax ( Quasi(..) ) import Data.Data import Data.Generics import 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 tvbs cxt ty) = DForallT <$> mapM (expand_tvb ign) tvbs <*> mapM (expand_type ign) cxt <*> expand_type ign ty go _ (DForallT {}) = impossible "A forall 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 a type variable binder's kind. expand_tvb :: DsMonad q => IgnoreKinds -> DTyVarBndr -> q DTyVarBndr expand_tvb _ tvb@DPlainTV{} = pure tvb expand_tvb ign (DKindedTV n k) = DKindedTV n <$> 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 args_ok <- allM no_tyvars_tyfams normal_args 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 extractDTvbName 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! #if __GLASGOW_HASKELL__ < 709 , args_ok #endif -> 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 , args_ok -> 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 no_tyvars_tyfams :: DType -> q Bool no_tyvars_tyfams = go_ty where go_ty :: DType -> q Bool -- Interesting cases go_ty (DVarT _) = return False go_ty (DConT con_name) = do m_info <- dsReify con_name return $ case m_info of Nothing -> False -- we don't know anything. False is safe. Just (DTyConI (DOpenTypeFamilyD {}) _) -> False Just (DTyConI (DDataFamilyD {}) _) -> False Just (DTyConI (DClosedTypeFamilyD {}) _) -> False _ -> True -- Recursive cases go_ty (DForallT tvbs ctxt ty) = liftM3 (\x y z -> x && y && z) (allM go_tvb tvbs) (allM go_ty ctxt) (go_ty ty) go_ty (DAppT t1 t2) = liftM2 (&&) (go_ty t1) (go_ty t2) go_ty (DAppKindT t k) = liftM2 (&&) (go_ty t) (go_ty k) go_ty (DSigT t k) = liftM2 (&&) (go_ty t) (go_ty k) -- Default to True go_ty DLitT{} = return True go_ty DArrowT = return True go_ty DWildCardT = return True -- These cases are uninteresting go_tvb :: DTyVarBndr -> q Bool go_tvb DPlainTV{} = return True go_tvb (DKindedTV _ k) = go_ty k allM :: Monad m => (a -> m Bool) -> [a] -> m Bool allM f = foldM (\b x -> (b &&) `liftM` f x) True {- 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. -} -- | Extract the name from a @TyVarBndr@ extractDTvbName :: DTyVarBndr -> Name extractDTvbName (DPlainTV n) = n extractDTvbName (DKindedTV n _) = n -- | 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.10/Language/Haskell/TH/Desugar/FV.hs0000644000000000000000000000373007346545000017554 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__ < 710 import Data.Foldable (foldMap) #endif #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 tvbs ctxt ty) = fv_dtvbs tvbs (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 _ pats) = 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 'DTyVarBndr's. fv_dtvbs :: [DTyVarBndr] -> 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 -> 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.10/Language/Haskell/TH/Desugar/Lift.hs0000644000000000000000000000272007346545000020135 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 -- -- Defines @Lift@ instances for the desugared language. This is defined -- in a separate module because it also must define @Lift@ instances for -- several TH types, which are orphans and may want another definition -- downstream. -- ---------------------------------------------------------------------------- {-# LANGUAGE CPP, TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Language.Haskell.TH.Desugar.Lift () where import Language.Haskell.TH.Desugar import Language.Haskell.TH.Instances () import Language.Haskell.TH.Lift $(deriveLiftMany [ ''DExp, ''DPat, ''DType, ''DTyVarBndr , ''DMatch, ''DClause, ''DLetDec, ''DDec, ''DDerivClause, ''DCon , ''DConFields, ''DForeign, ''DPragma, ''DRuleBndr, ''DTySynEqn , ''DPatSynDir , ''NewOrData, ''DDerivStrategy , ''DTypeFamilyHead, ''DFamilyResultSig #if __GLASGOW_HASKELL__ <= 710 , ''InjectivityAnn, ''Bang, ''SourceUnpackedness , ''SourceStrictness, ''Overlap #endif #if __GLASGOW_HASKELL__ < 801 , ''PatSynArgs #endif , ''TypeArg, ''DTypeArg ]) th-desugar-1.10/Language/Haskell/TH/Desugar/Match.hs0000644000000000000000000003712007346545000020275 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, TemplateHaskell #-} module Language.Haskell.TH.Desugar.Match (scExp, scLetDec) where import Prelude hiding ( fail, exp ) #if __GLASGOW_HASKELL__ < 709 import Control.Applicative #endif import Control.Monad hiding ( fail ) import qualified Control.Monad as Monad import Data.Data import qualified Data.Foldable as F import Data.Generics import qualified Data.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 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 DLitP lit = firstPat (head eqns) 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.10/Language/Haskell/TH/Desugar/OMap.hs0000644000000000000000000001223407346545000020074 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -fno-warn-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,8,0)) import Data.Foldable (Foldable) import Data.Monoid (Monoid(..)) import Data.Traversable (Traversable) #endif #if !(MIN_VERSION_base(4,11,0)) import Data.Semigroup (Semigroup(..)) #endif #if __GLASGOW_HASKELL__ < 710 deriving instance Typeable L #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, Typeable) 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 :: OM.OMap 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.|<>) :: OM.OMap k v -> OM.OMap k v -> OM.OMap 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 -> OM.OMap k v -> OM.OMap 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.\\) :: OM.OMap k v -> OM.OMap k v' -> OM.OMap k v) intersection :: forall k v v'. Ord k => OMap k v -> OMap k v' -> OMap k v intersection = coerce ((OM.|/\) :: OM.OMap k v -> OM.OMap k v' -> OM.OMap k 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 :: OM.OMap k v -> Bool) size :: forall k v. OMap k v -> Int size = coerce (OM.size :: OM.OMap k v -> Int) member :: forall k v. Ord k => k -> OMap k v -> Bool member = coerce (OM.member :: k -> OM.OMap k v -> Bool) notMember :: forall k v. Ord k => k -> OMap k v -> Bool notMember = coerce (OM.notMember :: k -> OM.OMap k v -> Bool) lookup :: forall k v. Ord k => k -> OMap k v -> Maybe v lookup = coerce (OM.lookup :: k -> OM.OMap k v -> Maybe v) lookupIndex :: forall k v. Ord k => k -> OMap k v -> Maybe Index lookupIndex = coerce (OM.findIndex :: k -> OM.OMap k v -> Maybe Index) lookupAt :: forall k v. Index -> OMap k v -> Maybe (k, v) lookupAt i m = coerce (OM.elemAt (coerce m) i :: Maybe (k, v)) 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 :: OM.OMap k v -> [(k, v)]) toAscList :: forall k v. OMap k v -> [(k, v)] toAscList = coerce (OM.toAscList :: OM.OMap k v -> [(k, v)]) toMap :: forall k v. OMap k v -> M.Map k v toMap = coerce (OM.toMap :: OM.OMap k v -> M.Map k v) th-desugar-1.10/Language/Haskell/TH/Desugar/OMap/0000755000000000000000000000000007346545000017536 5ustar0000000000000000th-desugar-1.10/Language/Haskell/TH/Desugar/OMap/Strict.hs0000644000000000000000000001017107346545000021342 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- 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 :: OM.OMap 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.|<>) :: OM.OMap k v -> OM.OMap k v -> OM.OMap 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 -> OM.OMap k v -> OM.OMap 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.\\) :: OM.OMap k v -> OM.OMap k v' -> OM.OMap k v) intersection :: forall k v v'. Ord k => OMap k v -> OMap k v' -> OMap k v intersection = coerce ((OM.|/\) :: OM.OMap k v -> OM.OMap k v' -> OM.OMap k 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 :: OM.OMap k v -> Bool) size :: forall k v. OMap k v -> Int size = coerce (OM.size :: OM.OMap k v -> Int) member :: forall k v. Ord k => k -> OMap k v -> Bool member = coerce (OM.member :: k -> OM.OMap k v -> Bool) notMember :: forall k v. Ord k => k -> OMap k v -> Bool notMember = coerce (OM.notMember :: k -> OM.OMap k v -> Bool) lookup :: forall k v. Ord k => k -> OMap k v -> Maybe v lookup = coerce (OM.lookup :: k -> OM.OMap k v -> Maybe v) lookupIndex :: forall k v. Ord k => k -> OMap k v -> Maybe Index lookupIndex = coerce (OM.findIndex :: k -> OM.OMap k v -> Maybe Index) lookupAt :: forall k v. Index -> OMap k v -> Maybe (k, v) lookupAt i m = coerce (OM.elemAt (coerce m) i :: Maybe (k, v)) 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 :: OM.OMap k v -> [(k, v)]) toAscList :: forall k v. OMap k v -> [(k, v)] toAscList = coerce (OM.toAscList :: OM.OMap k v -> [(k, v)]) toMap :: forall k v. OMap k v -> M.Map k v toMap = coerce (OM.toMap :: OM.OMap k v -> M.Map k v) th-desugar-1.10/Language/Haskell/TH/Desugar/OSet.hs0000644000000000000000000000725107346545000020115 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- 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,8,0)) import Data.Foldable (Foldable) import Data.Monoid (Monoid) #endif #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, Typeable) instance Ord a => Semigroup (OSet a) where (<>) = union empty :: forall a. OSet a empty = coerce (OS.empty :: OS.OSet 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.|<>) :: OS.OSet a -> OS.OSet a -> OS.OSet a) null :: forall a. OSet a -> Bool null = coerce (OS.null :: OS.OSet a -> Bool) size :: forall a. OSet a -> Int size = coerce (OS.size :: OS.OSet a -> Int) 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.\\) :: OS.OSet a -> OS.OSet a -> OS.OSet a) intersection :: forall a. Ord a => OSet a -> OSet a -> OSet a intersection = coerce ((OS.|/\) :: OS.OSet a -> OS.OSet a -> OS.OSet 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 = coerce (OS.elemAt (coerce s) i :: Maybe a) fromList :: Ord a => [a] -> OSet a fromList l = coerce (OS.fromList l) toAscList :: forall a. OSet a -> [a] toAscList = coerce (OS.toAscList :: OS.OSet a -> [a]) toSet :: forall a. OSet a -> S.Set a toSet = coerce (OS.toSet :: OS.OSet a -> S.Set a) th-desugar-1.10/Language/Haskell/TH/Desugar/Reify.hs0000644000000000000000000007466507346545000020336 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 #-} module Language.Haskell.TH.Desugar.Reify ( -- * Reification reifyWithLocals_maybe, reifyWithLocals, reifyWithWarning, reifyInDecs, -- ** Fixity reification qReifyFixity, reifyFixity, reifyFixityWithLocals, reifyFixityInDecs, -- * Datatype lookup getDataD, dataConNameToCon, dataConNameToDataName, -- * Value and type lookup lookupValueNameWithLocals, lookupTypeNameWithLocals, mkDataNameWithLocals, mkTypeNameWithLocals, reifyNameSpace, -- * Monad support DsMonad(..), DsM, withLocalDeclarations ) where 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 Data.List import Data.Maybe #if __GLASGOW_HASKELL__ < 709 import Control.Applicative #endif import Language.Haskell.TH.Datatype import Language.Haskell.TH.Instances () import Language.Haskell.TH.Syntax hiding ( lift ) import Language.Haskell.TH.Desugar.Util -- | Like @reify@ from Template Haskell, but looks also in any not-yet-typechecked -- declarations. To establish this list of not-yet-typechecked declarations, -- use 'withLocalDeclarations'. Returns 'Nothing' if reification fails. -- Note that no inferred type information is available from local declarations; -- bottoms may be used if necessary. reifyWithLocals_maybe :: DsMonad q => Name -> q (Maybe Info) reifyWithLocals_maybe name = qRecover (return . reifyInDecs name =<< localDeclarations) (Just `fmap` qReify name) -- | Like 'reifyWithLocals_maybe', but throws an exception upon failure, -- warning the user about separating splices. reifyWithLocals :: DsMonad q => Name -> q Info reifyWithLocals name = do m_info <- reifyWithLocals_maybe name case m_info of Nothing -> reifyFail name Just i -> return i -- | Reify a declaration, warning the user about splices if the reify fails. -- The warning says that reification can fail if you try to reify a type in -- the same splice as it is declared. reifyWithWarning :: (Quasi q, Fail.MonadFail q) => Name -> q Info reifyWithWarning name = qRecover (reifyFail name) (qReify name) -- | Print out a warning about separating splices and fail. reifyFail :: Fail.MonadFail m => Name -> m a reifyFail name = Fail.fail $ "Looking up " ++ (show name) ++ " in the list of available " ++ "declarations failed.\nThis lookup fails if the declaration " ++ "referenced was made in the same Template\nHaskell splice as the use " ++ "of the declaration. If this is the case, put\nthe reference to " ++ "the declaration in a new splice." --------------------------------- -- Utilities --------------------------------- -- | Extract the @TyVarBndr@s and constructors given the @Name@ of a type getDataD :: DsMonad q => String -- ^ Print this out on failure -> Name -- ^ Name of the datatype (@data@ or @newtype@) of interest -> q ([TyVarBndr], [Con]) getDataD err name = do info <- reifyWithLocals name dec <- case info of TyConI dec -> return dec _ -> badDeclaration case dec of #if __GLASGOW_HASKELL__ > 710 DataD _cxt _name tvbs mk cons _derivings -> go tvbs mk cons NewtypeD _cxt _name tvbs mk con _derivings -> go tvbs mk [con] #else DataD _cxt _name tvbs cons _derivings -> go tvbs Nothing cons NewtypeD _cxt _name tvbs con _derivings -> go tvbs Nothing [con] #endif _ -> badDeclaration where go tvbs mk cons = do k <- maybe (pure (ConT typeKindName)) (runQ . resolveTypeSynonyms) mk extra_tvbs <- mkExtraKindBindersGeneric unravelType KindedTV k let all_tvbs = tvbs ++ extra_tvbs return (all_tvbs, cons) badDeclaration = fail $ "The name (" ++ (show name) ++ ") refers to something " ++ "other than a datatype. " ++ err -- | 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 #if __GLASGOW_HASKELL__ > 710 DataConI _name _type parent_name -> return parent_name #else DataConI _name _type parent_name _fixity -> return parent_name #endif _ -> fail $ "The name " ++ show con_name ++ " does not appear to be " ++ "a data constructor." -- | From the name of a data constructor, retrieve its definition as a @Con@ dataConNameToCon :: 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 = find (any (con_name ==) . get_con_name) cons case m_con of Just con -> return con Nothing -> impossible "Datatype does not contain one of its own constructors." where get_con_name (NormalC name _) = [name] get_con_name (RecC name _) = [name] get_con_name (InfixC _ name _) = [name] get_con_name (ForallC _ _ con) = get_con_name con #if __GLASGOW_HASKELL__ > 710 get_con_name (GadtC names _ _) = names get_con_name (RecGadtC names _ _) = names #endif -------------------------------------------------- -- DsMonad -------------------------------------------------- -- | A 'DsMonad' stores some list of declarations that should be considered -- in scope. 'DsM' is the prototypical inhabitant of 'DsMonad'. class (Quasi m, 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 _ = 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' <- find (nameMatches n) (F.toList (extractBoundNamesPat pat)) = Just (n', mkVarI n decs) #if __GLASGOW_HASKELL__ > 710 reifyInDec n _ dec@(DataD _ n' _ _ _ _) | n `nameMatches` n' = Just (n', TyConI dec) reifyInDec n _ dec@(NewtypeD _ n' _ _ _ _) | n `nameMatches` n' = Just (n', TyConI dec) #else reifyInDec n _ dec@(DataD _ n' _ _ _) | n `nameMatches` n' = Just (n', TyConI dec) reifyInDec n _ dec@(NewtypeD _ n' _ _ _) | n `nameMatches` n' = Just (n', TyConI dec) #endif 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 decs (ForeignD (ImportF _ _ _ n' ty)) | n `nameMatches` n' = Just (n', mkVarITy n decs ty) reifyInDec n decs (ForeignD (ExportF _ _ n' ty)) | n `nameMatches` n' = Just (n', mkVarITy n decs ty) #if __GLASGOW_HASKELL__ > 710 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 []) #else reifyInDec n decs dec@(FamilyD _ n' _ _) | n `nameMatches` n' = Just (n', FamilyI dec (findInstances n decs)) reifyInDec n _ dec@(ClosedTypeFamilyD n' _ _ _) | n `nameMatches` n' = Just (n', FamilyI dec []) #endif #if __GLASGOW_HASKELL__ >= 801 reifyInDec n decs (PatSynD n' _ _ _) | n `nameMatches` n' = Just (n', mkPatSynI n decs) #endif #if __GLASGOW_HASKELL__ > 710 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 #else reifyInDec n decs (DataD _ ty_name tvbs cons _) | Just info <- maybeReifyCon n decs ty_name (map tvbToTANormalWithSig tvbs) cons = Just info reifyInDec n decs (NewtypeD _ ty_name tvbs con _) | Just info <- maybeReifyCon n decs ty_name (map tvbToTANormalWithSig tvbs) [con] = Just info #endif #if __GLASGOW_HASKELL__ > 710 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) #else 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 (fromMaybe defaultFixity $ reifyFixityInDecs n $ sub_decs ++ decs)) #endif reifyInDec n decs (ClassD _ _ _ _ sub_decs) | Just info <- firstMatch (reifyInDec n (sub_decs ++ decs)) sub_decs = Just info #if __GLASGOW_HASKELL__ >= 711 reifyInDec n decs (InstanceD _ _ _ sub_decs) #else reifyInDec n decs (InstanceD _ _ sub_decs) #endif | Just info <- firstMatch reify_in_instance sub_decs = Just info where reify_in_instance dec@(DataInstD {}) = reifyInDec n (sub_decs ++ decs) dec reify_in_instance dec@(NewtypeInstD {}) = reifyInDec n (sub_decs ++ decs) dec reify_in_instance _ = Nothing #if __GLASGOW_HASKELL__ >= 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 #elif __GLASGOW_HASKELL__ > 710 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 #else reifyInDec n decs (DataInstD _ ty_name tys cons _) | Just info <- maybeReifyCon n decs ty_name (map TANormal tys) cons = Just info reifyInDec n decs (NewtypeInstD _ ty_name tys con _) | Just info <- maybeReifyCon n decs ty_name (map TANormal tys) [con] = Just info #endif reifyInDec _ _ _ = Nothing maybeReifyCon :: Name -> [Dec] -> Name -> [TypeArg] -> [Con] -> Maybe (Named Info) #if __GLASGOW_HASKELL__ > 710 maybeReifyCon n _decs ty_name ty_args cons | Just (n', con) <- findCon n cons = Just (n', DataConI n (maybeForallT tvbs [] $ con_to_type con) ty_name) #else maybeReifyCon n decs ty_name ty_args cons | Just (n', con) <- findCon n cons = Just (n', DataConI n (maybeForallT tvbs [] $ con_to_type con) ty_name fixity) #endif | Just (n', ty) <- findRecSelector n cons -- we don't try to ferret out naughty record selectors. #if __GLASGOW_HASKELL__ > 710 = Just (n', VarI n (maybeForallT tvbs [] $ mkArrows [result_ty] ty) Nothing) #else = Just (n', VarI n (maybeForallT tvbs [] $ mkArrows [result_ty] ty) Nothing fixity) #endif where result_ty = applyType (ConT ty_name) (map unSigTypeArg ty_args) -- Make sure to call unSigTypeArg here. 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. con_to_type (NormalC _ stys) = mkArrows (map snd stys) result_ty con_to_type (RecC _ vstys) = mkArrows (map thdOf3 vstys) result_ty con_to_type (InfixC t1 _ t2) = mkArrows (map snd [t1, t2]) result_ty con_to_type (ForallC bndrs cxt c) = ForallT bndrs cxt (con_to_type c) #if __GLASGOW_HASKELL__ > 710 con_to_type (GadtC _ stys rty) = mkArrows (map snd stys) rty con_to_type (RecGadtC _ vstys rty) = mkArrows (map thdOf3 vstys) rty #endif #if __GLASGOW_HASKELL__ < 711 fixity = fromMaybe defaultFixity $ reifyFixityInDecs n decs #endif tvbs = freeVariablesWellScoped $ map probablyWrongUnTypeArg ty_args maybeReifyCon _ _ _ _ _ = Nothing mkVarI :: Name -> [Dec] -> Info mkVarI n decs = mkVarITy n decs (maybe (no_type n) snd $ findType n decs) mkVarITy :: Name -> [Dec] -> Type -> Info #if __GLASGOW_HASKELL__ > 710 mkVarITy n _decs ty = VarI n ty Nothing #else mkVarITy n decs ty = VarI n ty Nothing (fromMaybe defaultFixity $ reifyFixityInDecs n decs) #endif findType :: Name -> [Dec] -> Maybe (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 #if __GLASGOW_HASKELL__ >= 711 match_instance d@(InstanceD _ _ ty _) #else match_instance d@(InstanceD _ ty _) #endif | ConT n' <- ty_head ty , n `nameMatches` n' = [d] #if __GLASGOW_HASKELL__ >= 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 #elif __GLASGOW_HASKELL__ > 710 match_instance d@(DataInstD _ n' _ _ _ _) | n `nameMatches` n' = [d] match_instance d@(NewtypeInstD _ n' _ _ _ _) | n `nameMatches` n' = [d] #else match_instance d@(DataInstD _ n' _ _ _) | n `nameMatches` n' = [d] match_instance d@(NewtypeInstD _ n' _ _ _) | n `nameMatches` n' = [d] #endif #if __GLASGOW_HASKELL__ >= 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 #if __GLASGOW_HASKELL__ >= 711 match_instance (InstanceD _ _ _ decs) #else match_instance (InstanceD _ _ decs) #endif = 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 [TyVarBndr] 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 [TyVarBndr] 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 #if __GLASGOW_HASKELL__ > 710 go d@(OpenTypeFamilyD {}) = Just d go d@(DataFamilyD {}) = Just d #endif 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. -> [TyVarBndr] -- ^ 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 all_cls_tvbs cls_cxt | otherwise = id cls_cxt :: Cxt #if __GLASGOW_HASKELL__ < 709 cls_cxt = [ClassP cls_name (map tvbToType cls_tvbs)] #else cls_cxt = [foldl AppT (ConT cls_name) (map tvbToType cls_tvbs)] #endif 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 :: [TyVarBndr] meth_tvbs = deleteFirstsBy ((==) `on` tvName) (freeVariablesWellScoped [meth_ty]) all_cls_tvbs -- Explicitly quantify any kind variables bound by the class, if any. all_cls_tvbs :: [TyVarBndr] all_cls_tvbs = freeVariablesWellScoped $ map tvbToTypeWithSig cls_tvbs stripInstanceDec :: Dec -> Dec #if __GLASGOW_HASKELL__ >= 711 stripInstanceDec (InstanceD over cxt ty _) = InstanceD over cxt ty [] #else stripInstanceDec (InstanceD cxt ty _) = InstanceD cxt ty [] #endif stripInstanceDec dec = dec mkArrows :: [Type] -> Type -> Type mkArrows [] res_ty = res_ty mkArrows (t:ts) res_ty = AppT (AppT ArrowT t) $ mkArrows ts res_ty maybeForallT :: [TyVarBndr] -> Cxt -> Type -> Type maybeForallT tvbs cxt ty | null tvbs && null cxt = ty | ForallT tvbs2 cxt2 ty2 <- ty = ForallT (tvbs ++ tvbs2) (cxt ++ cxt2) ty2 | otherwise = ForallT tvbs cxt ty findCon :: Name -> [Con] -> Maybe (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 #if __GLASGOW_HASKELL__ > 710 GadtC nms _ _ -> gadt_case con nms RecGadtC nms _ _ -> gadt_case con nms #endif _ -> Nothing #if __GLASGOW_HASKELL__ > 710 gadt_case :: Con -> [Name] -> Maybe (Named Con) gadt_case con nms = case find (n `nameMatches`) nms of Just n' -> Just (n', con) Nothing -> Nothing #endif findRecSelector :: Name -> [Con] -> Maybe (Named Type) findRecSelector n = firstMatch match_con where match_con (RecC _ vstys) = firstMatch match_rec_sel vstys #if __GLASGOW_HASKELL__ >= 800 match_con (RecGadtC _ vstys _) = firstMatch match_rec_sel vstys #endif match_con (ForallC _ _ c) = match_con c match_con _ = Nothing match_rec_sel (n', _, ty) | n `nameMatches` n' = Just (n', ty) match_rec_sel _ = Nothing --------------------------------- -- Reifying fixities --------------------------------- -- -- This section allows GHC 7.x to call reifyFixity #if __GLASGOW_HASKELL__ < 711 qReifyFixity :: Quasi m => Name -> m (Maybe Fixity) qReifyFixity name = do info <- qReify name return $ case info of ClassOpI _ _ _ fixity -> Just fixity DataConI _ _ _ fixity -> Just fixity VarI _ _ _ fixity -> Just fixity _ -> Nothing {- | @reifyFixity nm@ attempts to find a fixity declaration for @nm@. For example, if the function @foo@ has the fixity declaration @infixr 7 foo@, then @reifyFixity 'foo@ would return @'Just' ('Fixity' 7 'InfixR')@. If the function @bar@ does not have a fixity declaration, then @reifyFixity 'bar@ returns 'Nothing', so you may assume @bar@ has 'defaultFixity'. -} reifyFixity :: Name -> Q (Maybe Fixity) reifyFixity = qReifyFixity #endif -- | Like 'reifyWithLocals_maybe', but for fixities. Note that a return of -- @Nothing@ might mean that the name is not in scope, or it might mean -- that the name has no assigned fixity. (Use 'reifyWithLocals_maybe' if -- you really need to tell the difference.) reifyFixityWithLocals :: DsMonad q => Name -> q (Maybe Fixity) reifyFixityWithLocals name = qRecover (return . reifyFixityInDecs name =<< localDeclarations) (qReifyFixity name) -------------------------------------- -- Lookuping name value and type names -------------------------------------- -- | Like 'lookupValueName' from Template Haskell, but looks also in 'Names' of -- not-yet-typechecked declarations. To establish this list of not-yet-typechecked -- declarations, use 'withLocalDeclarations'. Returns 'Nothing' if no value -- with the same name can be found. lookupValueNameWithLocals :: DsMonad q => String -> q (Maybe Name) lookupValueNameWithLocals = lookupNameWithLocals False -- | Like 'lookupTypeName' from Template Haskell, but looks also in 'Names' of -- not-yet-typechecked declarations. To establish this list of not-yet-typechecked -- declarations, use 'withLocalDeclarations'. Returns 'Nothing' if no type -- with the same name can be found. lookupTypeNameWithLocals :: DsMonad q => String -> q (Maybe Name) lookupTypeNameWithLocals = lookupNameWithLocals True lookupNameWithLocals :: DsMonad q => Bool -> String -> q (Maybe Name) lookupNameWithLocals ns s = do mb_name <- qLookupName ns s case mb_name of j_name@(Just{}) -> return j_name Nothing -> consult_locals where built_name = mkName s consult_locals = do decs <- localDeclarations let mb_infos = map (reifyInDec built_name decs) decs infos = catMaybes mb_infos return $ firstMatch (if ns then find_type_name else find_value_name) infos -- These functions work over Named Infos so we can avoid performing -- tiresome pattern-matching to retrieve the name associated with each Info. find_type_name, find_value_name :: Named Info -> Maybe Name find_type_name (n, info) = case infoNameSpace info of TcClsName -> Just n VarName -> Nothing DataName -> Nothing find_value_name (n, info) = case infoNameSpace info of VarName -> Just n DataName -> Just n TcClsName -> Nothing -- | Like TH's @lookupValueName@, but if this name is not bound, then we assume -- it is declared in the current module. -- -- Unlike 'mkDataName', this also consults the local declarations in scope when -- determining if the name is currently bound. mkDataNameWithLocals :: DsMonad q => String -> q Name mkDataNameWithLocals = mkNameWith lookupValueNameWithLocals mkNameG_d -- | Like TH's @lookupTypeName@, but if this name is not bound, then we assume -- it is declared in the current module. -- -- Unlike 'mkTypeName', this also consults the local declarations in scope when -- determining if the name is currently bound. mkTypeNameWithLocals :: DsMonad q => String -> q Name mkTypeNameWithLocals = mkNameWith lookupTypeNameWithLocals mkNameG_tc -- | Determines a `Name`'s 'NameSpace'. If the 'NameSpace' is attached to -- the 'Name' itself (i.e., it is unambiguous), then that 'NameSpace' is -- immediately returned. Otherwise, reification is used to lookup up the -- 'NameSpace' (consulting local declarations if necessary). -- -- Note that if a 'Name' lives in two different 'NameSpaces' (which can -- genuinely happen--for instance, @'mkName' \"==\"@, where @==@ is both -- a function and a type family), then this function will simply return -- whichever 'NameSpace' is discovered first via reification. If you wish -- to find a 'Name' in a particular 'NameSpace', use the -- 'lookupValueNameWithLocals' or 'lookupTypeNameWithLocals' functions. reifyNameSpace :: DsMonad q => Name -> q (Maybe NameSpace) reifyNameSpace n@(Name _ nf) = case nf of -- NameGs are simple, as they have a NameSpace attached. NameG ns _ _ -> pure $ Just ns -- For other names, we must use reification to determine what NameSpace -- it lives in (if any). _ -> do mb_info <- reifyWithLocals_maybe n pure $ fmap infoNameSpace mb_info -- | Determine a name's 'NameSpace' from its 'Info'. infoNameSpace :: Info -> NameSpace infoNameSpace info = case info of ClassI{} -> TcClsName TyConI{} -> TcClsName FamilyI{} -> TcClsName PrimTyConI{} -> TcClsName TyVarI{} -> TcClsName ClassOpI{} -> VarName VarI{} -> VarName DataConI{} -> DataName #if __GLASGOW_HASKELL__ >= 801 PatSynI{} -> DataName #endif th-desugar-1.10/Language/Haskell/TH/Desugar/Subst.hs0000644000000000000000000001165607346545000020347 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, substTyVarBndrs, unionSubsts, unionMaybeSubsts, -- * Matching a type template against a type IgnoreKinds(..), matchTy ) where import Data.List 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 #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif -- | 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 tvbs cxt ty) = substTyVarBndrs vars tvbs $ \vars' tvbs' -> do cxt' <- mapM (substTy vars') cxt ty' <- substTy vars' ty return $ DForallT tvbs' cxt' ty' substTy vars (DAppT t1 t2) = DAppT <$> substTy vars t1 <*> substTy vars t2 substTy vars (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 substTyVarBndrs :: Quasi q => DSubst -> [DTyVarBndr] -> (DSubst -> [DTyVarBndr] -> q a) -> q a substTyVarBndrs vars tvbs thing = do (vars', tvbs') <- mapAccumLM substTvb vars tvbs thing vars' tvbs' substTvb :: Quasi q => DSubst -> DTyVarBndr -> q (DSubst, DTyVarBndr) substTvb vars (DPlainTV n) = do new_n <- qNewName (nameBase n) return (M.insert n (DVarT new_n) vars, DPlainTV new_n) substTvb vars (DKindedTV n k) = do new_n <- qNewName (nameBase n) k' <- substTy vars k return (M.insert n (DVarT new_n) vars, DKindedTV new_n 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 = 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.10/Language/Haskell/TH/Desugar/Sweeten.hs0000644000000000000000000005004007346545000020647 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 TemplateHaskell #-} ----------------------------------------------------------------------------- -- | -- Module : Language.Haskell.TH.Desugar.Sweeten -- Copyright : (C) 2014 Richard Eisenberg -- License : BSD-style (see LICENSE) -- Maintainer : Ryan Scott -- Stability : experimental -- Portability : non-portable -- -- The functions in this module convert desugared Template Haskell back into -- proper Template Haskell. -- ---------------------------------------------------------------------------- module Language.Haskell.TH.Desugar.Sweeten ( expToTH, matchToTH, patToTH, decsToTH, decToTH, letDecToTH, typeToTH, conToTH, foreignToTH, pragmaToTH, ruleBndrToTH, clauseToTH, tvbToTH, cxtToTH, predToTH, derivClauseToTH, #if __GLASGOW_HASKELL__ >= 801 patSynDirToTH, #endif typeArgToTH ) where import Prelude hiding (exp) import Control.Arrow import Language.Haskell.TH hiding (cxt) import Language.Haskell.TH.Desugar.AST import Language.Haskell.TH.Desugar.Core (DTypeArg(..)) import Language.Haskell.TH.Desugar.Util import Data.Maybe ( maybeToList, mapMaybe ) 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 (mapMaybe letDecToTH decs) (expToTH exp) expToTH (DSigE exp ty) = SigE (expToTH exp) (typeToTH ty) #if __GLASGOW_HASKELL__ < 709 expToTH (DStaticE _) = error "Static expressions supported only in GHC 7.10+" #else expToTH (DStaticE exp) = StaticE (expToTH exp) #endif #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 pats) = ConP n (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 = concatMap 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) = maybeToList (letDecToTH d) decToTH (DDataD Data cxt n tvbs _mk cons derivings) = #if __GLASGOW_HASKELL__ > 710 [DataD (cxtToTH cxt) n (map tvbToTH tvbs) (fmap typeToTH _mk) (map conToTH cons) (concatMap derivClauseToTH derivings)] #else [DataD (cxtToTH cxt) n (map tvbToTH tvbs) (map conToTH cons) (map derivingToTH derivings)] #endif decToTH (DDataD Newtype cxt n tvbs _mk [con] derivings) = #if __GLASGOW_HASKELL__ > 710 [NewtypeD (cxtToTH cxt) n (map tvbToTH tvbs) (fmap typeToTH _mk) (conToTH con) (concatMap derivClauseToTH derivings)] #else [NewtypeD (cxtToTH cxt) n (map tvbToTH tvbs) (conToTH con) (map derivingToTH derivings)] #endif decToTH (DTySynD n tvbs ty) = [TySynD n (map tvbToTH tvbs) (typeToTH ty)] decToTH (DClassD cxt n tvbs fds decs) = [ClassD (cxtToTH cxt) n (map tvbToTH tvbs) fds (decsToTH decs)] decToTH (DInstanceD over mtvbs _cxt _ty decs) = [instanceDToTH over cxt' ty' decs] where (cxt', ty') = case mtvbs of Nothing -> (_cxt, _ty) Just _tvbs -> #if __GLASGOW_HASKELL__ < 800 || __GLASGOW_HASKELL__ >= 802 ([], DForallT _tvbs _cxt _ty) #else -- See #117 error $ "Explicit foralls in instance declarations " ++ "are broken on GHC 8.0." #endif decToTH (DForeignD f) = [ForeignD (foreignToTH f)] #if __GLASGOW_HASKELL__ > 710 decToTH (DOpenTypeFamilyD (DTypeFamilyHead n tvbs frs ann)) = [OpenTypeFamilyD (TypeFamilyHead n (map tvbToTH tvbs) (frsToTH frs) ann)] #else decToTH (DOpenTypeFamilyD (DTypeFamilyHead n tvbs frs _ann)) = [FamilyD TypeFam n (map tvbToTH tvbs) (frsToTH frs)] #endif decToTH (DDataFamilyD n tvbs mk) = #if __GLASGOW_HASKELL__ > 710 [DataFamilyD n (map tvbToTH tvbs) (fmap typeToTH mk)] #else [FamilyD DataFam n (map tvbToTH tvbs) (fmap typeToTH mk)] #endif decToTH (DDataInstD nd cxt mtvbs lhs mk cons derivings) = let ndc = case (nd, cons) of (Newtype, [con]) -> DNewtypeCon con (Newtype, _) -> error "Newtype that doesn't have only one constructor" (Data, _) -> DDataCons cons in dataInstDecToTH ndc cxt mtvbs lhs mk derivings #if __GLASGOW_HASKELL__ >= 807 decToTH (DTySynInstD eqn) = [TySynInstD (snd $ tySynEqnToTH eqn)] #else decToTH (DTySynInstD eqn) = let (n, eqn') = tySynEqnToTH eqn in [TySynInstD n eqn'] #endif #if __GLASGOW_HASKELL__ > 710 decToTH (DClosedTypeFamilyD (DTypeFamilyHead n tvbs frs ann) eqns) = [ClosedTypeFamilyD (TypeFamilyHead n (map tvbToTH tvbs) (frsToTH frs) ann) (map (snd . tySynEqnToTH) eqns) ] #else decToTH (DClosedTypeFamilyD (DTypeFamilyHead n tvbs frs _ann) eqns) = [ClosedTypeFamilyD n (map tvbToTH tvbs) (frsToTH frs) (map (snd . tySynEqnToTH) eqns)] #endif decToTH (DRoleAnnotD n roles) = [RoleAnnotD n roles] decToTH (DStandaloneDerivD mds mtvbs _cxt _ty) = [standaloneDerivDToTH mds cxt' ty'] where (cxt', ty') = case mtvbs of Nothing -> (_cxt, _ty) Just _tvbs -> #if __GLASGOW_HASKELL__ < 710 || __GLASGOW_HASKELL__ >= 802 ([], DForallT _tvbs _cxt _ty) #else -- See #117 error $ "Explicit foralls in standalone deriving declarations " ++ "are broken on GHC 7.10 and 8.0." #endif #if __GLASGOW_HASKELL__ < 709 decToTH (DDefaultSigD {}) = error "Default method signatures supported only in GHC 7.10+" #else decToTH (DDefaultSigD n ty) = [DefaultSigD n (typeToTH ty)] #endif #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 dec | DPatSynD{} <- dec = patSynErr | DPatSynSigD{} <- dec = patSynErr where patSynErr = error "Pattern synonyms supported only in GHC 8.2+" #endif decToTH _ = error "Newtype declaration without exactly 1 constructor." -- | 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 [DTyVarBndr] -> 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)] #elif __GLASGOW_HASKELL__ > 710 [NewtypeInstD (cxtToTH cxt) _n _lhs_args (fmap typeToTH _mk) (conToTH con) (concatMap derivClauseToTH derivings)] #else [NewtypeInstD (cxtToTH cxt) _n _lhs_args (conToTH con) (map derivingToTH 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)] #elif __GLASGOW_HASKELL__ > 710 [DataInstD (cxtToTH cxt) _n _lhs_args (fmap typeToTH _mk) (map conToTH cons) (concatMap derivClauseToTH derivings)] #else [DataInstD (cxtToTH cxt) _n _lhs_args (map conToTH cons) (map derivingToTH 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' #if __GLASGOW_HASKELL__ > 710 frsToTH :: DFamilyResultSig -> FamilyResultSig frsToTH DNoSig = NoSig frsToTH (DKindSig k) = KindSig (typeToTH k) frsToTH (DTyVarSig tvb) = TyVarSig (tvbToTH tvb) #else frsToTH :: DFamilyResultSig -> Maybe Kind frsToTH DNoSig = Nothing frsToTH (DKindSig k) = Just (typeToTH k) frsToTH (DTyVarSig (DPlainTV _)) = Nothing frsToTH (DTyVarSig (DKindedTV _ k)) = Just (typeToTH k) #endif #if __GLASGOW_HASKELL__ <= 710 derivingToTH :: DDerivClause -> Name derivingToTH (DDerivClause _ [DConT nm]) = nm derivingToTH p = error ("Template Haskell in GHC < 8.0 only allows simple derivings: " ++ show p) #endif -- | Note: This can currently only return a 'Nothing' if the 'DLetDec' is a pragma which -- is not supported by the GHC version being used. letDecToTH :: DLetDec -> Maybe Dec letDecToTH (DFunD name clauses) = Just $ FunD name (map clauseToTH clauses) letDecToTH (DValD pat exp) = Just $ ValD (patToTH pat) (NormalB (expToTH exp)) [] letDecToTH (DSigD name ty) = Just $ SigD name (typeToTH ty) letDecToTH (DInfixD f name) = Just $ InfixD f name letDecToTH (DPragmaD prag) = fmap PragmaD (pragmaToTH prag) conToTH :: DCon -> Con #if __GLASGOW_HASKELL__ > 710 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) #else conToTH (DCon [] [] n (DNormalC True [sty1, sty2]) _) = InfixC ((bangToStrict *** typeToTH) sty1) n ((bangToStrict *** typeToTH) sty2) -- Note: it's possible that someone could pass in a DNormalC value that -- erroneously claims that it's declared infix (e.g., if has more than two -- fields), but we will fall back on NormalC in such a scenario. conToTH (DCon [] [] n (DNormalC _ stys) _) = NormalC n (map (bangToStrict *** typeToTH) stys) conToTH (DCon [] [] n (DRecC vstys) _) = RecC n (map (\(v,b,t) -> (v,bangToStrict b,typeToTH t)) vstys) #endif #if __GLASGOW_HASKELL__ > 710 -- 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) #else -- On GHCs earlier than 8.0, we must be careful, since the only time ForallC is -- used is when there are either: -- -- 1. Any existentially quantified type variables -- 2. A constructor context -- -- If neither of these conditions hold, then we needn't put a ForallC at the -- front, since it would be completely pointless (you'd end up with things like -- @data Foo = forall. MkFoo@!). conToTH (DCon tvbs cxt n fields rty) | null ex_tvbs && null cxt = con' | otherwise = ForallC ex_tvbs (cxtToTH cxt) con' where -- Fortunately, on old GHCs, it's especially easy to distinguish between -- universally and existentially quantified type variables. When desugaring -- a ForallC, we just stick all of the universals (from the datatype -- definition) at the front of the @forall@. Therefore, it suffices to -- count the number of type variables in the return type and drop that many -- variables from the @forall@ in the ForallC, leaving only the -- existentials. ex_tvbs :: [TyVarBndr] ex_tvbs = map tvbToTH $ drop num_univ_tvs tvbs num_univ_tvs :: Int num_univ_tvs = go rty where go :: DType -> Int go (DAppT t1 t2) = go t1 + go t2 go (DSigT t _) = go t go (DVarT {}) = 1 go (DConT {}) = 0 go DArrowT = 0 go (DLitT {}) = 0 -- These won't show up on pre-8.0 GHCs go (DForallT {}) = error "`forall` type used in GADT return type" go DWildCardT = 0 go (DAppKindT {}) = 0 con' :: Con con' = conToTH $ DCon [] [] n fields rty #endif instanceDToTH :: Maybe Overlap -> DCxt -> DType -> [DDec] -> Dec instanceDToTH _over cxt ty decs = InstanceD #if __GLASGOW_HASKELL__ >= 800 _over #endif (cxtToTH cxt) (typeToTH ty) (decsToTH decs) standaloneDerivDToTH :: Maybe DDerivStrategy -> DCxt -> DType -> Dec #if __GLASGOW_HASKELL__ >= 710 standaloneDerivDToTH _mds cxt ty = StandaloneDerivD #if __GLASGOW_HASKELL__ >= 802 (fmap derivStrategyToTH _mds) #endif (cxtToTH cxt) (typeToTH ty) #else standaloneDerivDToTH _ _ _ = error "Standalone deriving supported only in GHC 7.10+" #endif foreignToTH :: DForeign -> Foreign foreignToTH (DImportF cc safety str n ty) = ImportF cc safety str n (typeToTH ty) foreignToTH (DExportF cc str n ty) = ExportF cc str n (typeToTH ty) pragmaToTH :: DPragma -> Maybe Pragma pragmaToTH (DInlineP n inl rm phases) = Just $ InlineP n inl rm phases pragmaToTH (DSpecialiseP n ty m_inl phases) = Just $ SpecialiseP n (typeToTH ty) m_inl phases pragmaToTH (DSpecialiseInstP ty) = Just $ SpecialiseInstP (typeToTH ty) #if __GLASGOW_HASKELL__ >= 807 pragmaToTH (DRuleP str mtvbs rbs lhs rhs phases) = Just $ RuleP str (fmap (fmap tvbToTH) mtvbs) (map ruleBndrToTH rbs) (expToTH lhs) (expToTH rhs) phases #else pragmaToTH (DRuleP str _ rbs lhs rhs phases) = Just $ RuleP str (map ruleBndrToTH rbs) (expToTH lhs) (expToTH rhs) phases #endif pragmaToTH (DAnnP target exp) = Just $ AnnP target (expToTH exp) #if __GLASGOW_HASKELL__ < 709 pragmaToTH (DLineP {}) = Nothing #else pragmaToTH (DLineP n str) = Just $ LineP n str #endif #if __GLASGOW_HASKELL__ < 801 pragmaToTH (DCompleteP {}) = Nothing #else pragmaToTH (DCompleteP cls mty) = Just $ CompleteP cls mty #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 typeToTH (DForallT tvbs cxt ty) = ForallT (map tvbToTH tvbs) (map predToTH cxt) (typeToTH ty) typeToTH (DAppT t1 t2) = AppT (typeToTH t1) (typeToTH t2) typeToTH (DSigT ty ki) = SigT (typeToTH ty) (typeToTH ki) typeToTH (DVarT n) = VarT n typeToTH (DConT n) = tyconToTH n typeToTH DArrowT = ArrowT typeToTH (DLitT lit) = LitT lit #if __GLASGOW_HASKELL__ > 710 typeToTH DWildCardT = WildCardT #else typeToTH DWildCardT = error "Wildcards supported only in GHC 8.0+" #endif #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 -> TyVarBndr tvbToTH (DPlainTV n) = PlainTV n tvbToTH (DKindedTV n k) = KindedTV n (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 #if __GLASGOW_HASKELL__ < 709 predToTH = go [] where go acc (DAppT p t) = go (typeToTH t : acc) p -- In the event that we're on a version of Template Haskell without support -- for kind applications, we will simply drop the applied kind. go acc (DAppKindT t _) = go acc t go acc (DSigT p _) = go acc p -- this shouldn't happen. go acc (DConT n) | nameBase n == "~" , [t1, t2] <- acc = EqualP t1 t2 | otherwise = ClassP n acc go _ (DVarT _) = error "Template Haskell in GHC <= 7.8 does not support variable constraints." go _ DWildCardT = error "Wildcards supported only in GHC 8.0+" go _ (DForallT {}) = error "Quantified constraints supported only in GHC 8.6+" go _ DArrowT = error "(->) spotted at head of a constraint" go _ (DLitT {}) = error "Type-level literal spotted at head of a constraint" #else 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 #if __GLASGOW_HASKELL__ > 710 predToTH DWildCardT = WildCardT #else predToTH DWildCardT = error "Wildcards supported only in GHC 8.0+" #endif #if __GLASGOW_HASKELL__ >= 805 predToTH (DForallT tvbs cxt p) = ForallT (map tvbToTH tvbs) (map predToTH cxt) (predToTH p) #else predToTH (DForallT {}) = 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 #endif tyconToTH :: Name -> Type tyconToTH n | n == ''(->) = ArrowT -- Work around Trac #14888 | n == ''[] = ListT #if __GLASGOW_HASKELL__ >= 709 | n == ''(~) = EqualityT #endif | n == '[] = PromotedNilT | n == '(:) = PromotedConsT | Just deg <- tupleNameDegree_maybe n = if isDataName n #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) #if __GLASGOW_HASKELL__ <= 710 -- | Convert a 'Bang' to a 'Strict' bangToStrict :: Bang -> Strict bangToStrict (Bang SourceUnpack _) = Unpacked bangToStrict (Bang _ SourceStrict) = IsStrict bangToStrict (Bang _ _) = NotStrict #endif th-desugar-1.10/Language/Haskell/TH/Desugar/Util.hs0000644000000000000000000004300707346545000020157 0ustar0000000000000000{- Language/Haskell/TH/Desugar/Util.hs (c) Richard Eisenberg 2013 rae@cs.brynmawr.edu Utility functions for th-desugar package. -} {-# LANGUAGE CPP, DeriveDataTypeable, RankNTypes, ScopedTypeVariables, TupleSections #-} #if __GLASGOW_HASKELL__ >= 800 {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE TypeApplications #-} #endif 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, firstMatch, unboxedSumDegree_maybe, unboxedSumNameDegree_maybe, tupleDegree_maybe, tupleNameDegree_maybe, unboxedTupleDegree_maybe, unboxedTupleNameDegree_maybe, splitTuple_maybe, topEverywhereM, isInfixDataCon, isTypeKindName, typeKindName, mkExtraKindBindersGeneric, unravelType, unSigType, unfoldType, TypeArg(..), applyType, filterTANormals, unSigTypeArg, probablyWrongUnTypeArg #if __GLASGOW_HASKELL__ >= 800 , bindIP #endif ) where import Prelude hiding (mapM, foldl, concatMap, any) import Language.Haskell.TH hiding ( cxt ) import Language.Haskell.TH.Datatype (tvName) import qualified Language.Haskell.TH.Desugar.OSet as OS import Language.Haskell.TH.Desugar.OSet (OSet) import Language.Haskell.TH.Syntax import Control.Monad ( replicateM ) import qualified Control.Monad.Fail as Fail import Data.Foldable import Data.Generics hiding ( Fixity ) import Data.Traversable import Data.Maybe #if __GLASGOW_HASKELL__ < 710 import Data.Monoid #endif #if __GLASGOW_HASKELL__ >= 800 import qualified Data.Kind as Kind import GHC.Classes ( IP ) import Unsafe.Coerce ( unsafeCoerce ) #endif ---------------------------------------- -- TH manipulations ---------------------------------------- -- | Like newName, but even more unique (unique across different splices), -- and with unique @nameBase@s. Precondition: the string is a valid Haskell -- alphanumeric identifier (could be upper- or lower-case). newUniqueName :: Quasi q => String -> q Name newUniqueName str = do n <- qNewName str qNewName $ show n -- | @mkNameWith lookup_fun mkName_fun str@ looks up the exact 'Name' of @str@ -- using the function @lookup_fun@. If it finds 'Just' the 'Name', meaning -- that it is bound in the current scope, then it is returned. If it finds -- 'Nothing', it assumes that @str@ is declared in the current module, and -- uses @mkName_fun@ to construct the appropriate 'Name' to return. mkNameWith :: Quasi q => (String -> q (Maybe Name)) -> (String -> String -> String -> Name) -> String -> q Name mkNameWith lookup_fun mkName_fun str = do m_name <- lookup_fun str case m_name of Just name -> return name Nothing -> do Loc { loc_package = pkg, loc_module = modu } <- qLocation return $ mkName_fun pkg modu str -- | Like TH's @lookupTypeName@, but if this name is not bound, then we assume -- it is declared in the current module. mkTypeName :: Quasi q => String -> q Name mkTypeName = mkNameWith (qLookupName True) mkNameG_tc -- | Like TH's @lookupDataName@, but if this name is not bound, then we assume -- it is declared in the current module. mkDataName :: Quasi q => String -> q Name mkDataName = mkNameWith (qLookupName False) mkNameG_d -- | Is this name a data constructor name? A 'False' answer means "unsure". isDataName :: Name -> Bool isDataName (Name _ (NameG DataName _ _)) = True isDataName _ = False -- | Extracts the name out of a variable pattern, or returns @Nothing@ stripVarP_maybe :: Pat -> Maybe Name stripVarP_maybe (VarP name) = Just name stripVarP_maybe _ = Nothing -- | Extracts the name out of a @PlainTV@, or returns @Nothing@ stripPlainTV_maybe :: TyVarBndr -> Maybe Name stripPlainTV_maybe (PlainTV n) = Just n stripPlainTV_maybe _ = 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 -> Type tvbToType = VarT . tvName -- | Convert a 'TyVarBndr' into a 'Type', preserving the kind signature -- (if it has one). tvbToTypeWithSig :: TyVarBndr -> Type tvbToTypeWithSig (PlainTV n) = VarT n tvbToTypeWithSig (KindedTV 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 -> 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 -- | Like 'mkExtraDKindBinders', but parameterized to allow working over both -- 'Kind'/'TyVarBndr' and 'DKind'/'DTyVarBndr'. mkExtraKindBindersGeneric :: Quasi q => (kind -> ([tyVarBndr], [pred], [kind], kind)) -> (Name -> kind -> tyVarBndr) -> kind -> q [tyVarBndr] mkExtraKindBindersGeneric unravel mkKindedTV k = do let (_, _, args, _) = unravel k names <- replicateM (length args) (qNewName "a") return (zipWith mkKindedTV names args) -- | Decompose a function 'Type' into its type variables, its context, its -- argument types, and its result type. unravelType :: Type -> ([TyVarBndr], [Pred], [Type], Type) unravelType (ForallT tvbs cxt ty) = let (tvbs', cxt', tys, res) = unravelType ty in (tvbs ++ tvbs', cxt ++ cxt', tys, res) unravelType (AppT (AppT ArrowT t1) t2) = let (tvbs, cxt, tys, res) = unravelType t2 in (tvbs, cxt, t1 : tys, res) unravelType t = ([], [], [], 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) #if __GLASGOW_HASKELL__ >= 800 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) #endif #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 #if __GLASGOW_HASKELL__ >= 710 unSigPred = unSigType #else unSigPred (ClassP n tys) = ClassP n (map unSigType tys) unSigPred (EqualP t1 t2) = EqualP (unSigType t1) (unSigType t2) #endif -- | 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 #if __GLASGOW_HASKELL__ >= 800 go acc (ParensT ty) = go acc ty #endif #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, Typeable, 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 -- | Remove all of the explicit kind signatures from a 'TypeArg'. unSigTypeArg :: TypeArg -> TypeArg unSigTypeArg (TANormal t) = TANormal (unSigType t) unSigTypeArg (TyArg k) = TyArg (unSigType k) -- | 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 _ 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 ---------------------------------------- #if __GLASGOW_HASKELL__ >= 800 -- 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 #endif -- like GHC's splitAtList :: [a] -> [b] -> ([b], [b]) splitAtList [] x = ([], x) splitAtList (_ : t) (x : xs) = let (as, bs) = splitAtList t xs in (x : as, bs) splitAtList (_ : _) [] = ([], []) thdOf3 :: (a,b,c) -> c thdOf3 (_,_,c) = c thirdOf3 :: (a -> b) -> (c, d, a) -> (c, d, b) thirdOf3 f (c, d, a) = (c, d, f a) -- lift concatMap into a monad -- could this be more efficient? -- | Concatenate the result of a @mapM@ concatMapM :: (Monad monad, Monoid monoid, Traversable t) => (a -> monad monoid) -> t a -> monad monoid concatMapM fn list = do bss <- mapM fn list return $ fold bss -- like GHC's -- | Monadic version of mapAccumL mapAccumLM :: Monad m => (acc -> x -> m (acc, y)) -- ^ combining function -> acc -- ^ initial state -> [x] -- ^ inputs -> m (acc, [y]) -- ^ final state, outputs mapAccumLM _ s [] = return (s, []) mapAccumLM f s (x:xs) = do (s1, x') <- f s x (s2, xs') <- mapAccumLM f s1 xs return (s2, x' : xs') -- like GHC's mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b] mapMaybeM _ [] = return [] mapMaybeM f (x:xs) = do y <- f x ys <- mapMaybeM f xs return $ case y of Nothing -> ys Just z -> z : ys expectJustM :: Fail.MonadFail m => String -> Maybe a -> m a expectJustM _ (Just x) = return x expectJustM err Nothing = Fail.fail err firstMatch :: (a -> Maybe b) -> [a] -> Maybe b firstMatch f xs = listToMaybe $ mapMaybe f xs -- | Semi-shallow version of 'everywhereM' - does not recurse into children of nodes of type @a@ (only applies the handler to them). -- -- >>> topEverywhereM (pure . fmap (*10) :: [Integer] -> Identity [Integer]) ([1,2,3] :: [Integer], "foo" :: String) -- Identity ([10,20,30],"foo") -- -- >>> everywhereM (mkM (pure . fmap (*10) :: [Integer] -> Identity [Integer])) ([1,2,3] :: [Integer], "foo" :: String) -- Identity ([10,200,3000],"foo") topEverywhereM :: (Typeable a, Data b, Monad m) => (a -> m a) -> b -> m b topEverywhereM handler = gmapM (topEverywhereM handler) `extM` handler -- Checks if a String names a valid Haskell infix data constructor -- (i.e., does it begin with a colon?). isInfixDataCon :: String -> Bool isInfixDataCon (':':_) = True isInfixDataCon _ = False -- | Returns 'True' if the argument 'Name' is that of 'Kind.Type' -- (or @*@ or 'Kind.★', to support older GHCs). isTypeKindName :: Name -> Bool isTypeKindName n = n == typeKindName #if __GLASGOW_HASKELL__ < 805 || n == starKindName || n == uniStarKindName #endif -- | The 'Name' of: -- -- 1. The kind 'Kind.Type', on GHC 8.0 or later. -- 2. The kind @*@ on older GHCs. typeKindName :: Name #if __GLASGOW_HASKELL__ >= 800 typeKindName = ''Kind.Type #else typeKindName = starKindName #endif #if __GLASGOW_HASKELL__ < 805 -- | The 'Name' of the kind @*@. starKindName :: Name #if __GLASGOW_HASKELL__ >= 800 starKindName = ''(Kind.*) #else starKindName = mkNameG_tc "ghc-prim" "GHC.Prim" "*" #endif -- | The 'Name' of: -- -- 1. The kind 'Kind.★', on GHC 8.0 or later. -- 2. The kind @*@ on older GHCs. uniStarKindName :: Name #if __GLASGOW_HASKELL__ >= 800 uniStarKindName = ''(Kind.★) #else uniStarKindName = starKindName #endif #endif th-desugar-1.10/README.md0000755000000000000000000000746107346545000013161 0ustar0000000000000000`th-desugar` Package ==================== [![Hackage](https://img.shields.io/hackage/v/th-desugar.svg)](http://hackage.haskell.org/package/th-desugar) [![Build Status](https://travis-ci.org/goldfirere/th-desugar.svg?branch=master)](https://travis-ci.org/goldfirere/th-desugar) 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. Known limitations ----------------- `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) th-desugar-1.10/Setup.hs0000644000000000000000000000005607346545000013324 0ustar0000000000000000import Distribution.Simple main = defaultMain th-desugar-1.10/Test/0000755000000000000000000000000007346545000012606 5ustar0000000000000000th-desugar-1.10/Test/Dec.hs0000644000000000000000000000241707346545000013641 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 #-} #if __GLASGOW_HASKELL__ >= 710 {-# LANGUAGE DeriveAnyClass #-} #endif {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-name-shadowing #-} #if __GLASGOW_HASKELL__ >= 711 {-# OPTIONS_GHC -Wno-redundant-constraints #-} #endif 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) #if __GLASGOW_HASKELL__ >= 709 $(S.dectest11) #endif $(S.dectest12) $(S.dectest13) $(S.dectest14) #if __GLASGOW_HASKELL__ >= 710 $(S.dectest15) #endif #if __GLASGOW_HASKELL__ < 800 || __GLASGOW_HASKELL__ >= 802 $(S.dectest16) #endif #if __GLASGOW_HASKELL__ >= 802 $(S.dectest17) #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.10/Test/DsDec.hs0000644000000000000000000000562607346545000014135 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 #-} #if __GLASGOW_HASKELL__ >= 710 {-# LANGUAGE DeriveAnyClass #-} #endif #if __GLASGOW_HASKELL__ >= 801 {-# LANGUAGE DerivingStrategies #-} #endif {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-incomplete-patterns -fno-warn-name-shadowing #-} #if __GLASGOW_HASKELL__ >= 711 {-# OPTIONS_GHC -Wno-redundant-constraints #-} #endif 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 import Data.Maybe( mapMaybe ) $(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) #if __GLASGOW_HASKELL__ >= 709 $(dsDecSplice S.dectest11) $(dsDecSplice S.standalone_deriving_test) #endif #if __GLASGOW_HASKELL__ >= 801 $(dsDecSplice S.deriv_strat_test) #endif $(dsDecSplice S.dectest12) $(dsDecSplice S.dectest13) $(dsDecSplice S.dectest14) #if __GLASGOW_HASKELL__ >= 710 $(dsDecSplice S.dectest15) #endif #if __GLASGOW_HASKELL__ < 800 || __GLASGOW_HASKELL__ >= 802 $(return $ decsToTH [S.ds_dectest16]) #endif #if __GLASGOW_HASKELL__ >= 802 $(return $ decsToTH [S.ds_dectest17]) #endif $(do decs <- S.rec_sel_test withLocalDeclarations decs $ do [DDataD nd [] name [DPlainTV tvbName] k cons []] <- dsDecs decs let arg_ty = (DConT name) `DAppT` (DVarT tvbName) recsels <- getRecordSelectors arg_ty 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 ++ mapMaybe letDecToTH recsels)) th-desugar-1.10/Test/Run.hs0000644000000000000000000005752707346545000013726 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 #-} {-# OPTIONS -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns -fno-warn-unused-matches -fno-warn-type-defaults -fno-warn-missing-signatures -fno-warn-unused-do-bind -fno-warn-missing-fields #-} #if __GLASGOW_HASKELL__ >= 711 {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-partial-type-signatures -Wno-redundant-constraints #-} #endif #if __GLASGOW_HASKELL__ >= 805 {-# LANGUAGE DerivingVia #-} {-# LANGUAGE QuantifiedConstraints #-} #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 Language.Haskell.TH.Desugar import qualified Language.Haskell.TH.Desugar.OSet as OS import Language.Haskell.TH.Desugar.Expand ( expandUnsoundly ) import Language.Haskell.TH import qualified Language.Haskell.TH.Syntax as Syn ( lift ) import Control.Monad #if __GLASGOW_HASKELL__ < 709 import Control.Applicative #endif import Data.Function ( on ) import qualified Data.Map as M import Data.Proxy -- | -- 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) #if __GLASGOW_HASKELL__ >= 709 , "pred" ~: $test37_pred @=? $(dsSplice test37_pred) , "pred2" ~: $test38_pred2 @=? $(dsSplice test38_pred2) , "eq" ~: $test39_eq @=? $(dsSplice test39_eq) #endif #if __GLASGOW_HASKELL__ >= 711 , "wildcard" ~: $test40_wildcards@=? $(dsSplice test40_wildcards) #endif #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 ] 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) #if __GLASGOW_HASKELL__ >= 709 test_e9a = $test_expand9 -- requires GHC #9262 test_e9b = $(test_expand9 >>= dsExp >>= expand >>= return . expToTH) #endif 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 #if __GLASGOW_HASKELL__ >= 709 , hasSameType test_e9a test_e9b #endif ] 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 #if __GLASGOW_HASKELL__ < 709 (True, _ `DAppT` DVarT _) -> [| True |] #else (True, _ `DAppT` DSigT (DVarT _) (DVarT _)) -> [| True |] #endif _ -> do runIO $ do putStrLn "Failed bug8884 test:" putStrLn $ show dinfo [| False |] ) flatten_dvald :: Bool flatten_dvald = let s1 = $(flatten_dvald_test) s2 = $(do exp <- flatten_dvald_test DLetE ddecs dexp <- dsExp exp flattened <- fmap concat $ mapM flattenDValD ddecs return $ expToTH $ DLetE flattened dexp ) 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 #if __GLASGOW_HASKELL__ >= 709 test_standalone_deriving = (MkBlarggie 5 'x') == (MkBlarggie 5 'x') #else test_standalone_deriving = True #endif 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 [DPlainTV f] [] (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 [DKindedTV a (DConT ''Constant `DAppT` DConT ''Int `DAppT` DVarT k)] [] (DVarT a) expected_ty = DForallT [DKindedTV a (DVarT k)] [] (DVarT a) expanded_ty <- expandType orig_ty expected_ty `eqTHSplice` expanded_ty) test_getDataD_kind_sig :: Bool test_getDataD_kind_sig = #if __GLASGOW_HASKELL__ >= 800 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)) |]) #else True -- DataD didn't have the ability to store kind signatures prior to GHC 8.0 #endif test_t102 :: Bool test_t102 = $(do decs <- [d| data Foo x where MkFoo :: forall a. { unFoo :: a } -> Foo a |] withLocalDeclarations decs $ do [DDataD _ _ foo [DPlainTV x] _ cons _] <- dsDecs decs recs <- getRecordSelectors (DConT foo `DAppT` DVarT x) cons (length recs `div` 2) `eqTHSplice` 1) test_t103 :: Bool test_t103 = #if __GLASGOW_HASKELL__ >= 800 $(do decs <- [d| data P (a :: k) = MkP |] [DDataD _ _ _ _ _ [DCon tvbs _ _ _ _] _] <- dsDecs decs case tvbs of [DPlainTV k, DKindedTV a (DVarT k')] | nameBase k == "k" , nameBase a == "a" , k == k' -> [| True |] | otherwise -> [| False |]) #else True -- No explicit kind variable binders prior to GHC 8.0 #endif test_t112 :: [Bool] test_t112 = $(do a <- newName "a" b <- newName "b" let [aVar, bVar] = map DVarT [a, b] [aTvb, bTvb] = map DPlainTV [a, b] let fvsABExpected = [aTvb, bTvb] fvsABActual = toposortTyVarsOf [aVar, bVar] fvsBAExpected = [bTvb, aTvb] fvsBAActual = toposortTyVarsOf [bVar, aVar] eqAB = fvsABExpected `eqTH` fvsABActual eqBA = fvsBAExpected `eqTH` fvsBAActual [| [eqAB, eqBA] |]) -- 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 = DForallT [] [DForallT [] [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 [DKindedTV c (DVarT a)] [] (DVarT c) -- forall a (c :: a). c ty3 = DForallT [DPlainTV a, DKindedTV c (DVarT a)] [] (DVarT c) -- forall (a :: k) k (b :: k). Proxy b -> Proxy a ty4 = DForallT [ DKindedTV a (DVarT k) , DPlainTV k , DKindedTV b (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 $ 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) `eq` Just (M.singleton a (DConT ''Bool)) , matchTy NoIgnore (DVarT a) (DVarT a) `eq` Just (M.singleton a (DVarT a)) , matchTy NoIgnore (DVarT a) (DVarT b) `eq` Just (M.singleton a (DVarT b)) , matchTy NoIgnore (DConT ''Either `DAppT` DVarT a `DAppT` DVarT b) (DConT ''Either `DAppT` DConT ''Int `DAppT` DConT ''Bool) `eq` 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) `eq` Just (M.singleton a (DConT ''Int)) , matchTy NoIgnore (DConT ''Either `DAppT` DVarT a `DAppT` DVarT a) (DConT ''Either `DAppT` DConT ''Int `DAppT` DConT ''Bool) `eq` Nothing , matchTy NoIgnore (DConT ''Int) (DConT ''Bool) `eq` Nothing , matchTy NoIgnore (DConT ''Int) (DConT ''Int) `eq` Just M.empty , matchTy NoIgnore (DConT ''Int) (DVarT a) `eq` Nothing , matchTy NoIgnore (DVarT a `DSigT` DConT ''Bool) (DConT ''Int) `eq` Nothing , matchTy YesIgnore (DVarT a `DSigT` DConT ''Bool) (DConT ''Int) `eq` Just (M.singleton a (DConT ''Int)) ] where a = mkName "a" b = mkName "b" -- GHC 7.6 uses containers-0.5.0.0 which doesn't have a good Data instance -- for Map. So we have to convert to lists before comparing. eq = (==) `on` fmap M.toList -- 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 "collects GADT record selectors correctly" $ test_t102 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..] zipWithM (\b n -> it ("computes free variables correctly " ++ show n) b) test_fvs [1..] -- 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..] fromHUnitTest tests th-desugar-1.10/Test/Splices.hs0000644000000000000000000005401407346545000014550 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 #-} #if __GLASGOW_HASKELL__ >= 711 {-# LANGUAGE TypeApplications #-} #endif #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 {-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-type-defaults -fno-warn-name-shadowing #-} module Splices where import Data.List import Data.Char import GHC.Exts import GHC.TypeLits import Language.Haskell.TH import Language.Haskell.TH.Desugar import Language.Haskell.TH.Syntax (Quasi) import Data.Generics #if __GLASGOW_HASKELL__ >= 803 import GHC.OverloadedLabels ( IsLabel(..) ) #endif 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 #if __GLASGOW_HASKELL__ < 711 eqTHSplice (infoDs, rolesDs) (infoReg, rolesReg) #else fixityDs <- reifyFixity dsName fixityReg <- reifyFixity regName eqTHSplice (infoDs, rolesDs, fixityDs) (infoReg, rolesReg, fixityReg) #endif unqualify :: Data a => a -> a unqualify = everywhere (mkT (mkName . nameBase)) assumeStarT :: Data a => a -> a #if __GLASGOW_HASKELL__ < 709 assumeStarT = id #else assumeStarT = everywhere (mkT go) where go :: TyVarBndr -> TyVarBndr go (PlainTV n) = KindedTV n StarT go (KindedTV n k) = KindedTV n (assumeStarT k) #endif dropTrailing0s :: Data a => a -> a dropTrailing0s = everywhere (mkT (mkName . frob . nameBase)) where frob str | head str == 'r' = str | head str == 'R' = str | otherwise = dropWhileEnd isDigit str 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" ; elemIndex 'o' fool ; x <- 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 :: * -> Constraint) -> () f _ = () in [f (Proxy :: Proxy Eq), f (Proxy :: Proxy Show)] |] test32_tylit = [| let f :: Proxy (a :: Symbol) -> Proxy (b :: Nat) -> () f _ _ = () in f (Proxy :: Proxy "Hi there!") (Proxy :: Proxy 10) |] test33_tvbs = [| let f :: forall a (b :: * -> *). Monad b => a -> b a f = return in [f 1, f 2] :: [Maybe Int] |] test34_let_as = [| let a@(Just x) = Just 5 in show x ++ 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 |] #if __GLASGOW_HASKELL__ >= 711 test40_wildcards = [| let f :: (Show a, _) => a -> a -> _ f x y = if x == y then show x else "bad" in f True False :: String |] #endif #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 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 |] type family PolyTF (x :: k) :: * where PolyTF (x :: *) = Bool test_expand7 = [| let f :: PolyTF Int -> () f True = () in f |] test_expand8 = [| let f :: PolyTF IO -> () f True = () in f |] #if __GLASGOW_HASKELL__ >= 709 test_expand9 = [| let f :: TFExpand (Maybe (IO a)) -> IO () f actions = sequence_ actions in f |] #endif #if __GLASGOW_HASKELL__ >= 709 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 ()) |] #endif #if __GLASGOW_HASKELL__ < 709 dec_test_nums = [1..10] :: [Int] #else dec_test_nums = [1..11] :: [Int] #endif 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 :: * -> *) m2 | m1 -> m2 where lift :: forall a. m1 a -> m2 a type M2 m1 :: * -> * |] dectest7 = [d| type family Dec7 a (b :: *) (c :: Bool) :: * -> * |] dectest8 = [d| type family Dec8 a |] dectest9 = [d| data family Dec9 a (b :: * -> *) :: * -> * |] dectest10 = [d| type family Dec10 a :: * -> * where Dec10 Int = Maybe Dec10 Bool = [] |] data Blarggie a = MkBlarggie Int a #if __GLASGOW_HASKELL__ >= 709 dectest11 = [d| class Dec11 a where meth13 :: a -> a -> Bool default meth13 :: Eq a => a -> a -> Bool meth13 = (==) |] standalone_deriving_test = [d| deriving instance Eq a => Eq (Blarggie a) |] #endif #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 :: (* -> Constraint) -> * 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_dectest16 = DInstanceD Nothing (Just [DPlainTV (mkName "a")]) [] (DConT ''ExCls `DAppT` (DConT ''ExData1 `DAppT` DVarT (mkName "a"))) [] dectest16 :: Q [Dec] dectest16 = return [ InstanceD #if __GLASGOW_HASKELL__ >= 800 Nothing #endif [] (ForallT [PlainTV (mkName "a")] [] (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"))) #if __GLASGOW_HASKELL__ >= 710 dectest17 :: Q [Dec] dectest17 = return [ StandaloneDerivD #if __GLASGOW_HASKELL__ >= 802 Nothing #endif [] (ForallT [PlainTV (mkName "a")] [] (ConT ''ExCls `AppT` (ConT ''ExData2 `AppT` VarT (mkName "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 :: * -> *) :: * -> * #if __GLASGOW_HASKELL__ >= 800 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 |] #else -- TH-quoted data family instances with GADT syntax are horribly broken on GHC 7.10 -- and older, so we opt to use non-GADT syntax on older GHCs so we can at least -- test *something*. imp_inst_test2 = [d| data instance Dec9 Int Maybe a = MkIMB [a] | forall b. MkIMB2 (b a) |] imp_inst_test3 = [d| newtype instance Dec9 Bool m x = MkBMX (m x) |] #endif type family Dec8 a imp_inst_test4 = [d| type instance Dec8 Int = Bool |] -- used for bug8884 test type family Poly (a :: k) :: * type instance Poly x = Int flatten_dvald_test = [| let (a,b,c) = ("foo", 4, False) in show a ++ show b ++ show c |] rec_sel_test = [d| data RecordSel a = forall b. (Show a, Eq b) => MkRecord { recsel1 :: (Int, a) , recsel_naughty :: (a, b) , recsel2 :: (forall b. b -> a) , recsel3 :: Bool } | MkRecord2 { recsel4 :: (a, a) } |] rec_sel_test_num_sels = 4 :: Int -- exclude naughty one testRecSelTypes :: Int -> Q Exp testRecSelTypes n = do #if __GLASGOW_HASKELL__ > 710 VarI _ ty1 _ <- reify (mkName ("DsDec.recsel" ++ show n)) VarI _ ty2 _ <- reify (mkName ("Dec.recsel" ++ show n)) #else VarI _ ty1 _ _ <- reify (mkName ("DsDec.recsel" ++ show n)) VarI _ ty2 _ _ <- reify (mkName ("Dec.recsel" ++ show n)) #endif let ty1' = return $ unqualify ty1 ty2' = return $ unqualify ty2 [| let x :: $ty1' x = undefined y :: $ty2' y = undefined in $(return $ VarE $ mkName "hasSameType") x y |] -- 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 :: * data R5 a :: * 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 :: * data family R13 a :: * 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 #if __GLASGOW_HASKELL__ >= 800 class R25 (f :: k -> *) where r26 :: forall (a :: k). f a data R27 (a :: k) = R28 { r29 :: Proxy a } #endif class R30 a where r31 :: a -> b -> a |] reifyDecsNames :: [Name] reifyDecsNames = map mkName [ "r1" #if __GLASGOW_HASKELL__ < 711 , "R2", "r3" -- these fail due to GHC#11797 #endif , "R4", "R5", "R6", "R7", "r8", "r9", "R10", "r11" , "R12", "R13", "R14", "r15", "r16", "r17", "R18", "R19", "R20" , "R21" , "r22" #if __GLASGOW_HASKELL__ >= 800 , "R25", "r26", "R28", "r29" #endif , "R30", "r31" ] 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 #if __GLASGOW_HASKELL__ >= 709 , test37_pred , test38_pred2 , test39_eq #endif #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 ] th-desugar-1.10/th-desugar.cabal0000644000000000000000000000661007346545000014721 0ustar0000000000000000name: th-desugar version: 1.10 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 == 7.8.4 , GHC == 7.10.3 , GHC == 8.0.2 , GHC == 8.2.2 , GHC == 8.4.4 , GHC == 8.6.5 , GHC == 8.8.1 description: This package provides the Language.Haskell.TH.Desugar module, which desugars Template Haskell's rich encoding of Haskell syntax into a simpler encoding. This desugaring discards surface syntax information (such as the use of infix operators) but retains the original meaning of the TH code. The intended use of this package is as a preprocessor for more advanced code manipulation tools. Note that the input to any of the ds... functions should be produced from a TH quote, using the syntax [| ... |]. If the input to these functions is a hand-coded TH syntax tree, the results may be unpredictable. In particular, it is likely that promoted datatypes will not work as expected. source-repository this type: git location: https://github.com/goldfirere/th-desugar.git tag: v1.10 source-repository head type: git location: https://github.com/goldfirere/th-desugar.git branch: master library build-depends: base >= 4.7 && < 5, ghc-prim, template-haskell >= 2.9 && < 2.16, containers >= 0.5, fail == 4.9.*, mtl >= 2.1, ordered-containers >= 0.2.2, semigroups >= 0.16, syb >= 0.4, th-abstraction >= 0.2.11, th-lift >= 0.6.1, th-orphans >= 0.13.7, transformers-compat >= 0.6.3 default-extensions: TemplateHaskell exposed-modules: Language.Haskell.TH.Desugar Language.Haskell.TH.Desugar.Expand Language.Haskell.TH.Desugar.Lift Language.Haskell.TH.Desugar.OMap Language.Haskell.TH.Desugar.OMap.Strict Language.Haskell.TH.Desugar.OSet Language.Haskell.TH.Desugar.Subst Language.Haskell.TH.Desugar.Sweeten other-modules: Language.Haskell.TH.Desugar.AST Language.Haskell.TH.Desugar.Core Language.Haskell.TH.Desugar.FV Language.Haskell.TH.Desugar.Match Language.Haskell.TH.Desugar.Reify Language.Haskell.TH.Desugar.Util default-language: Haskell2010 ghc-options: -Wall test-suite spec type: exitcode-stdio-1.0 ghc-options: -Wall default-language: Haskell2010 default-extensions: TemplateHaskell hs-source-dirs: Test main-is: Run.hs other-modules: Splices, Dec, DsDec build-depends: base >= 4 && < 5, template-haskell, containers >= 0.5, mtl >= 2.1, syb >= 0.4, HUnit >= 1.2, hspec >= 1.3, th-desugar, th-lift >= 0.6.1, th-orphans >= 0.9.1, th-expand-syns >= 0.3.0.6