diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -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, diff --git a/Language/Haskell/TH/Desugar.hs b/Language/Haskell/TH/Desugar.hs --- a/Language/Haskell/TH/Desugar.hs +++ b/Language/Haskell/TH/Desugar.hs @@ -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 diff --git a/Language/Haskell/TH/Desugar/AST.hs b/Language/Haskell/TH/Desugar/AST.hs --- a/Language/Haskell/TH/Desugar/AST.hs +++ b/Language/Haskell/TH/Desugar/AST.hs @@ -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. diff --git a/Language/Haskell/TH/Desugar/Core.hs b/Language/Haskell/TH/Desugar/Core.hs --- a/Language/Haskell/TH/Desugar/Core.hs +++ b/Language/Haskell/TH/Desugar/Core.hs @@ -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 diff --git a/Language/Haskell/TH/Desugar/Expand.hs b/Language/Haskell/TH/Desugar/Expand.hs --- a/Language/Haskell/TH/Desugar/Expand.hs +++ b/Language/Haskell/TH/Desugar/Expand.hs @@ -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" diff --git a/Language/Haskell/TH/Desugar/FV.hs b/Language/Haskell/TH/Desugar/FV.hs --- a/Language/Haskell/TH/Desugar/FV.hs +++ b/Language/Haskell/TH/Desugar/FV.hs @@ -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 diff --git a/Language/Haskell/TH/Desugar/Lift.hs b/Language/Haskell/TH/Desugar/Lift.hs --- a/Language/Haskell/TH/Desugar/Lift.hs +++ b/Language/Haskell/TH/Desugar/Lift.hs @@ -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 ]) diff --git a/Language/Haskell/TH/Desugar/Reify.hs b/Language/Haskell/TH/Desugar/Reify.hs --- a/Language/Haskell/TH/Desugar/Reify.hs +++ b/Language/Haskell/TH/Desugar/Reify.hs @@ -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 diff --git a/Language/Haskell/TH/Desugar/Subst.hs b/Language/Haskell/TH/Desugar/Subst.hs --- a/Language/Haskell/TH/Desugar/Subst.hs +++ b/Language/Haskell/TH/Desugar/Subst.hs @@ -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. diff --git a/Language/Haskell/TH/Desugar/Sweeten.hs b/Language/Haskell/TH/Desugar/Sweeten.hs --- a/Language/Haskell/TH/Desugar/Sweeten.hs +++ b/Language/Haskell/TH/Desugar/Sweeten.hs @@ -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+" diff --git a/Language/Haskell/TH/Desugar/Util.hs b/Language/Haskell/TH/Desugar/Util.hs --- a/Language/Haskell/TH/Desugar/Util.hs +++ b/Language/Haskell/TH/Desugar/Util.hs @@ -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) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,7 +2,7 @@ ==================== [![Hackage](https://img.shields.io/hackage/v/th-desugar.svg)](http://hackage.haskell.org/package/th-desugar) -[![Build Status](https://travis-ci.org/goldfirere/th-desugar.svg?branch=master)](https://travis-ci.org/goldfirere/th-desugar) +[![Build Status](https://github.com/goldfirere/th-desugar/workflows/Haskell-CI/badge.svg)](https://github.com/goldfirere/th-desugar/actions?query=workflow%3AHaskell-CI) This package provides the `Language.Haskell.TH.Desugar` module, which desugars Template Haskell's rich encoding of Haskell syntax into a simpler encoding. @@ -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). diff --git a/Test/DsDec.hs b/Test/DsDec.hs --- a/Test/DsDec.hs +++ b/Test/DsDec.hs @@ -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)) diff --git a/Test/ReifyTypeCUSKs.hs b/Test/ReifyTypeCUSKs.hs --- a/Test/ReifyTypeCUSKs.hs +++ b/Test/ReifyTypeCUSKs.hs @@ -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 diff --git a/Test/ReifyTypeSigs.hs b/Test/ReifyTypeSigs.hs --- a/Test/ReifyTypeSigs.hs +++ b/Test/ReifyTypeSigs.hs @@ -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` diff --git a/Test/Run.hs b/Test/Run.hs --- a/Test/Run.hs +++ b/Test/Run.hs @@ -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 diff --git a/Test/Splices.hs b/Test/Splices.hs --- a/Test/Splices.hs +++ b/Test/Splices.hs @@ -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 ] diff --git a/th-desugar.cabal b/th-desugar.cabal --- a/th-desugar.cabal +++ b/th-desugar.cabal @@ -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