th-desugar 1.11 → 1.12
raw patch · 18 files changed
+844/−549 lines, 18 filesdep ~template-haskelldep ~th-abstraction
Dependency ranges changed: template-haskell, th-abstraction
Files
- CHANGES.md +110/−1
- Language/Haskell/TH/Desugar.hs +73/−107
- Language/Haskell/TH/Desugar/AST.hs +38/−18
- Language/Haskell/TH/Desugar/Core.hs +228/−132
- Language/Haskell/TH/Desugar/Expand.hs +20/−16
- Language/Haskell/TH/Desugar/FV.hs +10/−5
- Language/Haskell/TH/Desugar/Lift.hs +5/−1
- Language/Haskell/TH/Desugar/Reify.hs +61/−57
- Language/Haskell/TH/Desugar/Subst.hs +26/−17
- Language/Haskell/TH/Desugar/Sweeten.hs +90/−97
- Language/Haskell/TH/Desugar/Util.hs +29/−26
- README.md +13/−1
- Test/DsDec.hs +4/−6
- Test/ReifyTypeCUSKs.hs +5/−5
- Test/ReifyTypeSigs.hs +3/−2
- Test/Run.hs +62/−34
- Test/Splices.hs +55/−17
- th-desugar.cabal +12/−7
CHANGES.md view
@@ -1,7 +1,116 @@ `th-desugar` release notes ========================== -Version 1.11 [????.??.??]+Version 1.12 [2021.03.12]+-------------------------+* Support GHC 9.0.+* Add support for explicit specificity. As part of this change,+ the way `th-desugar` represents type variable binders has been overhauled:+ * The `DTyVarBndr` data type is now parameterized by a `flag` type parameter:++ ```hs+ data DTyVarBndr flag+ = DPlainTV Name flag+ | DKindedTV Name flag DKind+ ```++ This can be instantiated to `Specificity` (for type variable binders that+ can be specified or inferred) or `()` (for type variable binders where+ specificity is irrelevant). `DTyVarBndrSpec` and `DTyVarBndrUnit` are also+ provided as type synonyms for `DTyVarBndr Specificity` and `DTyVarBndr ()`,+ respectively.+ * In order to interface with `TyVarBndr` (the TH counterpart to `DTyVarBndr`)+ in a backwards-compatible way, `th-desugar` now depends on the+ `th-abstraction` library.+ * The `ForallVisFlag` has been removed in favor of the new `DForallTelescope`+ data type, which not only distinguishes between invisible and visible+ `forall`s but also uses the correct type variable flag for invisible type+ variables (`Specificity`) and visible type variables (`()`).+ * The type of the `dsTvb` is now different on pre-9.0 versions of GHC:++ ```hs+ #if __GLASGOW_HASKELL__ >= 900+ dsTvb :: DsMonad q => TyVarBndr flag -> q (DTyVarBndr flag)+ #else+ dsTvb :: DsMonad q => flag -> TyVarBndr -> q (DTyVarBndr flag)+ #endif+ ```++ This is unfortunately required by the fact that prior to GHC 9.0, there is+ no `flag` information stored anywhere in a `TyVarBndr`. If you need to use+ `dsTvb` in a backward-compatible way, `L.H.TH.Desugar` now provides+ `dsTvbSpec` and `dsTvbUnit` functions which specialise `dsTvb` to+ particular `flag` types:++ ```hs+ dsTvbSpec :: DsMonad q => TyVarBndrSpec -> q DTyVarBndrSpec+ dsTvbUnit :: DsMonad q => TyVarBndrUnit -> q DTyVarBndrUnit+ ```+* The type of the `getRecordSelectors` function has changed:++ ```diff+ -getRecordSelectors :: DsMonad q => DType -> [DCon] -> q [DLetDec]+ +getRecordSelectors :: DsMonad q => [DCon] -> q [DLetDec]+ ```++ The old type signature had a `DType` argument whose sole purpose was to help+ determine which type variables were existential, as this information was used+ to filter out "naughty" record selectors, like the example below:++ ```hs+ data Some :: (Type -> Type) -> Type where+ MkSome :: { getSome :: f a } -> Some f+ ```++ The old implementation of `getRecordSelectors` would not include `getSome` in+ the returned list, as its type `f a` mentions an existential type variable,+ `a`, that is not mentioned in the return type `Some f`. The new+ implementation of `getRecordSelectors`, on the other hand, makes no attempt+ to filter out naughty record selectors, so it would include `getSome`.++ This reason for this change is ultimately because determining which type+ variables are existentially quantified in the context of Template+ Haskell is rather challenging in the general case. There are heuristics we+ could employ to guess which variables are existential, but we have found+ these heuristics difficult to predict (let alone specify). As a result, we+ take the slightly less correct (but much easier to explain) approach of+ returning all record selectors, regardless of whether they are naughty or not.+* The `conExistentialTvbs` function has been removed. It was horribly buggy,+ especially in the presence of GADT constructors. Moreover, this function was+ used in the implementation of `getRecordSelectors` function, so bugs in+ `conExistentialTvbs` often affected the results of `getRecordSelectors`.+* The types of `decToTH`, `letDecToTH`, and `pragmaToTH` have changed:++ ```diff+ -decToTH :: DDec -> [Dec]+ +decToTH :: DDec -> Dec++ -letDecToTH :: DLetDec -> Maybe Dec+ +letDecToTH :: DLetDec -> Dec++ -pragmaToTH :: DPragma -> Maybe Pragma+ +pragmaToTH :: DPragma -> Pragma+ ```++ The semantics of `pragmaToTH` have changed accordingly. Previously,+ `pragmaToTH` would return `Nothing` when the argument is a `DPragma` that is+ not supported on an old version of GHC, but now an error will be thrown+ instead. `decToTH` and `letDecToTH`, which transitively invoke `pragmaToTH`,+ have had their types updated to accommodate `pragmaToTH`'s type change.+* The type of the `substTyVarBndrs` function has been simplified to avoid the+ needless use of continuation-passing style:++ ```diff+ -substTyVarBndrs :: Quasi q => DSubst -> [DTyVarBndr flag] -> (DSubst -> [DTyVarBndr flag] -> q a) -> q a+ +substTyVarBndrs :: Quasi q => DSubst -> [DTyVarBndr flag] -> q (DSubst, [DTyVarBndr flag])+ ```+* `mkDLamEFromDPats` has now generates slightly more direct code for certain+ lambda expressions with `@`-patterns. For example, `\x@y -> f x y` would+ previously desugar to `\arg -> case arg of { y -> let x = y in f x y }`, but+ it now desugars to `\y -> let x = y in f x y`.+* `mkDLamEFromDPats` now requires only a `Quasi` context instead of `DsMonad`.++Version 1.11 [2020.03.25] ------------------------- * Support GHC 8.10. * Add support for visible dependent quantification. As part of this change,
Language/Haskell/TH/Desugar.hs view
@@ -25,8 +25,9 @@ module Language.Haskell.TH.Desugar ( -- * Desugared data types DExp(..), DLetDec(..), DPat(..),- DType(..), ForallVisFlag(..), DKind, DCxt, DPred,- DTyVarBndr(..), DMatch(..), DClause(..), DDec(..),+ DType(..), DForallTelescope(..), DKind, DCxt, DPred,+ DTyVarBndr(..), DTyVarBndrSpec, DTyVarBndrUnit, Specificity(..),+ DMatch(..), DClause(..), DDec(..), DDerivClause(..), DDerivStrategy(..), DPatSynDir(..), DPatSynType, Overlap(..), PatSynArgs(..), NewOrData(..), DTypeFamilyHead(..), DFamilyResultSig(..), InjectivityAnn(..),@@ -42,7 +43,7 @@ -- * Main desugaring functions dsExp, dsDecs, dsType, dsInfo, dsPatOverExp, dsPatsOverExp, dsPatX,- dsLetDecs, dsTvb, dsCxt,+ dsLetDecs, dsTvb, dsTvbSpec, dsTvbUnit, dsCxt, dsCon, dsForeign, dsPragma, dsRuleBndr, -- ** Secondary desugaring functions@@ -100,14 +101,15 @@ #if __GLASGOW_HASKELL__ >= 800 bindIP, #endif- conExistentialTvbs, mkExtraDKindBinders,- dTyVarBndrToDType, toposortTyVarsOf,+ mkExtraDKindBinders, dTyVarBndrToDType, changeDTVFlags, toposortTyVarsOf, -- ** 'FunArgs' and 'VisFunArg'- FunArgs(..), VisFunArg(..), filterVisFunArgs, ravelType, unravelType,+ FunArgs(..), ForallTelescope(..), VisFunArg(..),+ filterVisFunArgs, ravelType, unravelType, -- ** 'DFunArgs' and 'DVisFunArg'- DFunArgs(..), DVisFunArg(..), filterDVisFunArgs, ravelDType, unravelDType,+ DFunArgs(..), DVisFunArg(..),+ filterDVisFunArgs, ravelDType, unravelDType, -- ** 'TypeArg' TypeArg(..), applyType, filterTANormals, unfoldType,@@ -119,12 +121,12 @@ extractBoundNamesStmt, extractBoundNamesDec, extractBoundNamesPat ) where +import Language.Haskell.TH.Datatype.TyVarBndr import Language.Haskell.TH.Desugar.AST import Language.Haskell.TH.Desugar.Core import Language.Haskell.TH.Desugar.Expand import Language.Haskell.TH.Desugar.FV import Language.Haskell.TH.Desugar.Match-import 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@@ -145,8 +147,16 @@ -- | This class relates a TH type with its th-desugar type and allows -- conversions back and forth. The functional dependency goes only one--- way because `Type` and `Kind` are type synonyms, but they desugar--- to different types.+-- way because we define the following instances on old versions of GHC:+--+-- @+-- instance 'Desugar' 'TyVarBndrSpec' 'DTyVarBndrSpec'+-- instance 'Desugar' 'TyVarBndrUnit' 'DTyVarBndrUnit'+-- @+--+-- Prior to GHC 9.0, 'TyVarBndrSpec' and 'TyVarBndrUnit' are simply type+-- synonyms for 'TyVarBndr', so making the functional dependencies+-- bidirectional would cause these instances to be rejected. class Desugar th ds | ds -> th where desugar :: DsMonad q => th -> q ds sweeten :: ds -> th@@ -163,10 +173,37 @@ desugar = dsCxt sweeten = cxtToTH -instance Desugar TyVarBndr DTyVarBndr where+#if __GLASGOW_HASKELL__ >= 900+-- | This instance is only @flag@-polymorphic on GHC 9.0 or later, since+-- previous versions of GHC do not equip 'TyVarBndr' with a @flag@ type+-- parameter. As a result, we define two separate instances for 'DTyVarBndr'+-- on older GHCs:+--+-- @+-- instance 'Desugar' 'TyVarBndrSpec' 'DTyVarBndrSpec'+-- instance 'Desugar' 'TyVarBndrUnit' 'DTyVarBndrUnit'+-- @+instance Desugar (TyVarBndr flag) (DTyVarBndr flag) where desugar = dsTvb sweeten = tvbToTH+#else+-- | This instance monomorphizes the @flag@ parameter of 'DTyVarBndr' since+-- pre-9.0 versions of GHC do not equip 'TyVarBndr' with a @flag@ type+-- parameter. There is also a corresponding instance for+-- 'TyVarBndrUnit'/'DTyVarBndrUnit'.+instance Desugar TyVarBndrSpec DTyVarBndrSpec where+ desugar = dsTvbSpec+ sweeten = tvbToTH +-- | This instance monomorphizes the @flag@ parameter of 'DTyVarBndr' since+-- pre-9.0 versions of GHC do not equip 'TyVarBndr' with a @flag@ type+-- parameter. There is also a corresponding instance for+-- 'TyVarBndrSpec'/'DTyVarBndrSpec'.+instance Desugar TyVarBndrUnit DTyVarBndrUnit where+ desugar = dsTvbUnit+ sweeten = tvbToTH+#endif+ instance Desugar [Dec] [DDec] where desugar = dsDecs sweeten = decsToTH@@ -232,38 +269,38 @@ -- -- 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+-- 'getRecordSelectors' does not attempt to filter out \"naughty\" record+-- selectors—that is, records whose field types mention existentially+-- quantified type variables that do not appear in the constructor's return+-- type. Here is an example of a naughty record selector:+--+-- @+-- data Some :: (Type -> Type) -> Type where+-- MkSome :: { getSome :: f a } -> Some f+-- @+--+-- GHC itself will not allow the use of @getSome@ as a top-level function due+-- to its type @f a@ mentioning the existential variable @a@, but+-- 'getRecordSelectors' will return it nonetheless. Ultimately, this design+-- choice is a practical one, as detecting which type variables are existential+-- in Template Haskell is difficult in the general case.+getRecordSelectors :: DsMonad q => [DCon] -> q [DLetDec]+getRecordSelectors cons = merge_let_decs `fmap` concatMapM get_record_sels cons where- get_record_sels con@(DCon con_tvbs _ con_name con_fields con_ret_ty) =+ get_record_sels (DCon con_tvbs _ con_name con_fields con_ret_ty) = case con_fields of DRecC fields -> go fields DNormalC{} -> return [] where go fields = do varName <- qNewName "field"- 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 ForallInvis 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)]+ [ [ DSigD name $ DForallT (DForallInvis con_tvbs)+ $ DArrowT `DAppT` con_ret_ty `DAppT` field_ty+ , DFunD name [DClause [DConP con_name+ (mk_field_pats n (length fields) varName)] (DVarE varName)] ] | ((name, _strict, field_ty), n) <- zip fields [0..]- , OS.null (fvDType field_ty `OS.intersection` con_ex_tvb_set)- -- exclude "naughty" selectors ] mk_field_pats :: Int -> Int -> Name -> [DPat]@@ -345,87 +382,16 @@ -- are fresh type variable names. -- -- This expands kind synonyms if necessary.-mkExtraDKindBinders :: forall q. DsMonad q => DKind -> q [DTyVarBndr]+mkExtraDKindBinders :: forall q. DsMonad q => DKind -> q [DTyVarBndrUnit] mkExtraDKindBinders k = do k' <- expandType k let (fun_args, _) = unravelDType k' vis_fun_args = filterDVisFunArgs fun_args mapM mk_tvb vis_fun_args where- mk_tvb :: DVisFunArg -> q DTyVarBndr+ mk_tvb :: DVisFunArg -> q DTyVarBndrUnit mk_tvb (DVisFADep tvb) = return tvb- mk_tvb (DVisFAAnon ki) = DKindedTV <$> qNewName "a" <*> return ki---- | 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- ]+ mk_tvb (DVisFAAnon ki) = DKindedTV <$> qNewName "a" <*> return () <*> return ki {- $localReification
Language/Haskell/TH/Desugar/AST.hs view
@@ -6,14 +6,16 @@ constructors are prefixed with a D. -} -{-# LANGUAGE CPP, DeriveDataTypeable, DeriveGeneric #-}+{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveGeneric #-} module Language.Haskell.TH.Desugar.AST where import Data.Data hiding (Fixity) import GHC.Generics hiding (Fixity) import Language.Haskell.TH-import Language.Haskell.TH.Desugar.Util (ForallVisFlag)+#if __GLASGOW_HASKELL__ < 900+import Language.Haskell.TH.Datatype.TyVarBndr (Specificity)+#endif -- | Corresponds to TH's @Exp@ type. Note that @DLamE@ takes names, not patterns. data DExp = DVarE Name@@ -41,7 +43,7 @@ -- | Corresponds to TH's @Type@ type, used to represent -- types and kinds.-data DType = DForallT ForallVisFlag [DTyVarBndr] DType+data DType = DForallT DForallTelescope DType | DConstrainedT DCxt DType | DAppT DType DType | DAppKindT DType DKind@@ -53,6 +55,17 @@ | DWildCardT deriving (Eq, Show, Typeable, Data, Generic) +-- | The type variable binders in a @forall@.+data DForallTelescope+ = DForallVis [DTyVarBndrUnit]+ -- ^ A visible @forall@ (e.g., @forall a -> {...}@).+ -- These do not have any notion of specificity, so we use+ -- '()' as a placeholder value in the 'DTyVarBndr's.+ | DForallInvis [DTyVarBndrSpec]+ -- ^ An invisible @forall@ (e.g., @forall a {b} c -> {...}@),+ -- where each binder has a 'Specificity'.+ deriving (Eq, Show, Typeable, Data, Generic)+ -- | Kinds are types. Corresponds to TH's @Kind@ type DKind = DType @@ -63,10 +76,17 @@ type DCxt = [DPred] -- | Corresponds to TH's @TyVarBndr@-data DTyVarBndr = DPlainTV Name- | DKindedTV Name DKind- deriving (Eq, Show, Typeable, Data, Generic)+data DTyVarBndr flag+ = DPlainTV Name flag+ | DKindedTV Name flag DKind+ deriving (Eq, Show, Typeable, Data, Generic, Functor) +-- | Corresponds to TH's @TyVarBndrSpec@+type DTyVarBndrSpec = DTyVarBndr Specificity++-- | Corresponds to TH's @TyVarBndrUnit@+type DTyVarBndrUnit = DTyVarBndr ()+ -- | Corresponds to TH's @Match@ type. data DMatch = DMatch DPat DExp deriving (Eq, Show, Typeable, Data, Generic)@@ -90,19 +110,19 @@ -- | 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]+ | DDataD NewOrData DCxt Name [DTyVarBndrUnit] (Maybe DKind) [DCon] [DDerivClause]+ | DTySynD Name [DTyVarBndrUnit] DType+ | DClassD DCxt Name [DTyVarBndrUnit] [FunDep] [DDec]+ | DInstanceD (Maybe Overlap) (Maybe [DTyVarBndrUnit]) DCxt DType [DDec] | DForeignD DForeign | DOpenTypeFamilyD DTypeFamilyHead | DClosedTypeFamilyD DTypeFamilyHead [DTySynEqn]- | DDataFamilyD Name [DTyVarBndr] (Maybe DKind)- | DDataInstD NewOrData DCxt (Maybe [DTyVarBndr]) DType (Maybe DKind)+ | DDataFamilyD Name [DTyVarBndrUnit] (Maybe DKind)+ | DDataInstD NewOrData DCxt (Maybe [DTyVarBndrUnit]) DType (Maybe DKind) [DCon] [DDerivClause] | DTySynInstD DTySynEqn | DRoleAnnotD Name [Role]- | DStandaloneDerivD (Maybe DDerivStrategy) (Maybe [DTyVarBndr]) DCxt DType+ | DStandaloneDerivD (Maybe DDerivStrategy) (Maybe [DTyVarBndrUnit]) DCxt DType | DDefaultSigD Name DType | DPatSynD Name PatSynArgs DPatSynDir DPat | DPatSynSigD Name DPatSynType@@ -135,14 +155,14 @@ #endif -- | Corresponds to TH's 'TypeFamilyHead' type-data DTypeFamilyHead = DTypeFamilyHead Name [DTyVarBndr] DFamilyResultSig+data DTypeFamilyHead = DTypeFamilyHead Name [DTyVarBndrUnit] DFamilyResultSig (Maybe InjectivityAnn) deriving (Eq, Show, Typeable, Data, Generic) -- | Corresponds to TH's 'FamilyResultSig' type data DFamilyResultSig = DNoSig | DKindSig DKind- | DTyVarSig DTyVarBndr+ | DTyVarSig DTyVarBndrUnit deriving (Eq, Show, Typeable, Data, Generic) #if __GLASGOW_HASKELL__ <= 710@@ -165,7 +185,7 @@ -- other. -- -- * A 'DCon' always has an explicit return type.-data DCon = DCon [DTyVarBndr] DCxt Name DConFields+data DCon = DCon [DTyVarBndrSpec] DCxt Name DConFields DType -- ^ The GADT result type deriving (Eq, Show, Typeable, Data, Generic) @@ -252,7 +272,7 @@ data DPragma = DInlineP Name Inline RuleMatch Phases | DSpecialiseP Name DType (Maybe Inline) Phases | DSpecialiseInstP DType- | DRuleP String (Maybe [DTyVarBndr]) [DRuleBndr] DExp DExp Phases+ | DRuleP String (Maybe [DTyVarBndrUnit]) [DRuleBndr] DExp DExp Phases | DAnnP AnnTarget DExp | DLineP Int String | DCompleteP [Name] (Maybe Name)@@ -264,7 +284,7 @@ deriving (Eq, Show, Typeable, Data, Generic) -- | Corresponds to TH's @TySynEqn@ type (to store type family equations).-data DTySynEqn = DTySynEqn (Maybe [DTyVarBndr]) DType DType+data DTySynEqn = DTySynEqn (Maybe [DTyVarBndrUnit]) DType DType deriving (Eq, Show, Typeable, Data, Generic) -- | Corresponds to TH's @Info@ type.
Language/Haskell/TH/Desugar/Core.hs view
@@ -15,6 +15,7 @@ import Prelude hiding (mapM, foldl, foldr, all, elem, exp, concatMap, and) import Language.Haskell.TH hiding (match, clause, cxt)+import Language.Haskell.TH.Datatype.TyVarBndr import Language.Haskell.TH.Syntax hiding (lift) #if __GLASGOW_HASKELL__ < 709@@ -77,7 +78,10 @@ dsExp (UInfixE _ _ _) = fail "Cannot desugar unresolved infix operators." dsExp (ParensE exp) = dsExp exp-dsExp (LamE pats exp) = dsLam pats =<< dsExp exp+dsExp (LamE pats exp) = do+ exp' <- dsExp exp+ (pats', exp'') <- dsPatsOverExp pats exp'+ mkDLamEFromDPats pats' exp'' dsExp (LamCaseE matches) = do x <- newUniqueName "x" matches' <- dsMatches x matches@@ -105,7 +109,11 @@ matches' <- dsMatches scrutinee matches return $ DLetE [DValD (DVarP scrutinee) exp'] $ DCaseE (DVarE scrutinee) matches'-dsExp (DoE stmts) = dsDoStmts stmts+#if __GLASGOW_HASKELL__ >= 900+dsExp (DoE mb_mod stmts) = dsDoStmts mb_mod stmts+#else+dsExp (DoE stmts) = dsDoStmts Nothing stmts+#endif dsExp (CompE stmts) = dsComp stmts dsExp (ArithSeqE (FromR exp)) = DAppE (DVarE 'enumFrom) <$> dsExp exp dsExp (ArithSeqE (FromThenR exp1 exp2)) =@@ -264,7 +272,7 @@ 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+ else mkDLamEFromDPats (map DVarP section_vars) tup_body where -- If dealing with an empty field in a tuple section (Nothing), create a -- unique name and return Left. These names will be used to construct the@@ -285,40 +293,22 @@ 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+mkDLamEFromDPats :: Quasi q => [DPat] -> DExp -> q DExp+mkDLamEFromDPats pats exp+ | Just names <- mapM stripDVarP_maybe pats = return $ DLamE names exp | otherwise = do arg_names <- replicateM (length pats) (newUniqueName "arg") let scrutinee = mkTupleDExp (map DVarE arg_names)- (pats', exp') <- process_pats_over_exp pats exp- let match = DMatch (mkTupleDPat pats') exp'+ match = DMatch (mkTupleDPat pats) exp return $ DLamE arg_names (DCaseE scrutinee [match])+ where+ stripDVarP_maybe :: DPat -> Maybe Name+ stripDVarP_maybe (DVarP n) = Just n+ stripDVarP_maybe _ = Nothing -- | Desugar a list of matches for a @case@ statement dsMatches :: DsMonad q@@ -414,23 +404,27 @@ #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."+dsDoStmts :: forall q. DsMonad q => Maybe ModName -> [Stmt] -> q DExp+dsDoStmts mb_mod = go+ where+ go :: [Stmt] -> q DExp+ go [] = impossible "do-expression ended with something other than bare statement."+ go [NoBindS exp] = dsExp exp+ go (BindS pat exp : rest) = do+ rest' <- go rest+ dsBindS mb_mod exp pat rest' "do expression"+ go (LetS decs : rest) = do+ (decs', ip_binder) <- dsLetDecs decs+ rest' <- go rest+ return $ DLetE decs' $ ip_binder rest'+ go (NoBindS exp : rest) = do+ exp' <- dsExp exp+ rest' <- go rest+ let sequence_name = mk_qual_do_name mb_mod '(>>)+ return $ DAppE (DAppE (DVarE sequence_name) exp') rest'+ go (ParS _ : _) = impossible "Parallel comprehension in a do-statement." #if __GLASGOW_HASKELL__ >= 807-dsDoStmts (RecS {} : _) = fail "th-desugar currently does not support RecursiveDo"+ go (RecS {} : _) = fail "th-desugar currently does not support RecursiveDo" #endif -- | Desugar the @Stmt@s in a list or monad comprehension@@ -439,7 +433,7 @@ dsComp [NoBindS exp] = DAppE (DVarE 'return) <$> dsExp exp dsComp (BindS pat exp : rest) = do rest' <- dsComp rest- dsBindS exp pat rest' "monad comprehension"+ dsBindS Nothing exp pat rest' "monad comprehension" dsComp (LetS decs : rest) = do (decs', ip_binder) <- dsLetDecs decs rest' <- dsComp rest@@ -451,7 +445,7 @@ dsComp (ParS stmtss : rest) = do (pat, exp) <- dsParComp stmtss rest' <- dsComp rest- DAppE (DAppE (DVarE '(>>=)) exp) <$> dsLam [pat] rest'+ DAppE (DAppE (DVarE '(>>=)) exp) <$> mkDLamEFromDPats [pat] rest' #if __GLASGOW_HASKELL__ >= 807 dsComp (RecS {} : _) = fail "th-desugar currently does not support RecursiveDo" #endif@@ -463,12 +457,13 @@ -- '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+dsBindS :: forall q. DsMonad q+ => Maybe ModName -> Exp -> Pat -> DExp -> String -> q DExp+dsBindS mb_mod bind_arg_exp success_pat success_exp ctxt = do bind_arg_exp' <- dsExp bind_arg_exp (success_pat', success_exp') <- dsPatOverExp success_pat success_exp is_univ_pat <- isUniversalPattern success_pat'- let bind_into = DAppE (DAppE (DVarE '(>>=)) bind_arg_exp')+ let bind_into = DAppE (DAppE (DVarE bind_name) bind_arg_exp') if is_univ_pat then bind_into <$> mkDLamEFromDPats [success_pat'] success_exp' else do arg_name <- newUniqueName "arg"@@ -480,36 +475,46 @@ DLitE (StringL $ "Pattern match failure in " ++ ctxt) ] where+ bind_name = mk_qual_do_name mb_mod '(>>=)+ mk_fail_name :: q Name #if __GLASGOW_HASKELL__ >= 807 -- GHC 8.8 deprecates the MonadFailDesugaring extension since its effects -- are always enabled. Furthermore, MonadFailDesugaring is no longer -- enabled by default, so simply use MonadFail.fail. (That happens to -- be the same as Prelude.fail in 8.8+.)- mk_fail_name = return 'MonadFail.fail+ mk_fail_name = return fail_MonadFail_name #elif __GLASGOW_HASKELL__ >= 800 mk_fail_name = do mfd <- qIsExtEnabled MonadFailDesugaring- return $ if mfd then 'MonadFail.fail else 'Prelude.fail+ return $ if mfd then fail_MonadFail_name else fail_Prelude_name #else- mk_fail_name = return 'Prelude.fail+ mk_fail_name = return fail_Prelude_name #endif +#if __GLASGOW_HASKELL__ >= 800+ fail_MonadFail_name = mk_qual_do_name mb_mod 'MonadFail.fail+#endif++#if __GLASGOW_HASKELL__ < 807+ fail_Prelude_name = mk_qual_do_name mb_mod 'Prelude.fail+#endif+ -- | Desugar the contents of a parallel comprehension. -- Returns a @Pat@ containing a tuple of all bound variables and an expression -- to produce the values for those variables-dsParComp :: DsMonad q => [[Stmt]] -> q (Pat, DExp)+dsParComp :: DsMonad q => [[Stmt]] -> q (DPat, DExp) dsParComp [] = impossible "Empty list of parallel comprehension statements." dsParComp [r] = do let rv = foldMap extractBoundNamesStmt r dsR <- dsComp (r ++ [mk_tuple_stmt rv])- return (mk_tuple_pat rv, dsR)+ return (mk_tuple_dpat rv, dsR) dsParComp (q : rest) = do let qv = foldMap extractBoundNamesStmt q (rest_pat, rest_exp) <- dsParComp rest dsQ <- dsComp (q ++ [mk_tuple_stmt qv]) let zipped = DAppE (DAppE (DVarE 'mzip) dsQ) rest_exp- return (ConP (tupleDataName 2) [mk_tuple_pat qv, rest_pat], zipped)+ return (DConP (tupleDataName 2) [mk_tuple_dpat qv, rest_pat], zipped) -- helper function for dsParComp mk_tuple_stmt :: OSet Name -> Stmt@@ -517,23 +522,23 @@ 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)+mk_tuple_dpat :: OSet Name -> DPat+mk_tuple_dpat name_set =+ mkTupleDPat (F.foldr ((:) . DVarP) [] name_set) -- | Desugar a pattern, along with processing a (desugared) expression that -- is the entire scope of the variables bound in the pattern. dsPatOverExp :: DsMonad q => Pat -> DExp -> q (DPat, DExp) dsPatOverExp pat exp = do (pat', vars) <- runWriterT $ dsPat pat- let name_decs = uncurry (zipWith (DValD . DVarP)) $ unzip vars+ let name_decs = map (uncurry (DValD . DVarP)) vars return (pat', maybeDLetE name_decs exp) -- | Desugar multiple patterns. Like 'dsPatOverExp'. dsPatsOverExp :: DsMonad q => [Pat] -> DExp -> q ([DPat], DExp) dsPatsOverExp pats exp = do (pats', vars) <- runWriterT $ mapM dsPat pats- let name_decs = uncurry (zipWith (DValD . DVarP)) $ unzip vars+ let name_decs = map (uncurry (DValD . DVarP)) vars return (pats', maybeDLetE name_decs exp) -- | Desugar a pattern, returning a list of (Name, DExp) pairs of extra@@ -691,9 +696,9 @@ dsDataDec Newtype cxt n tvbs Nothing [con] derivings #endif dsDec (TySynD n tvbs ty) =- (:[]) <$> (DTySynD n <$> mapM dsTvb tvbs <*> dsType ty)+ (:[]) <$> (DTySynD n <$> mapM dsTvbUnit tvbs <*> dsType ty) dsDec (ClassD cxt n tvbs fds decs) =- (:[]) <$> (DClassD <$> dsCxt cxt <*> pure n <*> mapM dsTvb tvbs+ (:[]) <$> (DClassD <$> dsCxt cxt <*> pure n <*> mapM dsTvbUnit tvbs <*> pure fds <*> dsDecs decs) #if __GLASGOW_HASKELL__ >= 711 dsDec (InstanceD over cxt ty decs) =@@ -710,12 +715,12 @@ dsDec (OpenTypeFamilyD tfHead) = (:[]) <$> (DOpenTypeFamilyD <$> dsTypeFamilyHead tfHead) dsDec (DataFamilyD n tvbs m_k) =- (:[]) <$> (DDataFamilyD n <$> mapM dsTvb tvbs <*> mapM dsType m_k)+ (:[]) <$> (DDataFamilyD n <$> mapM dsTvbUnit 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)+ (:[]) <$> (DDataFamilyD n <$> mapM dsTvbUnit tvbs <*> mapM dsType m_k) #endif #if __GLASGOW_HASKELL__ >= 807 dsDec (DataInstD cxt mtvbs lhs mk cons derivings) =@@ -779,10 +784,10 @@ -- | Desugar a 'DataD' or 'NewtypeD'. dsDataDec :: DsMonad q- => NewOrData -> Cxt -> Name -> [TyVarBndr]+ => NewOrData -> Cxt -> Name -> [TyVarBndrUnit] -> Maybe Kind -> [Con] -> [DerivingClause] -> q [DDec] dsDataDec nd cxt n tvbs mk cons derivings = do- tvbs' <- mapM dsTvb tvbs+ tvbs' <- mapM dsTvbUnit tvbs let h98_tvbs = case mk of -- If there's an explicit return kind, we're dealing with a -- GADT, so this argument goes unused in dsCon.@@ -796,10 +801,10 @@ -- | Desugar a 'DataInstD' or a 'NewtypeInstD'. dsDataInstDec :: DsMonad q- => NewOrData -> Cxt -> Name -> Maybe [TyVarBndr] -> [TypeArg]+ => NewOrData -> Cxt -> Name -> Maybe [TyVarBndrUnit] -> [TypeArg] -> Maybe Kind -> [Con] -> [DerivingClause] -> q [DDec] dsDataInstDec nd cxt n mtvbs tys mk cons derivings = do- mtvbs' <- mapM (mapM dsTvb) mtvbs+ mtvbs' <- mapM (mapM dsTvbUnit) mtvbs tys' <- mapM dsTypeArg tys let lhs' = applyDType (DConT n) tys' h98_tvbs =@@ -824,12 +829,12 @@ dsFamilyResultSig :: DsMonad q => FamilyResultSig -> q DFamilyResultSig dsFamilyResultSig NoSig = return DNoSig dsFamilyResultSig (KindSig k) = DKindSig <$> dsType k-dsFamilyResultSig (TyVarSig tvb) = DTyVarSig <$> dsTvb tvb+dsFamilyResultSig (TyVarSig tvb) = DTyVarSig <$> dsTvbUnit tvb -- | Desugar a @TypeFamilyHead@ dsTypeFamilyHead :: DsMonad q => TypeFamilyHead -> q DTypeFamilyHead dsTypeFamilyHead (TypeFamilyHead n tvbs result inj)- = DTypeFamilyHead n <$> mapM dsTvb tvbs+ = DTypeFamilyHead n <$> mapM dsTvbUnit tvbs <*> dsFamilyResultSig result <*> pure inj @@ -838,12 +843,12 @@ #else -- | Desugar bits and pieces into a 'DTypeFamilyHead' dsTypeFamilyHead :: DsMonad q- => Name -> [TyVarBndr] -> Maybe Kind -> q DTypeFamilyHead+ => Name -> [TyVarBndrUnit] -> 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+ DTypeFamilyHead n <$> mapM dsTvbUnit tvbs <*> pure result_sig <*> pure Nothing #endif@@ -960,10 +965,10 @@ -- 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).+ => [DTyVarBndrUnit] -- ^ The universally quantified type variables+ -- (used if desugaring a non-GADT constructor).+ -> DType -- ^ The original data declaration's type+ -- (used if desugaring a non-GADT constructor). -> Con -> q [DCon] dsCon univ_dtvbs data_type con = do dcons' <- dsCon' con@@ -971,8 +976,10 @@ case m_gadt_type of Nothing -> let ex_dtvbs = dtvbs- expl_dtvbs = univ_dtvbs ++ ex_dtvbs- impl_dtvbs = toposortTyVarsOf $ mapMaybe extractTvbKind expl_dtvbs in+ expl_dtvbs = changeDTVFlags SpecifiedSpec univ_dtvbs +++ ex_dtvbs+ impl_dtvbs = changeDTVFlags SpecifiedSpec $+ toposortTyVarsOf $ mapMaybe extractTvbKind expl_dtvbs in DCon (impl_dtvbs ++ expl_dtvbs) dcxt n fields data_type Just gadt_type -> let univ_ex_dtvbs = dtvbs in@@ -987,7 +994,7 @@ -- * 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)]+ => Con -> q [(Name, [DTyVarBndrSpec], DCxt, DConFields, Maybe DType)] dsCon' (NormalC n stys) = do dtys <- mapM dsBangType stys return [(n, [], [], DNormalC False dtys, Nothing)]@@ -999,7 +1006,7 @@ dty2 <- dsBangType sty2 return [(n, [], [], DNormalC True [dty1, dty2], Nothing)] dsCon' (ForallC tvbs cxt con) = do- dtvbs <- mapM dsTvb tvbs+ dtvbs <- mapM dsTvbSpec tvbs dcxt <- dsCxt cxt dcons' <- dsCon' con return $ flip map dcons' $ \(n, dtvbs', dcxt', fields, m_gadt_type) ->@@ -1057,7 +1064,7 @@ dsPragma (SpecialiseInstP ty) = DSpecialiseInstP <$> dsType ty #if __GLASGOW_HASKELL__ >= 807 dsPragma (RuleP str mtvbs rbs lhs rhs phases)- = DRuleP str <$> mapM (mapM dsTvb) mtvbs+ = DRuleP str <$> mapM (mapM dsTvbUnit) mtvbs <*> mapM dsRuleBndr rbs <*> dsExp lhs <*> dsExp rhs@@ -1089,7 +1096,7 @@ -- 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+ DTySynEqn <$> mapM (mapM dsTvbUnit) mtvbs <*> dsType lhs <*> dsType rhs #else -- | Desugar a @TySynEqn@. (Available only with GHC 7.8+) dsTySynEqn :: DsMonad q => Name -> TySynEqn -> q DTySynEqn@@ -1134,8 +1141,14 @@ -- | Desugar a type dsType :: DsMonad q => Type -> q DType+#if __GLASGOW_HASKELL__ >= 900+-- See Note [Gracefully handling linear types]+dsType (MulArrowT `AppT` _) = return DArrowT+dsType MulArrowT = fail "Cannot desugar exotic uses of linear types."+#endif dsType (ForallT tvbs preds ty) =- mkDForallConstrainedT ForallInvis <$> mapM dsTvb tvbs <*> dsCxt preds <*> dsType ty+ mkDForallConstrainedT <$> (DForallInvis <$> mapM dsTvbSpec tvbs)+ <*> dsCxt preds <*> dsType ty dsType (AppT t1 t2) = DAppT <$> dsType t1 <*> dsType t2 dsType (SigT ty ki) = DSigT <$> dsType ty <*> dsType ki dsType (VarT name) = return $ DVarT name@@ -1174,14 +1187,72 @@ return $ DConT ''IP `DAppT` DLitT (StrTyLit n) `DAppT` t' #endif #if __GLASGOW_HASKELL__ >= 809-dsType (ForallVisT tvbs ty) = DForallT ForallVis <$> mapM dsTvb tvbs <*> dsType ty+dsType (ForallVisT tvbs ty) =+ DForallT <$> (DForallVis <$> mapM dsTvbUnit tvbs) <*> dsType ty #endif --- | Desugar a @TyVarBndr@-dsTvb :: DsMonad q => TyVarBndr -> q DTyVarBndr-dsTvb (PlainTV n) = return $ DPlainTV n-dsTvb (KindedTV n k) = DKindedTV n <$> dsType k+#if __GLASGOW_HASKELL__ >= 900+-- | Desugar a 'TyVarBndr'.+dsTvb :: DsMonad q => TyVarBndr_ flag -> q (DTyVarBndr flag)+dsTvb (PlainTV n flag) = return $ DPlainTV n flag+dsTvb (KindedTV n flag k) = DKindedTV n flag <$> dsType k+#else+-- | Desugar a 'TyVarBndr' with a particular @flag@.+dsTvb :: DsMonad q => flag -> TyVarBndr -> q (DTyVarBndr flag)+dsTvb flag (PlainTV n) = return $ DPlainTV n flag+dsTvb flag (KindedTV n k) = DKindedTV n flag <$> dsType k+#endif +{-+Note [Gracefully handling linear types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Per the README, th-desugar does not currently support linear types.+Unfortunately, we cannot simply reject all occurrences of+multiplicity-polymorphic function arrows (i.e., MulArrowT), as it is possible+for "non-linear" code to contain them when reified. For example, the type of a+Haskell98 data constructor such as `Just` will be reified as++ a #-> Maybe a++In terms of the TH AST, that is:++ MulArrowT `AppT` PromotedConT 'One `AppT` VarT a `AppT` (ConT ''Maybe `AppT` VarT a)++Therefore, in order to desugar these sorts of types, we have to do *something*+with MulArrowT. The approach that th-desugar takes is to pretend that all+multiplicity-polymorphic function arrows are actually ordinary function arrows+(->) when desugaring types. In other words, whenever th-desugar sees+(MulArrowT `AppT` m), for any particular value of `m`, it will turn it into+DArrowT.++This approach is enough to gracefully handle most uses of MulArrowT, as TH+reification always generates MulArrowT applied to some particular multiplicity+(as of GHC 9.0, at least). It's conceivable that some wily user could manually+construct a TH AST containing MulArrowT in a different position, but since this+situation is rare, we simply throw an error in such cases.++We adopt a similar stance in L.H.TH.Desugar.Reify when locally reifying the+types of data constructors: since th-desugar doesn't currently support linear+types, we pretend as if MulArrowT does not exist. As a result, the type of+`Just` would be locally reified as `a -> Maybe a`, not `a #-> Maybe a`.+-}++-- | Desugar a 'TyVarBndrSpec'.+dsTvbSpec :: DsMonad q => TyVarBndrSpec -> q DTyVarBndrSpec+#if __GLASGOW_HASKELL__ >= 900+dsTvbSpec = dsTvb+#else+dsTvbSpec = dsTvb SpecifiedSpec+#endif++-- | Desugar a 'TyVarBndrUnit'.+dsTvbUnit :: DsMonad q => TyVarBndrUnit -> q DTyVarBndrUnit+#if __GLASGOW_HASKELL__ >= 900+dsTvbUnit = dsTvb+#else+dsTvbUnit = dsTvb ()+#endif+ -- | Desugar a @Cxt@ dsCxt :: DsMonad q => Cxt -> q DCxt dsCxt = concatMapM dsPred@@ -1292,14 +1363,17 @@ dsPred t@(ForallVisT {}) = impossible $ "Visible dependent quantifier seen as head of constraint: " ++ show t #endif+#if __GLASGOW_HASKELL__ >= 900+dsPred MulArrowT = impossible "Linear arrow seen as head of constraint."+#endif -- | Desugar a quantified constraint.-dsForallPred :: DsMonad q => [TyVarBndr] -> Cxt -> Pred -> q DCxt+dsForallPred :: DsMonad q => [TyVarBndrSpec] -> Cxt -> Pred -> q DCxt dsForallPred tvbs cxt p = do ps' <- dsPred p case ps' of- [p'] -> (:[]) <$> (mkDForallConstrainedT ForallInvis- <$> mapM dsTvb tvbs <*> dsCxt cxt <*> pure p')+ [p'] -> (:[]) <$> (mkDForallConstrainedT <$>+ (DForallInvis <$> mapM dsTvbSpec tvbs) <*> dsCxt cxt <*> pure p') _ -> fail "Cannot desugar constraint tuples in the body of a quantified constraint" -- See GHC #15334. #endif@@ -1318,9 +1392,9 @@ -- a DType using DForallT and DConstrainedT as appropriate. The phrase -- "as appropriate" is used because DConstrainedT will not be used if the -- context is empty, per Note [Desugaring and sweetening ForallT].-mkDForallConstrainedT :: ForallVisFlag -> [DTyVarBndr] -> DCxt -> DType -> DType-mkDForallConstrainedT fvf tvbs ctxt ty =- DForallT fvf tvbs $ if null ctxt then ty else DConstrainedT ctxt ty+mkDForallConstrainedT :: DForallTelescope -> DCxt -> DType -> DType+mkDForallConstrainedT tele ctxt ty =+ DForallT tele $ if null ctxt then ty else DConstrainedT ctxt ty -- create a list of expressions in the same order as the fields in the first argument -- but with the values as given in the second argument@@ -1372,11 +1446,6 @@ 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@@ -1428,9 +1497,9 @@ 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+dTyVarBndrToDType :: DTyVarBndr flag -> DType+dTyVarBndrToDType (DPlainTV a _) = DVarT a+dTyVarBndrToDType (DKindedTV a _ k) = DVarT a `DSigT` k -- | Extract the underlying 'DType' or 'DKind' from a 'DTypeArg'. This forgets -- information about whether a type is a normal argument or not, so use with@@ -1454,7 +1523,7 @@ -- 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 :: Name -> [DTyVarBndrUnit] -> DType nonFamilyDataReturnType con_name = applyDType (DConT con_name) . map (DTANormal . dTyVarBndrToDType) @@ -1470,7 +1539,7 @@ -- 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 :: [DTypeArg] -> [DTyVarBndrUnit] dataFamInstTvbs = toposortTyVarsOf . map probablyWrongUnDTypeArg -- | Take a list of 'DType's, find their free variables, and sort them in@@ -1486,7 +1555,7 @@ -- -- On older GHCs, this takes measures to avoid returning explicitly bound -- kind variables, which was not possible before @TypeInType@.-toposortTyVarsOf :: [DType] -> [DTyVarBndr]+toposortTyVarsOf :: [DType] -> [DTyVarBndrUnit] toposortTyVarsOf tys = let freeVars :: [Name] freeVars = F.toList $ foldMap fvDType tys@@ -1495,7 +1564,7 @@ varKindSigs = foldMap go_ty tys where go_ty :: DType -> Map Name DKind- go_ty (DForallT _ tvbs t) = go_tvbs tvbs (go_ty t)+ go_ty (DForallT tele t) = go_tele tele (go_ty t) go_ty (DConstrainedT ctxt t) = foldMap go_ty ctxt `mappend` go_ty t go_ty (DAppT t1 t2) = go_ty t1 `mappend` go_ty t2 go_ty (DAppKindT t k) = go_ty t `mappend` go_ty k@@ -1510,12 +1579,16 @@ go_ty (DLitT {}) = mempty go_ty DWildCardT = mempty - go_tvbs :: [DTyVarBndr] -> Map Name DKind -> Map Name DKind+ go_tele :: DForallTelescope -> Map Name DKind -> Map Name DKind+ go_tele (DForallVis tvbs) = go_tvbs tvbs+ go_tele (DForallInvis tvbs) = go_tvbs tvbs++ go_tvbs :: [DTyVarBndr flag] -> Map Name DKind -> Map Name DKind go_tvbs tvbs m = foldr go_tvb m tvbs - go_tvb :: DTyVarBndr -> 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+ go_tvb :: DTyVarBndr flag -> Map Name DKind -> Map Name DKind+ go_tvb (DPlainTV n _) m = M.delete n m+ go_tvb (DKindedTV n _ k) m = M.delete n m `mappend` go_ty k -- | Do a topological sort on a list of tyvars, -- so that binders occur before occurrences@@ -1569,7 +1642,7 @@ maybe S.empty (OS.toSet . fvDType) (M.lookup n varKindSigs) ascribeWithKind n =- maybe (DPlainTV n) (DKindedTV n) (M.lookup n varKindSigs)+ 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@@ -1588,23 +1661,33 @@ filter (not . isKindBinderOnOldGHCs) $ scopedSort freeVars -dtvbName :: DTyVarBndr -> Name-dtvbName (DPlainTV n) = n-dtvbName (DKindedTV n _) = n+dtvbName :: DTyVarBndr flag -> Name+dtvbName (DPlainTV n _) = n+dtvbName (DKindedTV n _ _) = n +-- @mk_qual_do_name mb_mod orig_name@ will simply return @orig_name@ if+-- @mb_mod@ is Nothing. If @mb_mod@ is @Just mod_@, then a new 'Name' will be+-- returned that uses @mod_@ as the new module prefix. This is useful for+-- emulating the behavior of the @QualifiedDo@ extension, which adds module+-- prefixes to functions such as ('>>=') and ('>>').+mk_qual_do_name :: Maybe ModName -> Name -> Name+mk_qual_do_name mb_mod orig_name = case mb_mod of+ Nothing -> orig_name+ Just mod_ -> Name (OccName (nameBase orig_name)) (NameQ mod_)+ -- | Reconstruct an arrow 'DType' from its argument and result types. ravelDType :: DFunArgs -> DType -> DType-ravelDType DFANil res = res-ravelDType (DFAForalls fvf tvbs args) res = DForallT fvf tvbs (ravelDType args res)-ravelDType (DFACxt cxt args) res = DConstrainedT cxt (ravelDType args res)-ravelDType (DFAAnon t args) res = DAppT (DAppT DArrowT t) (ravelDType args res)+ravelDType DFANil res = res+ravelDType (DFAForalls tele args) res = DForallT tele (ravelDType args res)+ravelDType (DFACxt cxt args) res = DConstrainedT cxt (ravelDType args res)+ravelDType (DFAAnon t args) res = DAppT (DAppT DArrowT t) (ravelDType args res) -- | Decompose a function 'DType' into its arguments (the 'DFunArgs') and its -- result type (the 'DType). unravelDType :: DType -> (DFunArgs, DType)-unravelDType (DForallT fvf tvbs ty) =+unravelDType (DForallT tele ty) = let (args, res) = unravelDType ty in- (DFAForalls fvf tvbs args, res)+ (DFAForalls tele args, res) unravelDType (DConstrainedT cxt ty) = let (args, res) = unravelDType ty in (DFACxt cxt args, res)@@ -1617,7 +1700,7 @@ data DFunArgs = DFANil -- ^ No more arguments.- | DFAForalls ForallVisFlag [DTyVarBndr] DFunArgs+ | DFAForalls DForallTelescope DFunArgs -- ^ A series of @forall@ed type variables followed by a dot (if -- 'ForallInvis') or an arrow (if 'ForallVis'). For example, -- the type variables @a1 ... an@ in @forall a1 ... an. r@.@@ -1634,7 +1717,7 @@ -- arguments (e.g., the @c@ in @c => r@), which are instantiated without -- the need for explicit user input. data DVisFunArg- = DVisFADep DTyVarBndr+ = DVisFADep DTyVarBndrUnit -- ^ A visible @forall@ (e.g., @forall a -> a@). | DVisFAAnon DType -- ^ An anonymous argument followed by an arrow (e.g., @a -> r@).@@ -1643,10 +1726,10 @@ -- | Filter the visible function arguments from a list of 'DFunArgs'. filterDVisFunArgs :: DFunArgs -> [DVisFunArg] filterDVisFunArgs DFANil = []-filterDVisFunArgs (DFAForalls fvf tvbs args) =- case fvf of- ForallVis -> map DVisFADep tvbs ++ args'- ForallInvis -> args'+filterDVisFunArgs (DFAForalls tele args) =+ case tele of+ DForallVis tvbs -> map DVisFADep tvbs ++ args'+ DForallInvis _ -> args' where args' = filterDVisFunArgs args filterDVisFunArgs (DFACxt _ args) =@@ -1669,16 +1752,29 @@ unfoldDType = go [] where go :: [DTypeArg] -> DType -> (DType, [DTypeArg])- go acc (DForallT _ _ ty) = go acc ty+ 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+-- | Extract the kind from a 'DTyVarBndr', if one is present.+extractTvbKind :: DTyVarBndr flag -> Maybe DKind+extractTvbKind (DPlainTV _ _) = Nothing+extractTvbKind (DKindedTV _ _ k) = Just k++-- | Set the flag in a list of 'DTyVarBndr's. This is often useful in contexts+-- where one needs to re-use a list of 'DTyVarBndr's from one flag setting to+-- another flag setting. For example, in order to re-use the 'DTyVarBndr's bound+-- by a 'DDataD' in a 'DForallT', one can do the following:+--+-- @+-- case x of+-- 'DDataD' _ _ _ tvbs _ _ _ ->+-- 'DForallT' ('DForallInvis' ('changeDTVFlags' 'SpecifiedSpec' tvbs)) ...+-- @+changeDTVFlags :: newFlag -> [DTyVarBndr oldFlag] -> [DTyVarBndr newFlag]+changeDTVFlags new_flag = map (new_flag <$) -- | Some functions in this module only use certain arguments on particular -- versions of GHC. Other versions of GHC (that don't make use of those
Language/Haskell/TH/Desugar/Expand.hs view
@@ -59,9 +59,9 @@ expand_type ign = go [] where go :: [DTypeArg] -> DType -> q DType- go [] (DForallT fvf tvbs ty) =- DForallT fvf <$> mapM (expand_tvb ign) tvbs- <*> expand_type ign ty+ go [] (DForallT tele ty) =+ DForallT <$> expand_tele ign tele+ <*> expand_type ign ty go _ (DForallT {}) = impossible "A forall type is applied to another type." go [] (DConstrainedT cxt ty) =@@ -88,10 +88,15 @@ finish :: DType -> [DTypeArg] -> q DType finish ty args = return $ applyDType ty args +-- | Expands all type synonyms in the kinds of a @forall@ telescope.+expand_tele :: DsMonad q => IgnoreKinds -> DForallTelescope -> q DForallTelescope+expand_tele ign (DForallVis tvbs) = DForallVis <$> mapM (expand_tvb ign) tvbs+expand_tele ign (DForallInvis tvbs) = DForallInvis <$> mapM (expand_tvb ign) tvbs+ -- | Expands all type synonyms in a type variable binder's kind.-expand_tvb :: DsMonad q => IgnoreKinds -> DTyVarBndr -> q DTyVarBndr-expand_tvb _ tvb@DPlainTV{} = pure tvb-expand_tvb ign (DKindedTV n k) = DKindedTV n <$> expand_type ign k+expand_tvb :: DsMonad q => IgnoreKinds -> DTyVarBndr flag -> q (DTyVarBndr flag)+expand_tvb _ tvb@DPlainTV{} = pure tvb+expand_tvb ign (DKindedTV n flag k) = DKindedTV n flag <$> expand_type ign k -- | Expand a constructor with given arguments expand_con :: forall q.@@ -123,7 +128,7 @@ | 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 <- substTy (M.fromList $ zip (map dtvbName tvbs) syn_args) rhs ty' <- expand_type ign ty return $ applyDType ty' $ map DTANormal rest_args @@ -197,7 +202,7 @@ _ -> True -- Recursive cases- go_ty (DForallT _ tvbs ty) = liftM2 (&&) (allM go_tvb tvbs) (go_ty ty)+ go_ty (DForallT tele ty) = liftM2 (&&) (go_tele tele) (go_ty ty) go_ty (DConstrainedT ctxt ty) = liftM2 (&&) (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)@@ -209,10 +214,14 @@ 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+ go_tele :: DForallTelescope -> q Bool+ go_tele (DForallVis tvbs) = allM go_tvb tvbs+ go_tele (DForallInvis tvbs) = allM go_tvb tvbs + go_tvb :: DTyVarBndr flag -> 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 @@ -234,11 +243,6 @@ 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"
Language/Haskell/TH/Desugar/FV.hs view
@@ -27,7 +27,7 @@ fvDType = go where go :: DType -> OSet Name- go (DForallT _ tvbs ty) = fv_dtvbs tvbs (go ty)+ go (DForallT tele ty) = fv_dtele tele (go ty) go (DConstrainedT ctxt ty) = foldMap fvDType ctxt <> go ty go (DAppT t1 t2) = go t1 <> go t2 go (DAppKindT t k) = go t <> go k@@ -61,11 +61,16 @@ -- Binding forms ----- +-- | Adjust the free variables of something following a 'DForallTelescope'.+fv_dtele :: DForallTelescope -> OSet Name -> OSet Name+fv_dtele (DForallVis tvbs) = fv_dtvbs tvbs+fv_dtele (DForallInvis tvbs) = fv_dtvbs tvbs+ -- | Adjust the free variables of something following 'DTyVarBndr's.-fv_dtvbs :: [DTyVarBndr] -> OSet Name -> OSet Name+fv_dtvbs :: [DTyVarBndr flag] -> OSet Name -> OSet Name fv_dtvbs tvbs fvs = foldr fv_dtvb fvs tvbs -- | Adjust the free variables of something following a 'DTyVarBndr'.-fv_dtvb :: DTyVarBndr -> 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+fv_dtvb :: DTyVarBndr flag -> OSet Name -> OSet Name+fv_dtvb (DPlainTV n _) fvs = OS.delete n fvs+fv_dtvb (DKindedTV n _ k) fvs = OS.delete n fvs <> fvDType k
Language/Haskell/TH/Desugar/Lift.hs view
@@ -23,7 +23,7 @@ import Language.Haskell.TH.Instances () import Language.Haskell.TH.Lift -$(deriveLiftMany [ ''DExp, ''DPat, ''DType, ''ForallVisFlag, ''DTyVarBndr+$(deriveLiftMany [ ''DExp, ''DPat, ''DType, ''DForallTelescope, ''DTyVarBndr , ''DMatch, ''DClause, ''DLetDec, ''DDec, ''DDerivClause, ''DCon , ''DConFields, ''DForeign, ''DPragma, ''DRuleBndr, ''DTySynEqn , ''DPatSynDir , ''NewOrData, ''DDerivStrategy@@ -35,8 +35,12 @@ #if __GLASGOW_HASKELL__ < 801 , ''PatSynArgs #endif+#if __GLASGOW_HASKELL__ < 900+ , ''Specificity+#endif , ''TypeArg, ''DTypeArg , ''FunArgs, ''DFunArgs , ''VisFunArg, ''DVisFunArg+ , ''ForallTelescope ])
Language/Haskell/TH/Desugar/Reify.hs view
@@ -52,6 +52,7 @@ import Data.Set (Set) import Language.Haskell.TH.Datatype+import Language.Haskell.TH.Datatype.TyVarBndr import Language.Haskell.TH.Instances () import Language.Haskell.TH.Syntax hiding ( lift ) @@ -99,7 +100,7 @@ getDataD :: DsMonad q => String -- ^ Print this out on failure -> Name -- ^ Name of the datatype (@data@ or @newtype@) of interest- -> q ([TyVarBndr], [Con])+ -> q ([TyVarBndrUnit], [Con]) getDataD err name = do info <- reifyWithLocals name dec <- case info of@@ -139,16 +140,16 @@ -- are fresh type variable names. -- -- This expands kind synonyms if necessary.-mkExtraKindBinders :: forall q. Quasi q => Kind -> q [TyVarBndr]+mkExtraKindBinders :: forall q. Quasi q => Kind -> q [TyVarBndrUnit] mkExtraKindBinders k = do k' <- runQ $ resolveTypeSynonyms k let (fun_args, _) = unravelType k' vis_fun_args = filterVisFunArgs fun_args mapM mk_tvb vis_fun_args where- mk_tvb :: VisFunArg -> q TyVarBndr+ mk_tvb :: VisFunArg -> q TyVarBndrUnit mk_tvb (VisFADep tvb) = return tvb- mk_tvb (VisFAAnon ki) = KindedTV <$> qNewName "a" <*> return ki+ mk_tvb (VisFAAnon ki) = kindedTV <$> qNewName "a" <*> return ki -- | From the name of a data constructor, retrive the datatype definition it -- is a part of.@@ -380,7 +381,7 @@ #endif ) where- extract_rec_sel_info :: RecSelInfo -> ([TyVarBndr], Type, Type)+ extract_rec_sel_info :: RecSelInfo -> ([TyVarBndrUnit], Type, Type) -- Returns ( Selector type variable binders -- , Record field type -- , constructor result type )@@ -416,16 +417,18 @@ -} -- Reverse-engineer the type of a data constructor.-con_to_type :: [TyVarBndr] -- The type variables bound by a data type head.- -- Only used for Haskell98-style constructors.- -> Type -- The constructor result type.- -- Only used for Haskell98-style constructors.+con_to_type :: [TyVarBndrUnit] -- The type variables bound by a data type head.+ -- Only used for Haskell98-style constructors.+ -> Type -- The constructor result type.+ -- Only used for Haskell98-style constructors. -> Con -> Type con_to_type h98_tvbs h98_result_ty con = case go con of (is_gadt, ty) | is_gadt -> ty | otherwise -> maybeForallT h98_tvbs [] ty where+ -- Note that we deliberately ignore linear types and use (->) everywhere.+ -- See [Gracefully handling linear types] in L.H.TH.Desugar.Core. go :: Con -> (Bool, Type) -- The Bool is True when dealing with a GADT go (NormalC _ stys) = (False, mkArrows (map snd stys) h98_result_ty) go (RecC _ vstys) = (False, mkArrows (map thdOf3 vstys) h98_result_ty)@@ -520,14 +523,14 @@ #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 :: [Type] -> Maybe [TyVarBndrUnit] rejig_tvbs ts = let tvbs = freeVariablesWellScoped ts in if null tvbs then Nothing else Just tvbs - rejig_data_inst_tvbs :: Cxt -> Type -> Maybe Kind -> Maybe [TyVarBndr]+ rejig_data_inst_tvbs :: Cxt -> Type -> Maybe Kind -> Maybe [TyVarBndrUnit] rejig_data_inst_tvbs cxt lhs mk = rejig_tvbs $ cxt ++ [lhs] ++ maybeToList mk #endif@@ -637,17 +640,17 @@ -- 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.+ :: Name -- ^ The class name.+ -> [TyVarBndrUnit] -- ^ The class's type variable binders.+ -> Bool -- ^ If 'True', prepend a class predicate.+ -> Type -- ^ The method type. -> Type quantifyClassMethodType cls_name cls_tvbs prepend meth_ty = add_cls_cxt quantified_meth_ty where add_cls_cxt :: Type -> Type add_cls_cxt- | prepend = ForallT all_cls_tvbs cls_cxt+ | prepend = ForallT (changeTVFlags SpecifiedSpec all_cls_tvbs) cls_cxt | otherwise = id cls_cxt :: Cxt@@ -666,12 +669,13 @@ | otherwise = ForallT meth_tvbs [] meth_ty - meth_tvbs :: [TyVarBndr]- meth_tvbs = deleteFirstsBy ((==) `on` tvName)+ meth_tvbs :: [TyVarBndrSpec]+ meth_tvbs = changeTVFlags SpecifiedSpec $+ 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 :: [TyVarBndrUnit] all_cls_tvbs = freeVariablesWellScoped $ map tvbToTypeWithSig cls_tvbs stripInstanceDec :: Dec -> Dec@@ -686,11 +690,13 @@ mkArrows [] res_ty = res_ty mkArrows (t:ts) res_ty = AppT (AppT ArrowT t) $ mkArrows ts res_ty -maybeForallT :: [TyVarBndr] -> Cxt -> Type -> Type+maybeForallT :: [TyVarBndrUnit] -> 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+ | ForallT tvbs2 cxt2 ty2 <- ty = ForallT (tvbs_spec ++ tvbs2) (cxt ++ cxt2) ty2+ | otherwise = ForallT tvbs_spec cxt ty+ where+ tvbs_spec = changeTVFlags SpecifiedSpec tvbs findCon :: Name -> [Con] -> Maybe (Named Con) findCon n = firstMatch match_con@@ -969,17 +975,17 @@ #endif _ -> Nothing where- ascribe_tf_tvb_kind :: TyVarBndr -> TyVarBndr+ ascribe_tf_tvb_kind :: TyVarBndrUnit -> TyVarBndrUnit ascribe_tf_tvb_kind tvb =- case tvb of- KindedTV{} -> tvb- PlainTV tvn -> KindedTV tvn $ fromMaybe StarT $ Map.lookup tvn cls_tvb_kind_map+ elimTV (\tvn -> kindedTV tvn $ fromMaybe StarT $ Map.lookup tvn cls_tvb_kind_map)+ (\_ _ -> tvb)+ tvb -- Data types have CUSKs when: -- -- 1. All of their type variables have explicit kinds. -- 2. All kind variables in the result kind are explicitly quantified.-datatype_kind :: [TyVarBndr] -> Maybe Kind -> Maybe Kind+datatype_kind :: [TyVarBndrUnit] -> Maybe Kind -> Maybe Kind datatype_kind tvbs m_ki = whenAlt (all tvb_is_kinded tvbs && ki_fvs_are_bound) $ build_kind tvbs (default_res_ki m_ki)@@ -991,14 +997,14 @@ in ki_fvs `Set.isSubsetOf` tvb_vars -- Classes have CUSKs when all of their type variables have explicit kinds.-class_kind :: [TyVarBndr] -> Maybe Kind+class_kind :: [TyVarBndrUnit] -> Maybe Kind class_kind tvbs = whenAlt (all tvb_is_kinded tvbs) $ build_kind tvbs ConstraintT -- Open type families and data families always have CUSKs. Type variables -- without explicit kinds default to Type, as does the return kind if it -- is not specified.-open_ty_fam_kind :: [TyVarBndr] -> Maybe Kind -> Maybe Kind+open_ty_fam_kind :: [TyVarBndrUnit] -> Maybe Kind -> Maybe Kind open_ty_fam_kind tvbs m_ki = build_kind (map default_tvb tvbs) (default_res_ki m_ki) @@ -1006,7 +1012,7 @@ -- -- 1. All of their type variables have explicit kinds. -- 2. An explicit return kind is supplied.-closed_ty_fam_kind :: [TyVarBndr] -> Maybe Kind -> Maybe Kind+closed_ty_fam_kind :: [TyVarBndrUnit] -> Maybe Kind -> Maybe Kind closed_ty_fam_kind tvbs m_ki = case m_ki of Just ki -> whenAlt (all tvb_is_kinded tvbs) $@@ -1017,7 +1023,7 @@ -- -- 1. All of their type variables have explicit kinds. -- 2. The right-hand-side type is annotated with an explicit kind.-ty_syn_kind :: [TyVarBndr] -> Type -> Maybe Kind+ty_syn_kind :: [TyVarBndrUnit] -> Type -> Maybe Kind ty_syn_kind tvbs rhs = case rhs of SigT _ ki -> whenAlt (all tvb_is_kinded tvbs) $@@ -1029,31 +1035,31 @@ -- this function is `Maybe Kind` because there are situations where even -- this amount of information is not sufficient to determine the full kind. -- See Note [The limitations of standalone kind signatures].-build_kind :: [TyVarBndr] -> Kind -> Maybe Kind+build_kind :: [TyVarBndrUnit] -> Kind -> Maybe Kind build_kind arg_kinds res_kind = fmap quantifyType $ fst $ foldr go (Just res_kind, Set.fromList (freeVariables res_kind)) arg_kinds where- go :: TyVarBndr -> (Maybe Kind, Set Name) -> (Maybe Kind, Set Name)+ go :: TyVarBndrUnit -> (Maybe Kind, Set Name) -> (Maybe Kind, Set Name) go tvb (res, res_fvs) =- case tvb of- PlainTV n- -> ( if n `Set.member` res_fvs- then forall_vis tvb res- else Nothing -- We have a type variable binder without an- -- explicit kind that is not used dependently, so- -- we cannot build a kind from it. This is the- -- only case where we return Nothing.- , res_fvs- )- KindedTV n k- -> ( if n `Set.member` res_fvs- then forall_vis tvb res- else fmap (ArrowT `AppT` k `AppT`) res- , Set.fromList (freeVariables k) `Set.union` res_fvs- )+ elimTV (\n ->+ ( if n `Set.member` res_fvs+ then forall_vis tvb res+ else Nothing -- We have a type variable binder without an+ -- explicit kind that is not used dependently, so+ -- we cannot build a kind from it. This is the+ -- only case where we return Nothing.+ , res_fvs+ ))+ (\n k ->+ ( if n `Set.member` res_fvs+ then forall_vis tvb res+ else fmap (ArrowT `AppT` k `AppT`) res+ , Set.fromList (freeVariables k) `Set.union` res_fvs+ ))+ tvb - forall_vis :: TyVarBndr -> Maybe Kind -> Maybe Kind+ forall_vis :: TyVarBndrUnit -> Maybe Kind -> Maybe Kind #if __GLASGOW_HASKELL__ >= 809 forall_vis tvb m_ki = fmap (ForallVisT [tvb]) m_ki -- One downside of this approach is that we generate kinds like this:@@ -1069,20 +1075,18 @@ forall_vis _ _ = Nothing #endif -tvb_is_kinded :: TyVarBndr -> Bool+tvb_is_kinded :: TyVarBndr_ flag -> Bool tvb_is_kinded = isJust . tvb_kind_maybe -tvb_kind_maybe :: TyVarBndr -> Maybe Kind-tvb_kind_maybe PlainTV{} = Nothing-tvb_kind_maybe (KindedTV _ k) = Just k+tvb_kind_maybe :: TyVarBndr_ flag -> Maybe Kind+tvb_kind_maybe = elimTV (\_ -> Nothing) (\_ k -> Just k) vis_arg_kind_maybe :: VisFunArg -> Maybe Kind vis_arg_kind_maybe (VisFADep tvb) = tvb_kind_maybe tvb vis_arg_kind_maybe (VisFAAnon k) = Just k -default_tvb :: TyVarBndr -> TyVarBndr-default_tvb (PlainTV n) = KindedTV n StarT-default_tvb tvb@KindedTV{} = tvb+default_tvb :: TyVarBndrUnit -> TyVarBndrUnit+default_tvb tvb = elimTV (\n -> kindedTV n StarT) (\_ _ -> tvb) tvb default_res_ki :: Maybe Kind -> Kind default_res_ki = fromMaybe StarT
Language/Haskell/TH/Desugar/Subst.hs view
@@ -17,7 +17,8 @@ DSubst, -- * Capture-avoiding substitution- substTy, substTyVarBndrs, unionSubsts, unionMaybeSubsts,+ substTy, substForallTelescope, substTyVarBndrs,+ unionSubsts, unionMaybeSubsts, -- * Matching a type template against a type IgnoreKinds(..), matchTy@@ -40,10 +41,10 @@ -- | Capture-avoiding substitution on types substTy :: Quasi q => DSubst -> DType -> q DType-substTy vars (DForallT fvf tvbs ty) =- substTyVarBndrs vars tvbs $ \vars' tvbs' -> do- ty' <- substTy vars' ty- return $ DForallT fvf tvbs' ty'+substTy vars (DForallT tele ty) = do+ (vars', tele') <- substForallTelescope vars tele+ ty' <- substTy vars' ty+ return $ DForallT tele' ty' substTy vars (DConstrainedT cxt ty) = DConstrainedT <$> mapM (substTy vars) cxt <*> substTy vars ty substTy vars (DAppT t1 t2) =@@ -62,22 +63,30 @@ 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'+substForallTelescope :: Quasi q => DSubst -> DForallTelescope+ -> q (DSubst, DForallTelescope)+substForallTelescope vars tele =+ case tele of+ DForallVis tvbs -> do+ (vars', tvbs') <- substTyVarBndrs vars tvbs+ return (vars', DForallVis tvbs')+ DForallInvis tvbs -> do+ (vars', tvbs') <- substTyVarBndrs vars tvbs+ return (vars', DForallInvis tvbs') -substTvb :: Quasi q => DSubst -> DTyVarBndr- -> q (DSubst, DTyVarBndr)-substTvb vars (DPlainTV n) = do+substTyVarBndrs :: Quasi q => DSubst -> [DTyVarBndr flag]+ -> q (DSubst, [DTyVarBndr flag])+substTyVarBndrs = mapAccumLM substTvb++substTvb :: Quasi q => DSubst -> DTyVarBndr flag+ -> q (DSubst, DTyVarBndr flag)+substTvb vars (DPlainTV n flag) = do new_n <- qNewName (nameBase n)- return (M.insert n (DVarT new_n) vars, DPlainTV new_n)-substTvb vars (DKindedTV n k) = do+ return (M.insert n (DVarT new_n) vars, DPlainTV new_n flag)+substTvb vars (DKindedTV n flag k) = do new_n <- qNewName (nameBase n) k' <- substTy vars k- return (M.insert n (DVarT new_n) vars, DKindedTV new_n k')+ return (M.insert n (DVarT new_n) vars, DKindedTV new_n flag k') -- | Computes the union of two substitutions. Fails if both subsitutions map -- the same variable to different types.
Language/Haskell/TH/Desugar/Sweeten.hs view
@@ -40,13 +40,12 @@ import Control.Arrow import Language.Haskell.TH hiding (cxt)+import Language.Haskell.TH.Datatype.TyVarBndr import Language.Haskell.TH.Desugar.AST-import Language.Haskell.TH.Desugar.Core (DTypeArg(..))+import Language.Haskell.TH.Desugar.Core (DTypeArg(..), changeDTVFlags) import Language.Haskell.TH.Desugar.Util -import Data.Maybe ( maybeToList, mapMaybe )- expToTH :: DExp -> Exp expToTH (DVarE n) = VarE n expToTH (DConE n) = ConE n@@ -54,7 +53,7 @@ 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 (DLetE decs exp) = LetE (map letDecToTH decs) (expToTH exp) expToTH (DSigE exp ty) = SigE (expToTH exp) (typeToTH ty) #if __GLASGOW_HASKELL__ < 709 expToTH (DStaticE _) = error "Static expressions supported only in GHC 7.10+"@@ -82,59 +81,59 @@ patToTH DWildP = WildP decsToTH :: [DDec] -> [Dec]-decsToTH = concatMap decToTH+decsToTH = map decToTH -- | This returns a list of @Dec@s because GHC 7.6.3 does not have -- a one-to-one mapping between 'DDec' and @Dec@.-decToTH :: DDec -> [Dec]-decToTH (DLetDec d) = maybeToList (letDecToTH d)+decToTH :: DDec -> Dec+decToTH (DLetDec d) = 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)]+ 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)]+ 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)]+ 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)]+ NewtypeD (cxtToTH cxt) n (map tvbToTH tvbs) (conToTH con)+ (map derivingToTH derivings) #endif decToTH (DDataD Newtype _cxt _n _tvbs _mk _cons _derivings) = error "Newtype declaration without exactly 1 constructor."-decToTH (DTySynD n tvbs ty) = [TySynD n (map tvbToTH tvbs) (typeToTH ty)]+decToTH (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)]+ ClassD (cxtToTH cxt) n (map tvbToTH tvbs) fds (decsToTH decs) decToTH (DInstanceD over mtvbs _cxt _ty decs) =- [instanceDToTH over cxt' ty' decs]+ instanceDToTH over cxt' ty' decs where- (cxt', ty') = case mtvbs of+ (cxt', ty') = case fmap (changeDTVFlags SpecifiedSpec) mtvbs of Nothing -> (_cxt, _ty) Just _tvbs -> #if __GLASGOW_HASKELL__ < 800 || __GLASGOW_HASKELL__ >= 802- ([], DForallT ForallInvis _tvbs $ DConstrainedT _cxt _ty)+ ([], DForallT (DForallInvis _tvbs) $ DConstrainedT _cxt _ty) #else -- See #117 error $ "Explicit foralls in instance declarations " ++ "are broken on GHC 8.0." #endif-decToTH (DForeignD f) = [ForeignD (foreignToTH f)]+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)]+ 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)]+ 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)]+ DataFamilyD n (map tvbToTH tvbs) (fmap typeToTH mk) #else- [FamilyD DataFam n (map tvbToTH tvbs) (fmap typeToTH mk)]+ 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@@ -143,30 +142,29 @@ (Data, _) -> DDataCons cons in dataInstDecToTH ndc cxt mtvbs lhs mk derivings #if __GLASGOW_HASKELL__ >= 807-decToTH (DTySynInstD eqn) = [TySynInstD (snd $ tySynEqnToTH eqn)]+decToTH (DTySynInstD eqn) = TySynInstD (snd $ tySynEqnToTH eqn) #else decToTH (DTySynInstD eqn) = let (n, eqn') = tySynEqnToTH eqn in- [TySynInstD n eqn']+ 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)- ]+ 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)]+ ClosedTypeFamilyD n (map tvbToTH tvbs) (frsToTH frs) (map (snd . tySynEqnToTH) eqns) #endif-decToTH (DRoleAnnotD n roles) = [RoleAnnotD n roles]+decToTH (DRoleAnnotD n roles) = RoleAnnotD n roles decToTH (DStandaloneDerivD mds mtvbs _cxt _ty) =- [standaloneDerivDToTH mds cxt' ty']+ standaloneDerivDToTH mds cxt' ty' where- (cxt', ty') = case mtvbs of+ (cxt', ty') = case fmap (changeDTVFlags SpecifiedSpec) mtvbs of Nothing -> (_cxt, _ty) Just _tvbs -> #if __GLASGOW_HASKELL__ < 710 || __GLASGOW_HASKELL__ >= 802- ([], DForallT ForallInvis _tvbs $ DConstrainedT _cxt _ty)+ ([], DForallT (DForallInvis _tvbs) $ DConstrainedT _cxt _ty) #else -- See #117 error $ "Explicit foralls in standalone deriving declarations "@@ -176,17 +174,17 @@ decToTH (DDefaultSigD {}) = error "Default method signatures supported only in GHC 7.10+" #else-decToTH (DDefaultSigD n ty) = [DefaultSigD n (typeToTH ty)]+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)]+decToTH (DPatSynD n args dir pat) = PatSynD n args (patSynDirToTH dir) (patToTH pat)+decToTH (DPatSynSigD n ty) = PatSynSigD n (typeToTH ty) #else decToTH DPatSynD{} = patSynErr decToTH DPatSynSigD{} = patSynErr #endif #if __GLASGOW_HASKELL__ >= 809-decToTH (DKiSigD n ki) = [KiSigD n (typeToTH ki)]+decToTH (DKiSigD n ki) = KiSigD n (typeToTH ki) #else decToTH (DKiSigD {}) = error "Standalone kind signatures supported only in GHC 8.10+"@@ -204,34 +202,34 @@ | DDataCons [DCon] -- | Sweeten a 'DDataInstD'.-dataInstDecToTH :: DNewOrDataCons -> DCxt -> Maybe [DTyVarBndr] -> DType- -> Maybe DKind -> [DDerivClause] -> [Dec]+dataInstDecToTH :: DNewOrDataCons -> DCxt -> Maybe [DTyVarBndrUnit] -> DType+ -> Maybe DKind -> [DDerivClause] -> Dec dataInstDecToTH ndc cxt _mtvbs lhs _mk derivings = case ndc of DNewtypeCon con -> #if __GLASGOW_HASKELL__ >= 807- [NewtypeInstD (cxtToTH cxt) (fmap (fmap tvbToTH) _mtvbs) (typeToTH lhs)- (fmap typeToTH _mk) (conToTH con)- (concatMap derivClauseToTH derivings)]+ 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)]+ 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)]+ 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)]+ 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)]+ 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)]+ DataInstD (cxtToTH cxt) _n _lhs_args (map conToTH cons)+ (map derivingToTH derivings) #endif where _lhs' = typeToTH lhs@@ -247,10 +245,10 @@ 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)+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@@ -260,14 +258,13 @@ 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)+-- | Sweeten a 'DLetDec'.+letDecToTH :: DLetDec -> Dec+letDecToTH (DFunD name clauses) = FunD name (map clauseToTH clauses)+letDecToTH (DValD pat exp) = ValD (patToTH pat) (NormalB (expToTH exp)) []+letDecToTH (DSigD name ty) = SigD name (typeToTH ty)+letDecToTH (DInfixD f name) = InfixD f name+letDecToTH (DPragmaD prag) = PragmaD (pragmaToTH prag) conToTH :: DCon -> Con #if __GLASGOW_HASKELL__ > 710@@ -363,29 +360,29 @@ ImportF cc safety str n (typeToTH ty) foreignToTH (DExportF cc str n ty) = ExportF cc str n (typeToTH ty) -pragmaToTH :: DPragma -> Maybe Pragma-pragmaToTH (DInlineP n inl rm phases) = Just $ InlineP n inl rm phases+pragmaToTH :: DPragma -> Pragma+pragmaToTH (DInlineP n inl rm phases) = InlineP n inl rm phases pragmaToTH (DSpecialiseP n ty m_inl phases) =- Just $ SpecialiseP n (typeToTH ty) m_inl phases-pragmaToTH (DSpecialiseInstP ty) = Just $ SpecialiseInstP (typeToTH ty)+ SpecialiseP n (typeToTH ty) m_inl phases+pragmaToTH (DSpecialiseInstP ty) = SpecialiseInstP (typeToTH ty) #if __GLASGOW_HASKELL__ >= 807 pragmaToTH (DRuleP str mtvbs rbs lhs rhs phases) =- Just $ RuleP str (fmap (fmap tvbToTH) mtvbs) (map ruleBndrToTH rbs)- (expToTH lhs) (expToTH rhs) phases+ 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+ RuleP str (map ruleBndrToTH rbs) (expToTH lhs) (expToTH rhs) phases #endif-pragmaToTH (DAnnP target exp) = Just $ AnnP target (expToTH exp)+pragmaToTH (DAnnP target exp) = AnnP target (expToTH exp) #if __GLASGOW_HASKELL__ < 709-pragmaToTH (DLineP {}) = Nothing+pragmaToTH (DLineP {}) = error "LINE pragmas only supported in GHC 7.10+" #else-pragmaToTH (DLineP n str) = Just $ LineP n str+pragmaToTH (DLineP n str) = LineP n str #endif #if __GLASGOW_HASKELL__ < 801-pragmaToTH (DCompleteP {}) = Nothing+pragmaToTH (DCompleteP {}) = error "COMPLETE pragmas only supported in GHC 8.2+" #else-pragmaToTH (DCompleteP cls mty) = Just $ CompleteP cls mty+pragmaToTH (DCompleteP cls mty) = CompleteP cls mty #endif ruleBndrToTH :: DRuleBndr -> RuleBndr@@ -417,19 +414,18 @@ -- We need a special case for DForallT ForallInvis followed by DConstrainedT -- so that we may collapse them into a single ForallT when sweetening. -- See Note [Desugaring and sweetening ForallT] in L.H.T.Desugar.Core.-typeToTH (DForallT ForallInvis tvbs (DConstrainedT ctxt ty)) =+typeToTH (DForallT (DForallInvis tvbs) (DConstrainedT ctxt ty)) = ForallT (map tvbToTH tvbs) (map predToTH ctxt) (typeToTH ty)-typeToTH (DForallT fvf tvbs ty) =- case fvf of- ForallInvis -> ForallT tvbs' [] ty'- ForallVis ->+typeToTH (DForallT tele ty) =+ case tele of+ DForallInvis tvbs -> ForallT (map tvbToTH tvbs) [] ty'+ DForallVis _tvbs -> #if __GLASGOW_HASKELL__ >= 809- ForallVisT tvbs' ty'+ ForallVisT (map tvbToTH _tvbs) ty' #else error "Visible dependent quantification supported only in GHC 8.10+" #endif where- tvbs' = map tvbToTH tvbs ty' = typeToTH ty typeToTH (DConstrainedT cxt ty) = ForallT [] (map predToTH cxt) (typeToTH ty) typeToTH (DAppT t1 t2) = AppT (typeToTH t1) (typeToTH t2)@@ -451,9 +447,9 @@ typeToTH (DAppKindT t _) = typeToTH t #endif -tvbToTH :: DTyVarBndr -> TyVarBndr-tvbToTH (DPlainTV n) = PlainTV n-tvbToTH (DKindedTV n k) = KindedTV n (typeToTH k)+tvbToTH :: DTyVarBndr flag -> TyVarBndr_ flag+tvbToTH (DPlainTV n flag) = plainTVFlag n flag+tvbToTH (DKindedTV n flag k) = kindedTVFlag n flag (typeToTH k) cxtToTH :: DCxt -> Cxt cxtToTH = map predToTH@@ -529,15 +525,12 @@ -- We need a special case for DForallT ForallInvis followed by DConstrainedT -- so that we may collapse them into a single ForallT when sweetening. -- See Note [Desugaring and sweetening ForallT] in L.H.T.Desugar.Core.-predToTH (DForallT ForallInvis tvbs (DConstrainedT ctxt p)) =+predToTH (DForallT (DForallInvis tvbs) (DConstrainedT ctxt p)) = ForallT (map tvbToTH tvbs) (map predToTH ctxt) (predToTH p)-predToTH (DForallT fvf tvbs p) =- case fvf of- ForallInvis -> ForallT tvbs' [] p'- ForallVis -> error "Visible dependent quantifier spotted at head of a constraint"- where- tvbs' = map tvbToTH tvbs- p' = predToTH p+predToTH (DForallT tele p) =+ case tele of+ DForallInvis tvbs -> ForallT (map tvbToTH tvbs) [] (predToTH p)+ DForallVis _ -> error "Visible dependent quantifier spotted at head of a constraint" predToTH (DConstrainedT cxt p) = ForallT [] (map predToTH cxt) (predToTH p) #else predToTH (DForallT {}) = error "Quantified constraints supported only in GHC 8.6+"
Language/Haskell/TH/Desugar/Util.hs view
@@ -30,7 +30,7 @@ unboxedTupleNameDegree_maybe, splitTuple_maybe, topEverywhereM, isInfixDataCon, isTypeKindName, typeKindName,- unSigType, unfoldType, ForallVisFlag(..), FunArgs(..), VisFunArg(..),+ unSigType, unfoldType, ForallTelescope(..), FunArgs(..), VisFunArg(..), filterVisFunArgs, ravelType, unravelType, TypeArg(..), applyType, filterTANormals, probablyWrongUnTypeArg #if __GLASGOW_HASKELL__ >= 800@@ -41,7 +41,7 @@ import Prelude hiding (mapM, foldl, concatMap, any) import Language.Haskell.TH hiding ( cxt )-import Language.Haskell.TH.Datatype (tvName)+import Language.Haskell.TH.Datatype.TyVarBndr import qualified Language.Haskell.TH.Desugar.OSet as OS import Language.Haskell.TH.Desugar.OSet (OSet) import Language.Haskell.TH.Syntax@@ -111,9 +111,8 @@ 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+stripPlainTV_maybe :: TyVarBndr_ flag -> Maybe Name+stripPlainTV_maybe = elimTV Just (\_ _ -> Nothing) -- | Report that a certain TH construct is impossible impossible :: Fail.MonadFail q => String -> q a@@ -121,18 +120,17 @@ -- | Convert a 'TyVarBndr' into a 'Type', dropping the kind signature -- (if it has one).-tvbToType :: TyVarBndr -> Type+tvbToType :: TyVarBndr_ flag -> 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+tvbToTypeWithSig :: TyVarBndr_ flag -> Type+tvbToTypeWithSig = elimTV VarT (\n k -> SigT (VarT n) k) -- | Convert a 'TyVarBndr' into a 'TypeArg' (specifically, a 'TANormal'), -- preserving the kind signature (if it has one).-tvbToTANormalWithSig :: TyVarBndr -> TypeArg+tvbToTANormalWithSig :: TyVarBndr_ flag -> TypeArg tvbToTANormalWithSig = TANormal . tvbToTypeWithSig -- | Do two names name the same thing?@@ -206,18 +204,23 @@ = Just args go _ _ = Nothing --- | Is a @forall@ invisible (e.g., @forall a b. {...}@, with a dot) or visible--- (e.g., @forall a b -> {...}@, with an arrow)?-data ForallVisFlag- = ForallVis -- ^ A visible @forall@ (with an arrow)- | ForallInvis -- ^ An invisible @forall@ (with a dot)+-- | The type variable binders in a @forall@. This is not used by the TH AST+-- itself, but this is used as an intermediate data type in 'FAForalls'.+data ForallTelescope+ = ForallVis [TyVarBndrUnit]+ -- ^ A visible @forall@ (e.g., @forall a -> {...}@).+ -- These do not have any notion of specificity, so we use+ -- '()' as a placeholder value in the 'TyVarBndr's.+ | ForallInvis [TyVarBndrSpec]+ -- ^ An invisible @forall@ (e.g., @forall a {b} c -> {...}@),+ -- where each binder has a 'Specificity'. deriving (Eq, Show, Typeable, Data) -- | The list of arguments in a function 'Type'. data FunArgs = FANil -- ^ No more arguments.- | FAForalls ForallVisFlag [TyVarBndr] FunArgs+ | FAForalls ForallTelescope FunArgs -- ^ A series of @forall@ed type variables followed by a dot (if -- 'ForallInvis') or an arrow (if 'ForallVis'). For example, -- the type variables @a1 ... an@ in @forall a1 ... an. r@.@@ -234,7 +237,7 @@ -- arguments (e.g., the @c@ in @c => r@), which are instantiated without -- the need for explicit user input. data VisFunArg- = VisFADep TyVarBndr+ = VisFADep TyVarBndrUnit -- ^ A visible @forall@ (e.g., @forall a -> a@). | VisFAAnon Type -- ^ An anonymous argument followed by an arrow (e.g., @a -> r@).@@ -243,10 +246,10 @@ -- | Filter the visible function arguments from a list of 'FunArgs'. filterVisFunArgs :: FunArgs -> [VisFunArg] filterVisFunArgs FANil = []-filterVisFunArgs (FAForalls fvf tvbs args) =- case fvf of- ForallVis -> map VisFADep tvbs ++ args'- ForallInvis -> args'+filterVisFunArgs (FAForalls tele args) =+ case tele of+ ForallVis tvbs -> map VisFADep tvbs ++ args'+ ForallInvis _ -> args' where args' = filterVisFunArgs args filterVisFunArgs (FACxt _ args) =@@ -260,10 +263,10 @@ -- We need a special case for FAForalls ForallInvis followed by FACxt so that we may -- collapse them into a single ForallT when raveling. -- See Note [Desugaring and sweetening ForallT] in L.H.T.Desugar.Core.-ravelType (FAForalls ForallInvis tvbs (FACxt p args)) res =+ravelType (FAForalls (ForallInvis tvbs) (FACxt p args)) res = ForallT tvbs p (ravelType args res)-ravelType (FAForalls ForallInvis tvbs args) res = ForallT tvbs [] (ravelType args res)-ravelType (FAForalls ForallVis _tvbs _args) _res =+ravelType (FAForalls (ForallInvis tvbs) args) res = ForallT tvbs [] (ravelType args res)+ravelType (FAForalls (ForallVis _tvbs) _args) _res = #if __GLASGOW_HASKELL__ >= 809 ForallVisT _tvbs (ravelType _args _res) #else@@ -277,14 +280,14 @@ unravelType :: Type -> (FunArgs, Type) unravelType (ForallT tvbs cxt ty) = let (args, res) = unravelType ty in- (FAForalls ForallInvis tvbs (FACxt cxt args), res)+ (FAForalls (ForallInvis tvbs) (FACxt cxt args), res) unravelType (AppT (AppT ArrowT t1) t2) = let (args, res) = unravelType t2 in (FAAnon t1 args, res) #if __GLASGOW_HASKELL__ >= 809 unravelType (ForallVisT tvbs ty) = let (args, res) = unravelType ty in- (FAForalls ForallVis tvbs args, res)+ (FAForalls (ForallVis tvbs) args, res) #endif unravelType t = (FANil, t)
README.md view
@@ -2,7 +2,7 @@ ==================== [](http://hackage.haskell.org/package/th-desugar)-[](https://travis-ci.org/goldfirere/th-desugar)+[](https://github.com/goldfirere/th-desugar/actions?query=workflow%3AHaskell-CI) This package provides the `Language.Haskell.TH.Desugar` module, which desugars Template Haskell's rich encoding of Haskell syntax into a simpler encoding.@@ -26,6 +26,9 @@ Known limitations -----------------++## Limited support for kind inference+ `th-desugar` sometimes has to construct types for certain Haskell entities. For instance, `th-desugar` desugars all Haskell98-style constructors to use GADT syntax, so the following:@@ -88,3 +91,12 @@ 4. Locally reified data constructors 5. Locally reified type family instances (on GHC 8.8 and later, in which the Template Haskell AST supports explicit `foralls` in type family equations)++## Limited support for linear types++Currently, the `th-desugar` AST deliberately makes it impossible to represent+linear types, and desugaring a linear function arrow will simply turn into a+normal function arrow `(->)`. This choice is partly motivated by issues in the+way that linear types interact with Template Haskell, which sometimes make it+impossible to tell whether a reified function type is linear or not. See, for+instance, [GHC#18378](https://gitlab.haskell.org/ghc/ghc/-/issues/18378).
Test/DsDec.hs view
@@ -32,7 +32,6 @@ import Language.Haskell.TH.Syntax ( qReport ) import Control.Monad-import Data.Maybe( mapMaybe ) $(dsDecSplice S.dectest1) $(dsDecSplice S.dectest2)@@ -83,9 +82,8 @@ $(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+ [DDataD nd [] name [DPlainTV tvbName ()] k cons []] <- dsDecs decs+ recsels <- getRecordSelectors cons let num_sels = length recsels `div` 2 -- ignore type sigs when (num_sels /= S.rec_sel_test_num_sels) $ qReport True $ "Wrong number of record selectors extracted.\n"@@ -97,5 +95,5 @@ 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))+ plaindata = [DDataD nd [] name [DPlainTV tvbName ()] k (map unrecord cons) []]+ return (decsToTH plaindata ++ map letDecToTH recsels))
Test/ReifyTypeCUSKs.hs view
@@ -96,7 +96,7 @@ #if __GLASGOW_HASKELL__ >= 800 ++ [ (8, let k = mkName "k" in- DForallT ForallInvis [DPlainTV k] $+ DForallT (DForallInvis [DPlainTV k SpecifiedSpec]) $ DArrowT `DAppT` DVarT k `DAppT` (DArrowT `DAppT` DVarT k `DAppT` typeKind)) ]@@ -105,19 +105,19 @@ ++ [ (9, let j = mkName "j" k = mkName "k" in- DForallT ForallInvis [DPlainTV j] $+ DForallT (DForallInvis [DPlainTV j SpecifiedSpec]) $ DArrowT `DAppT` DVarT j `DAppT`- (DForallT ForallInvis [DPlainTV k] $+ (DForallT (DForallInvis [DPlainTV k SpecifiedSpec]) $ DArrowT `DAppT` DVarT k `DAppT` typeKind)) ] #endif #if __GLASGOW_HASKELL__ >= 809 ++ [ (10, let k = mkName "k" in- DForallT ForallVis [DKindedTV k typeKind] $+ DForallT (DForallVis [DKindedTV k () typeKind]) $ DArrowT `DAppT` DVarT k `DAppT` typeKind) , (11, let k = mkName "k" in- DForallT ForallVis [DPlainTV k] $+ DForallT (DForallVis [DPlainTV k ()]) $ DArrowT `DAppT` DVarT k `DAppT` typeKind) ] #endif
Test/ReifyTypeSigs.hs view
@@ -61,13 +61,14 @@ typeKind = DConT typeKindName boolKind = DConT ''Bool k_to_type = DArrowT `DAppT` DVarT k `DAppT` typeKind- forall_k_invis_k_to_type = DForallT ForallInvis [DPlainTV k] k_to_type in+ forall_k_invis_k_to_type =+ DForallT (DForallInvis [DPlainTV k SpecifiedSpec]) k_to_type in [ (1, forall_k_invis_k_to_type) , (2, k_to_type) , (3, forall_k_invis_k_to_type) , (4, forall_k_invis_k_to_type) , (5, k_to_type)- , (6, DForallT ForallVis [DKindedTV k boolKind] $+ , (6, DForallT (DForallVis [DKindedTV k () boolKind]) $ DArrowT `DAppT` (DConT ''Proxy `DAppT` DVarT k) `DAppT` DConT ''Constraint) , (7, DArrowT `DAppT` boolKind `DAppT`
Test/Run.hs view
@@ -8,7 +8,8 @@ RankNTypes, TypeFamilies, DataKinds, ConstraintKinds, PolyKinds, MultiParamTypeClasses, FlexibleInstances, ExistentialQuantification,- ScopedTypeVariables, GADTs, ViewPatterns, TupleSections #-}+ ScopedTypeVariables, GADTs, ViewPatterns, TupleSections,+ TypeOperators #-} {-# 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@@ -58,6 +59,10 @@ import qualified Data.Map as M import Data.Proxy +#if __GLASGOW_HASKELL__ >= 900+import Prelude as P+#endif+ -- | -- Convert a HUnit test suite to a spec. This can be used to run existing -- HUnit tests with Hspec.@@ -143,6 +148,9 @@ #if __GLASGOW_HASKELL__ >= 809 , "tuple_sections" ~: $test51_tuple_sections @=? $(dsSplice test51_tuple_sections) #endif+#if __GLASGOW_HASKELL__ >= 900+ , "qual_do" ~: $test52_qual_do @=? $(dsSplice test52_qual_do)+#endif ] test35a = $test35_expand@@ -228,10 +236,10 @@ flatten_dvald :: Bool flatten_dvald = let s1 = $(flatten_dvald_test)- s2 = $(do exp <- flatten_dvald_test- DLetE ddecs dexp <- dsExp exp+ s2 = $(do expr <- flatten_dvald_test+ DLetE ddecs dexpr <- dsExp expr flattened <- fmap concat $ mapM flattenDValD ddecs- return $ expToTH $ DLetE flattened dexp ) in+ return $ expToTH $ DLetE flattened dexpr ) in s1 == s2 test_rec_sels :: Bool@@ -273,7 +281,7 @@ (decsToTH [ -- type family F (x :: k) :: k DOpenTypeFamilyD (DTypeFamilyHead fam_name- [DKindedTV x (DVarT k)]+ [DKindedTV x () (DVarT k)] (DKindSig (DVarT k)) Nothing) -- type instance F (x :: ()) = x@@ -299,17 +307,23 @@ test_t92 = $(do a <- newName "a" f <- newName "f"- let t = DForallT ForallInvis [DPlainTV f] (DVarT f `DAppT` DVarT a)- toposortTyVarsOf [t] `eqTHSplice` [DPlainTV a])+ let t = DForallT (DForallInvis [DPlainTV f SpecifiedSpec])+ (DVarT f `DAppT` DVarT a)+ toposortTyVarsOf [t] `eqTHSplice` [DPlainTV a ()]) test_t97 :: Bool test_t97 = $(do a <- newName "a" k <- newName "k"- let orig_ty = DForallT ForallInvis- [DKindedTV a (DConT ''Constant `DAppT` DConT ''Int `DAppT` DVarT k)]+ let orig_ty = DForallT+ (DForallInvis+ [DKindedTV a SpecifiedSpec+ (DConT ''Constant `DAppT` DConT ''Int+ `DAppT` DVarT k)]) (DVarT a)- expected_ty = DForallT ForallInvis [DKindedTV a (DVarT k)] (DVarT a)+ expected_ty = DForallT (DForallInvis+ [DKindedTV a SpecifiedSpec (DVarT k)])+ (DVarT a) expanded_ty <- expandType orig_ty expected_ty `eqTHSplice` expanded_ty) @@ -322,8 +336,8 @@ 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) [] []))+ [decToTH (DDataD Data [] data_name [DPlainTV a ()]+ (Just data_kind_sig) [] [])] (getDataD "th-desugar: Impossible" data_name) [| $(Syn.lift (length tvbs)) |]) #else@@ -337,7 +351,7 @@ MkT :: forall a. { unT :: a } -> T a |] info <- withLocalDeclarations decs (dsReify (mkName "unT")) let -- forall a. T a -> a- exp_ty = DForallT ForallInvis [DPlainTV (mkName "a")] $+ exp_ty = DForallT (DForallInvis [DPlainTV (mkName "a") SpecifiedSpec]) $ DArrowT `DAppT` (DConT (mkName "T") `DAppT` DVarT (mkName "a")) `DAppT` DVarT (mkName "a") case info of@@ -351,13 +365,21 @@ -- bother testing this on pre-8.0 GHCs. #endif -test_t102 :: Bool+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)+ $(do decs1 <- [d| data Foo x where MkFoo :: forall a. { unFoo :: a } -> Foo a |]+ let b1 = withLocalDeclarations decs1 $ do+ [DDataD _ _ _ _ _ cons1 _] <- dsDecs decs1+ recs1 <- getRecordSelectors cons1+ (length recs1 `div` 2) `eqTHSplice` 1+ decs2 <- [d| data HList l where+ Nil :: HList '[]+ (:>) :: { hhead :: x, htail :: HList xs } -> HList (x ': xs) |]+ let b2 = withLocalDeclarations decs2 $ do+ [DDataD _ _ _ _ _ cons2 _] <- dsDecs decs2+ recs2 <- getRecordSelectors cons2+ (length recs2 `div` 2) `eqTHSplice` 2+ [| [$b1, $b2] |]) test_t103 :: Bool test_t103 =@@ -365,7 +387,7 @@ $(do decs <- [d| data P (a :: k) = MkP |] [DDataD _ _ _ _ _ [DCon tvbs _ _ _ _] _] <- dsDecs decs case tvbs of- [DPlainTV k, DKindedTV a (DVarT k')]+ [DPlainTV k SpecifiedSpec, DKindedTV a SpecifiedSpec (DVarT k')] | nameBase k == "k" , nameBase a == "a" , k == k'@@ -382,8 +404,8 @@ b <- newName "b" let aVar = DVarT a bVar = DVarT b- aTvb = DPlainTV a- bTvb = DPlainTV b+ aTvb = DPlainTV a ()+ bTvb = DPlainTV b () fvsABExpected = [aTvb, bTvb] fvsABActual = toposortTyVarsOf [aVar, bVar]@@ -407,8 +429,8 @@ -- infixr 5 `m` -- m :: a --- -- We define this by hand to avoid GHC#17608 on pre-8.12 GHCs.- decs = sweeten [ DClassD [] c [DPlainTV a] []+ -- We define this by hand to avoid GHC#17608 on pre-9.0 GHCs.+ decs = sweeten [ DClassD [] c [DPlainTV a ()] [] [ DLetDec (DInfixD fixity m) , DLetDec (DSigD m (DVarT a)) ]@@ -442,16 +464,21 @@ -- (Nothing :: Maybe a) ty1 = DSigT (DConT 'Nothing) (DConT ''Maybe `DAppT` DVarT a) -- forall (c :: a). c- ty2 = DForallT ForallInvis [DKindedTV c (DVarT a)] (DVarT c)+ ty2 = DForallT (DForallInvis [DKindedTV c SpecifiedSpec (DVarT a)])+ (DVarT c) -- forall a (c :: a). c- ty3 = DForallT ForallInvis [DPlainTV a, DKindedTV c (DVarT a)] (DVarT c)+ ty3 = DForallT (DForallInvis [ DPlainTV a SpecifiedSpec+ , DKindedTV c SpecifiedSpec (DVarT a)+ ])+ (DVarT c) -- forall (a :: k) k (b :: k). Proxy b -> Proxy a- ty4 = DForallT ForallInvis- [ DKindedTV a (DVarT k)- , DPlainTV k- , DKindedTV b (DVarT k)- ] (DArrowT `DAppT` (DConT ''Proxy `DAppT` DVarT b)- `DAppT` (DConT ''Proxy `DAppT` DVarT a))+ ty4 = DForallT (DForallInvis+ [ DKindedTV a SpecifiedSpec (DVarT k)+ , DPlainTV k SpecifiedSpec+ , DKindedTV b SpecifiedSpec (DVarT k)+ ])+ (DArrowT `DAppT` (DConT ''Proxy `DAppT` DVarT b)+ `DAppT` (DConT ''Proxy `DAppT` DVarT a)) substTy1 <- substTy subst ty1 substTy2 <- substTy subst ty2@@ -511,7 +538,7 @@ normal_reifications :: [String] normal_reifications = $(do infos <- mapM reify reifyDecsNames ListE <$> mapM (Syn.lift . show . Just)- (dropTrailing0s $ unqualify infos))+ (dropTrailing0s $ delinearize $ unqualify infos)) zipWith3M :: Monad m => (a -> b -> c -> m d) -> [a] -> [b] -> [c] -> m [d] zipWith3M f (a:as) (b:bs) (c:cs) = liftM2 (:) (f a b c) (zipWith3M f as bs cs)@@ -604,7 +631,8 @@ it "reifies GADT record selectors correctly" $ test_t100 - it "collects GADT record selectors correctly" $ test_t102+ zipWithM (\b n -> it ("collects GADT record selectors correctly" ++ show n) b)+ test_t102 [1..] it "quantifies kind variables in desugared ADT constructors" $ test_t103
Test/Splices.hs view
@@ -40,6 +40,10 @@ {-# LANGUAGE StandaloneKindSignatures #-} #endif +#if __GLASGOW_HASKELL__ >= 900+{-# LANGUAGE QualifiedDo #-}+#endif+ {-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-type-defaults -fno-warn-name-shadowing #-} @@ -51,6 +55,7 @@ import GHC.TypeLits import Language.Haskell.TH+import Language.Haskell.TH.Datatype.TyVarBndr import Language.Haskell.TH.Desugar import Language.Haskell.TH.Syntax (Quasi) import Data.Generics@@ -59,6 +64,8 @@ import GHC.OverloadedLabels ( IsLabel(..) ) #endif +import Prelude as P+ dsSplice :: Q Exp -> Q Exp dsSplice expq = expq >>= dsExp >>= (return . expToTH) @@ -88,13 +95,21 @@ #if __GLASGOW_HASKELL__ < 709 assumeStarT = id #else-assumeStarT = everywhere (mkT go)+assumeStarT = everywhere (mkT assume_spec . mkT assume_unit) where- go :: TyVarBndr -> TyVarBndr- go (PlainTV n) = KindedTV n StarT- go (KindedTV n k) = KindedTV n (assumeStarT k)+ assume_spec :: TyVarBndrSpec -> TyVarBndrSpec+#if __GLASGOW_HASKELL__ >= 900+ assume_spec (PlainTV n spec) = KindedTV n spec StarT+ assume_spec (KindedTV n spec k) = KindedTV n spec (assumeStarT k)+#else+ assume_spec = assume_unit #endif + assume_unit :: TyVarBndrUnit -> TyVarBndrUnit+ assume_unit = elimTV (\n -> kindedTV n StarT)+ (\n k -> kindedTV n (assumeStarT k))+#endif+ dropTrailing0s :: Data a => a -> a dropTrailing0s = everywhere (mkT (mkName . frob . nameBase)) where@@ -103,6 +118,18 @@ | head str == 'R' = str | otherwise = dropWhileEnd isDigit str +-- Because th-desugar does not support linear types, we must pretend like+-- MulArrowT does not exist for testing purposes.+-- See Note [Gracefully handling linear types] in L.H.TH.Desugar.Core.+delinearize :: Data a => a -> a+delinearize = everywhere (mkT no_mul)+ where+ no_mul :: Type -> Type+#if __GLASGOW_HASKELL__ >= 900+ no_mul (MulArrowT `AppT` _) = ArrowT+#endif+ no_mul t = t+ eqTH :: (Data a, Show a) => a -> a -> Bool eqTH a b = show (unqualify a) == show (unqualify b) @@ -290,6 +317,14 @@ (#,#) ((,,) _ a _) ((#,,#) _ b _) -> a + b |] #endif +#if __GLASGOW_HASKELL__ >= 900+test52_qual_do =+ [| P.do x <- [1, 2]+ y@1 <- [x]+ [1, 2]+ P.return y |]+#endif+ type family TFExpand x type instance TFExpand Int = Bool type instance TFExpand (Maybe a) = [a]@@ -410,7 +445,7 @@ data ExData1 a data ExData2 a -ds_dectest16 = DInstanceD Nothing (Just [DPlainTV (mkName "a")]) []+ds_dectest16 = DInstanceD Nothing (Just [DPlainTV (mkName "a") ()]) [] (DConT ''ExCls `DAppT` (DConT ''ExData1 `DAppT` DVarT (mkName "a"))) [] dectest16 :: Q [Dec]@@ -418,10 +453,10 @@ #if __GLASGOW_HASKELL__ >= 800 Nothing #endif- [] (ForallT [PlainTV (mkName "a")] []+ [] (ForallT [plainTVSpecified (mkName "a")] [] (ConT ''ExCls `AppT` (ConT ''ExData1 `AppT` VarT (mkName "a")))) [] ]-ds_dectest17 = DStandaloneDerivD Nothing (Just [DPlainTV (mkName "a")]) []+ds_dectest17 = DStandaloneDerivD Nothing (Just [DPlainTV (mkName "a") ()]) [] (DConT ''ExCls `DAppT` (DConT ''ExData2 `DAppT` DVarT (mkName "a"))) #if __GLASGOW_HASKELL__ >= 710@@ -430,7 +465,7 @@ #if __GLASGOW_HASKELL__ >= 802 Nothing #endif- [] (ForallT [PlainTV (mkName "a")] []+ [] (ForallT [plainTVSpecified (mkName "a")] [] (ConT ''ExCls `AppT` (ConT ''ExData2 `AppT` VarT (mkName "a")))) ] #endif@@ -474,13 +509,13 @@ flatten_dvald_test = [| let (a,b,c) = ("foo", 4, False) in show a ++ show b ++ show c |] -rec_sel_test = [d| data RecordSel a = forall b. (Show a, Eq b) =>+rec_sel_test = [d| data RecordSel a = Show a => MkRecord { recsel1 :: (Int, a)- , recsel_naughty :: (a, b)- , recsel2 :: (forall b. b -> a)- , recsel3 :: Bool }- | MkRecord2 { recsel4 :: (a, a) } |]-rec_sel_test_num_sels = 4 :: Int -- exclude naughty one+ , recsel2 :: (forall b. b -> a)+ , recsel3 :: Bool }+ | MkRecord2 { recsel3 :: Bool+ , recsel4 :: (a, a) } |]+rec_sel_test_num_sels = 4 :: Int testRecSelTypes :: Int -> Q Exp testRecSelTypes n = do@@ -494,11 +529,11 @@ let ty1' = return $ unqualify ty1 ty2' = return $ unqualify ty2 [| let x :: $ty1'- x = undefined+ x _ = undefined y :: $ty2'- y = undefined+ y _ = undefined in- $(return $ VarE $ mkName "hasSameType") x y |]+ $(return $ VarE $ mkName "hasSameType") (\d -> x d) (\d -> y d) |] -- used for expand@@ -725,5 +760,8 @@ #endif #if __GLASGOW_HASKELL__ >= 809 , test51_tuple_sections+#endif+#if __GLASGOW_HASKELL__ >= 900+ , test52_qual_do #endif ]
th-desugar.cabal view
@@ -1,5 +1,5 @@ name: th-desugar-version: 1.11+version: 1.12 cabal-version: >= 1.10 synopsis: Functions to desugar Template Haskell homepage: https://github.com/goldfirere/th-desugar@@ -18,8 +18,9 @@ , GHC == 8.2.2 , GHC == 8.4.4 , GHC == 8.6.5- , GHC == 8.8.3- , GHC == 8.10.1+ , GHC == 8.8.4+ , GHC == 8.10.4+ , GHC == 9.0.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.@@ -45,17 +46,18 @@ build-depends: base >= 4.7 && < 5, ghc-prim,- template-haskell >= 2.9 && < 2.17,+ template-haskell >= 2.9 && < 2.18, 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-abstraction >= 0.4 && < 0.5, th-lift >= 0.6.1, th-orphans >= 0.13.7, transformers-compat >= 0.6.3+ if !impl(ghc >= 8.0)+ build-depends: fail == 4.9.*,+ semigroups >= 0.16 default-extensions: TemplateHaskell exposed-modules: Language.Haskell.TH.Desugar Language.Haskell.TH.Desugar.Expand@@ -78,6 +80,8 @@ test-suite spec type: exitcode-stdio-1.0 ghc-options: -Wall+ if impl(ghc >= 8.6)+ ghc-options: -Wno-star-is-type default-language: Haskell2010 default-extensions: TemplateHaskell hs-source-dirs: Test@@ -96,6 +100,7 @@ syb >= 0.4, HUnit >= 1.2, hspec >= 1.3,+ th-abstraction >= 0.4 && < 0.5, th-desugar, th-lift >= 0.6.1, th-orphans >= 0.13.9