diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,6 +1,238 @@ `th-desugar` release notes ========================== +Version 1.19 [2026.01.10] +------------------------- +* Support GHC 9.14. +* Support specialising expressions in `SPECIALISE` pragmas. As part of these + changes, a `DSpecialiseEP` data constructor has been added to `DPragma`, and + the existing `DSpecialiseP` data constructor has been converted to a pattern + synonym defined in terms of `DSpecialiseEP`. +* Add `mkTupleDType :: [DType] -> DType`, which offers functionality similar to + the existing `mkTupleD{Exp,Pat}` functions, but for types instead of + expressions or patterns. + +Version 1.18 [2024.12.11] +------------------------- +* Support GHC 9.12. +* Add further support for embedded types in terms. The `DExp` type now has a + `DForallE` data constructor (mirroring `ForallE` and `ForallVisE` in + `template-haskell`) and a `DConstrainedE` data constructor (mirroring + `ConstrainedE` in `template-haskell`). +* The `DLamE` and `DCaseE` data constructors (as well as the related + `mkDLamEFromDPats` function) are now deprecated in favor of the new + `DLamCasesE` data constructor. `DLamE`, `DCaseE`, and `mkDLamEFromDPats` will + be removed in a future release of `th-desugar`, so users are encouraged to + migrate. For more details on how to migrate your code, see [this + document](https://github.com/goldfirere/th-desugar/blob/master/docs/LambdaCaseMigration.md). +* The type of the `dsMatches` function has changed: + + ```diff + -dsMatches :: DsMonad q => Name -> [Match] -> q [DMatch] + +dsMatches :: DsMonad q => MatchContext -> [Match] -> q [DMatch] + ``` + + In particular: + + * `dsMatches` function no longer includes a `Name` argument for the + variable being scrutinized, as the new approach that `th-desugar` uses to + desugar `Match`es no longer requires this. + * `dsMatches` now requires a `MatchContext` argument, which + determines what kind of "`Non-exhaustive patterns in ...`" error it raises + when reaching a fallthrough case for non-exhaustive matches. +* Add a `maybeDCasesE :: MatchContext -> [DExp] -> [DClause] -> DExp` function. + `maybeDCasesE` is similar to `maybeDCaseE` except that it matches on multiple + expressions (using `\\cases`) instead of matching on a single expression. +* Add support for desugaring higher-order uses of embedded type patterns (e.g., + `\(type a) (x :: a) -> x :: a`) and invisible type patterns (e.g., + `\ @a (x :: a) -> x :: a`). +* Add a `Quote` instance for `DsM`. +* Add `mapDTVName` and `mapDTVKind` functions, which allow mapping over the + `Name` and `DKind` of a `DTyVarBndr`, respectively. +* Export `substTyVarBndr` from `Language.Haskell.TH.Desugar.Subst`. +* Add a `Language.Haskell.TH.Desugar.Subst.Capturing` module. This exposes + mostly the same API as `Language.Haskell.TH.Desugar.Subst`, except that the + substitution functions in `Language.Haskell.TH.Desugar.Subst.Capturing` do + not avoid capture when subtituting into a @forall@ type. As a result, these + substitution functions are pure rather than monadic. +* Add `dMatchUpSAKWithDecl`, a function that matches up type variable binders + from a standalone kind signature to the corresponding type variable binders + in the type-level declaration's header: + + * The type signature for `dMatchUpSAKWithDecl` returns + `[DTyVarBndr ForAllTyFlag]`, where `ForAllTyFlag` is a new data type that + generalizes both `Specificity` and `BndrVis`. + * Add `dtvbForAllTyFlagsToSpecs` and `dtvbForAllTyFlagsToBndrVis` functions, + which allow converting the results of calling `dMatchUpSAKWithDecl` to + `[DTyVarBndrSpec]` or `[DTyVarBndrVis]`, respectively. + * Also add `matchUpSAKWithDecl`, `tvbForAllTyFlagsToSpecs`, and + `tvbForAllTyFlagsToBndrVis` functions, which work over `TyVarBndr` instead + of `DTyVarBndr`. +* Locally reifying the type of a data constructor or class method now yields + type signatures with more precise type variable information, as `th-desugar` + now incorporates information from the standalone kind signature (if any) for + the parent data type or class, respectively. For instance, consider the + following data type declaration: + + ```hs + type P :: forall {k}. k -> Type + data P (a :: k) = MkP + ``` + + In previous versions of `th-desugar`, locally reifying `MkP` would yield the + following type: + + ```hs + MkP :: forall k (a :: k). P a + ``` + + This was subtly wrong, as `k` is marked as specified (i.e., eligible for + visible type application), not inferred. In `th-desugar-1.18`, however, the + locally reified type will mark `k` as inferred, as expected: + + ```hs + MkP :: forall {k} (a :: k). P a + ``` + + Similarly, desugaring `MkP` from Template Haskell to `th-desugar` results + in a data constructor with the expected type above. + * As a result of these changes, the type of `dsCon` has changed slightly: + + ```diff + -dsCon :: DsMonad q => [DTyVarBndrUnit] -> DType -> Con -> q [DCon] + +dsCon :: DsMonad q => [DTyVarBndrSpec] -> DType -> Con -> q [DCon] + ``` + +Version 1.17 [2024.05.12] +------------------------- +* Support GHC 9.10. +* Add support namespace identifiers in fixity declarations. As part of these + changes, the `DInfixD` data constructor now has a `NamespaceSpecifier` field. +* Add support for `SCC` declarations via the new `DSCCP` data constructor for + the `DPragma` data type. +* Add partial support for embedded types in expressions (via the new `DTypeE` + data constructor) and in patterns (via the new `DTypeP` data constructor). + This is only partial support because the use of `DTypeP` is supported in the + clauses of function declarations, but not in lambda expressions, `\case` + expressions, or `\cases` expressions. See the "Known limitations" section of + the `th-desugar` `README` for full details. +* Add partial support for invisible type patterns via the new `DInvisP` data + constructor. Just like with `DTypeP`, `th-desugar` only supports the use of + `DInvisP` in the clauses of function declarations. See the "Known limitations" + section of the `th-desugar` `README` for full details. +* `extractBoundNamesDPat` no longer extracts type variables from constructor + patterns. That this function ever did extract type variables was a mistake, + and the new behavior of `extractBoundNamesDPat` brings it in line with the + behavior `extractBoundNamesPat`. +* The `unboxedTupleNameDegree_maybe` function now returns: + * `Just 0` when the argument is `''Unit#` + * `Just 1` when the argument is `''Solo#` + * `Just ` when the argument is `''Tuple#` + This is primarily motivated by the fact that with GHC 9.10 or later, `''(##)` + is syntactic sugar for `''Unit#`, `''(#,#)` is syntactic sugar for `Tuple2#`, + and so on. +* The `unboxedSumNameDegree_maybe` function now returns `Just n` when the + argument is `Sum#`. This is primarily motivated by the fact that with GHC + 9.10 or later, `''(#|#)` is syntactic sugar for `Sum2#`, `''(#||#)` is + syntactic sugar for `Sum3#`, and so on. +* Add `Foldable` and `Traversable` instances for `DTyVarBndrSpec`. + +Version 1.16 [2023.10.13] +------------------------- +* Support GHC 9.8. +* Require `th-abstraction-0.6` or later. +* Add support for invisible binders in type-level declarations. As part of this + change: + + * `Language.Haskell.TH.Desugar` now exports a `DTyVarBndrVis` type synonym, + which is the `th-desugar` counterpart to `TyVarBndrVis`. It also exports a + `dsTvbVis` function, which is the `DTyVarBndrVis` counterpart to `dsTvbSpec` + and `dsTvbUnit`. + * `Language.Haskell.TH.Desugar` now re-exports `BndrVis` from + `template-haskell`. + * The `DDataD`, `DTySynD`, `DClassD`, `DDataFamilyD`, and `DTypeFamilyHead` + parts of the `th-desugar` AST now use `DTyVarBndrVis` instead of + `DTyVarBndrUnit`. + * The `mkExtraDKindBinders`, `dsCon`, and `dsDataDec` functions now use + `DTyVarBndrVis` instead of `DTyVarBndrUnit`. + * The `getDataD` function now uses `TyVarBndrVis` instead of `TyVarBndrUnit`. + + It is possible that you will need to convert between `TyVarBndrUnit` and + `TyVarBndrVis` to adapt your existing `th-desugar` code. (Note that `TyVarBndr + flag` is an instance of `Functor`, so this can be accomplished with `fmap`.) +* `Language.Haskell.TH.Desugar` now exports a family of functions for converting + type variable binders into type arguments while preserving their visibility: + + * The `tyVarBndrVisToTypeArg` and `tyVarBndrVisToTypeArgWithSig` functions + convert a `TyVarBndrVis` to a `TypeArg`. `tyVarBndrVisToTypeArg` omits kind + signatures when converting `KindedTV`s, while `tyVarBndrVisToTypeArgWithSig` + preserves kind signatures. + * The `dTyVarBndrVisToDTypeArg` and `dTyVarBndrVisToDTypeArgWithSig` functions + convert a `DTyVarBndrVis` to a `DTypeArg`. `dTyVarBndrVisToDTypeArg` omits + kind signatures when converting `DKindedTV`s, while + `dTyVarBndrVisToDTypeArgWithSig` preserves kind signatures. +* `th-desugar` now supports generating typed Template Haskell quotes and splices + via the new `DTypedBracketE` and `DTypedSpliceE` constructors of `DExp`, + respectively. +* The `lookupValueNameWithLocals` function will no longer reify field selectors + when the `NoFieldSelectors` language extension is set, mirroring the behavior + of the `lookupValueName` function in `template-haskell`. Note that this will + only happen when using GHC 9.8 or later, as previous versions of GHC do not + equip Template Haskell with enough information to conclude whether a value is + a record field or not. +* The `tupleNameDegree_maybe` function now returns: + * `Just 0` when the argument is `''Unit` + * `Just 1` when the argument is `''Solo` or `'MkSolo` + * `Just ` when the argument is `''Tuple` + This is primarily motivated by the fact that with GHC 9.8 or later, `''()` is + syntactic sugar for `''Unit`, `''(,)` is syntactic sugar for `Tuple2`, and so + on. We also include cases for `''Solo` and `'MkSolo` for the sake of + completeness, even though they do not have any special syntactic sugar. +* The `tupleDegree_maybe`, `unboxedSumDegree_maybe`, and + `unboxedTupleDegree_maybe` functions have been removed. Their only use sites + were in the `tupleNameDegree_maybe`, `unboxedSumNameDegree_maybe`, and + `unboxedTupleNameDegree_maybe` functions, respectively. Moreover, + `tupleDegree_maybe`'s semantics were questionable, considering that it could + potentially return `Just ` for a custom data type named `Tuple`, even + if the custom data type has no relation to the `Tuple` types defined in + `GHC.Tuple`. +* The `matchTy` function now looks through visible kind applications (i.e., + `DAppKindT`s) whenever `YesIgnoreKinds` is given. +* Fix a bug in which infix data family declaration would mistakenly be rejected + when reified locally. +* Fix a bug in which data types that use visible dependent quantification would + produce ill-scoped code when desugared. + +Version 1.15 [2023.03.12] +------------------------- +* Support GHC 9.6. +* The `NewOrData` data type has been renamed to `DataFlavor` and extended to + support `type data` declarations: + + ```diff + -data NewOrData = NewType | Data + +data DataFlavor = NewType | Data | TypeData + ``` + + Desugaring upholds the following properties regarding `TypeData`: + + * A `DDataD` with a `DataFlavor` of `TypeData` cannot have any deriving + clauses or datatype contexts, and the `DConFields` in each `DCon` will be a + `NormalC` where each `Bang` is equal to + `Bang NoSourceUnpackedness NoSourceStrictness`. + * A `DDataInstD` can have a `DataFlavor` of `NewType` or `Data`, but not + `TypeData`. +* The type of `getDataD` has been changed to also include a `DataFlavor`: + + ```diff + -getDataD :: DsMonad q => String -> Name -> q ([TyVarBndrUnit], [Con]) + +getDataD :: DsMonad q => String -> Name -> q (DataFlavor, [TyVarBndrUnit], [Con]) + ``` +* Local reification can now reify the types of pattern synonym record + selectors. +* Fix a bug in which the types of locally reified GADT record selectors would + sometimes have type variables quantified in the wrong order. + Version 1.14 [2022.08.23] ------------------------- * Support GHC 9.4. 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 @@ -6,7 +6,7 @@ {-# LANGUAGE CPP, MultiParamTypeClasses, FunctionalDependencies, TypeSynonymInstances, FlexibleInstances, LambdaCase, - ScopedTypeVariables #-} + ScopedTypeVariables, PatternSynonyms #-} ----------------------------------------------------------------------------- -- | @@ -24,17 +24,26 @@ module Language.Haskell.TH.Desugar ( -- * Desugared data types - DExp(..), DLetDec(..), DPat(..), + DExp(..), pattern DLamE, pattern DCaseE, + DLetDec(..), NamespaceSpecifier(..), DPat(..), DType(..), DForallTelescope(..), DKind, DCxt, DPred, DTyVarBndr(..), DTyVarBndrSpec, DTyVarBndrUnit, Specificity(..), + DTyVarBndrVis, +#if __GLASGOW_HASKELL__ >= 907 + BndrVis(..), +#else + BndrVis, + pattern BndrReq, + pattern BndrInvis, +#endif DMatch(..), DClause(..), DDec(..), DDerivClause(..), DDerivStrategy(..), DPatSynDir(..), DPatSynType, - Overlap(..), PatSynArgs(..), NewOrData(..), + Overlap(..), PatSynArgs(..), DataFlavor(..), DTypeFamilyHead(..), DFamilyResultSig(..), InjectivityAnn(..), DCon(..), DConFields(..), DDeclaredInfix, DBangType, DVarBangType, Bang(..), SourceUnpackedness(..), SourceStrictness(..), DForeign(..), - DPragma(..), DRuleBndr(..), DTySynEqn(..), DInfo(..), DInstanceDec, + DPragma(DSpecialiseP, ..), DRuleBndr(..), DTySynEqn(..), DInfo(..), DInstanceDec, Role(..), AnnTarget(..), -- * The 'Desugar' class @@ -43,12 +52,13 @@ -- * Main desugaring functions dsExp, dsDecs, dsType, dsInfo, dsPatOverExp, dsPatsOverExp, dsPatX, - dsLetDecs, dsTvb, dsTvbSpec, dsTvbUnit, dsCxt, + dsLetDecs, dsTvb, dsTvbSpec, dsTvbUnit, dsTvbVis, dsCxt, dsCon, dsForeign, dsPragma, dsRuleBndr, -- ** Secondary desugaring functions PatM, dsPred, dsPat, dsDec, dsDataDec, dsDataInstDec, DerivingClause, dsDerivClause, dsLetDec, + MatchContext(..), LamCaseVariant(..), dsMatches, dsBody, dsGuards, dsDoStmts, dsComp, dsClauses, dsBangType, dsVarBangType, dsTypeFamilyHead, dsFamilyResultSig, @@ -91,12 +101,18 @@ getDataD, dataConNameToDataName, dataConNameToCon, nameOccursIn, allNamesIn, flattenDValD, getRecordSelectors, mkTypeName, mkDataName, newUniqueName, - mkTupleDExp, mkTupleDPat, maybeDLetE, maybeDCaseE, mkDLamEFromDPats, - tupleDegree_maybe, tupleNameDegree_maybe, - unboxedSumDegree_maybe, unboxedSumNameDegree_maybe, - unboxedTupleDegree_maybe, unboxedTupleNameDegree_maybe, + mkTupleDExp, mkTupleDPat, mkTupleDType, + maybeDLetE, maybeDCaseE, maybeDCasesE, + dCaseE, dCasesE, dLamE, dLamCaseE, mkDLamEFromDPats, + tupleNameDegree_maybe, + unboxedSumNameDegree_maybe, unboxedTupleNameDegree_maybe, isTypeKindName, typeKindName, bindIP, - mkExtraDKindBinders, dTyVarBndrToDType, changeDTVFlags, toposortTyVarsOf, + mkExtraDKindBinders, dTyVarBndrToDType, changeDTVFlags, + mapDTVName, mapDTVKind, + toposortTyVarsOf, toposortKindVarsOfTvbs, + ForAllTyFlag(..), + tvbForAllTyFlagsToSpecs, tvbForAllTyFlagsToBndrVis, matchUpSAKWithDecl, + dtvbForAllTyFlagsToSpecs, dtvbForAllTyFlagsToBndrVis, dMatchUpSAKWithDecl, -- ** 'FunArgs' and 'VisFunArg' FunArgs(..), ForallTelescope(..), VisFunArg(..), @@ -107,10 +123,14 @@ filterDVisFunArgs, ravelDType, unravelDType, -- ** 'TypeArg' - TypeArg(..), applyType, filterTANormals, unfoldType, + TypeArg(..), applyType, filterTANormals, + tyVarBndrVisToTypeArg, tyVarBndrVisToTypeArgWithSig, + unfoldType, -- ** 'DTypeArg' - DTypeArg(..), applyDType, filterDTANormals, unfoldDType, + DTypeArg(..), applyDType, filterDTANormals, + dTyVarBndrVisToDTypeArg, dTyVarBndrVisToDTypeArgWithSig, + unfoldDType, -- ** Extracting bound names extractBoundNamesStmt, extractBoundNamesDec, extractBoundNamesPat @@ -221,7 +241,7 @@ y <- newUniqueName "y" let pat' = wildify name y pat match = DMatch pat' (DVarE y) - cas = DCaseE (DVarE x) [match] + cas = dCaseE (DVarE x) [match] return $ DValD (DVarP name) cas wildify name y p = @@ -235,6 +255,8 @@ DBangP pa -> DBangP (wildify name y pa) DSigP pa ty -> DSigP (wildify name y pa) ty DWildP -> DWildP + DTypeP ty -> DTypeP ty + DInvisP ty -> DInvisP ty flattenDValD other_dec = return [other_dec] @@ -372,16 +394,18 @@ -- are fresh type variable names. -- -- This expands kind synonyms if necessary. -mkExtraDKindBinders :: forall q. DsMonad q => DKind -> q [DTyVarBndrUnit] +mkExtraDKindBinders :: forall q. DsMonad q => DKind -> q [DTyVarBndrVis] mkExtraDKindBinders k = do k' <- expandType k let (fun_args, _) = unravelDType k' vis_fun_args = filterDVisFunArgs fun_args mapM mk_tvb vis_fun_args where - mk_tvb :: DVisFunArg -> q DTyVarBndrUnit - mk_tvb (DVisFADep tvb) = return tvb - mk_tvb (DVisFAAnon ki) = DKindedTV <$> qNewName "a" <*> return () <*> return ki + mk_tvb :: DVisFunArg -> q (DTyVarBndrVis) + mk_tvb (DVisFADep tvb) = return (BndrReq <$ tvb) + mk_tvb (DVisFAAnon ki) = do + name <- qNewName "a" + pure $ DKindedTV name BndrReq ki {- $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,31 +6,165 @@ constructors are prefixed with a D. -} -{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveGeneric #-} +{-# LANGUAGE CPP, DeriveDataTypeable, DeriveTraversable, DeriveGeneric, DeriveLift, PatternSynonyms, ViewPatterns #-} module Language.Haskell.TH.Desugar.AST where import Data.Data hiding (Fixity) import GHC.Generics hiding (Fixity) import Language.Haskell.TH +import Language.Haskell.TH.Instances () +import Language.Haskell.TH.Syntax (Lift) #if __GLASGOW_HASKELL__ < 900 -import Language.Haskell.TH.Datatype.TyVarBndr (Specificity) +import Language.Haskell.TH.Datatype.TyVarBndr (Specificity(..)) #endif +#if __GLASGOW_HASKELL__ < 907 +import Language.Haskell.TH.Datatype.TyVarBndr (BndrVis) +#endif +import Language.Haskell.TH.Desugar.Util (DataFlavor) + -- | Corresponds to TH's @Exp@ type. Note that @DLamE@ takes names, not patterns. data DExp = DVarE Name | DConE Name | DLitE Lit | DAppE DExp DExp | DAppTypeE DExp DType - | DLamE [Name] DExp - | DCaseE DExp [DMatch] + -- | A @\\cases@ expression. In the spirit of making 'DExp' minimal, + -- @th-desugar@ will desugar lambda expressions, @case@ expressions, + -- @\\case@ expressions, and @\\cases@ expressions to 'DLamCasesE'. + -- (See also the 'dLamE', 'dCaseE', and 'dLamCaseE' functions for + -- constructing these expressions in terms of 'DLamCasesE'.) + -- + -- A 'DLamCasesE' value should obey the following invariants: + -- + -- * Each 'DClause' should have exactly the same number of visible + -- arguments in its list of 'DPat's. + -- + -- * If the list of 'DClause's is empty, then the overall expression + -- should have exactly one argument. Note that this is a + -- difference in behavior from how @\\cases@ expressions work, as + -- @\\cases@ is required to have at least one clause. For this + -- reason, @th-desugar@ will sweeten @DLamCasesE []@ to + -- @\\case{}@. + | DLamCasesE [DClause] | DLetE [DLetDec] DExp | DSigE DExp DType | DStaticE DExp - deriving (Eq, Show, Data, Generic) + | DTypedBracketE DExp + | DTypedSpliceE DExp + | DTypeE DType + | DForallE DForallTelescope DExp + | DConstrainedE [DExp] DExp + deriving (Eq, Show, Data, Generic, Lift) +-- | A 'DLamCasesE' value with exactly one 'DClause' where all 'DPat's are +-- 'DVarP's. This pattern synonym is provided for backwards compatibility with +-- older versions of @th-desugar@ in which 'DLamE' was a data constructor of +-- 'DExp'. This pattern synonym is deprecated and will be removed in a future +-- release of @th-desugar@. +pattern DLamE :: [Name] -> DExp -> DExp +pattern DLamE vars rhs <- (dLamE_maybe -> Just (vars, rhs)) + where + DLamE vars rhs = DLamCasesE [DClause (map DVarP vars) rhs] +{-# DEPRECATED DLamE "Use `dLamE` or `DLamCasesE` instead." #-} +-- | Return @'Just' (pats, rhs)@ if the supplied 'DExp' is a 'DLamCasesE' value +-- with exactly one 'DClause' where all 'DPat's are 'DVarP's, where @pats@ is +-- the list of 'DVarP' 'Name's and @rhs@ is the expression on the right-hand +-- side of the 'DClause'. Otherwise, return 'Nothing'. +dLamE_maybe :: DExp -> Maybe ([Name], DExp) +dLamE_maybe (DLamCasesE [DClause pats rhs]) = do + vars <- traverse dVarP_maybe pats + Just (vars, rhs) +dLamE_maybe _ = Nothing + +-- | Return @'Just' var@ if the supplied 'DPat' is a 'DVarP' value, where @var@ +-- is the 'DVarP' 'Name'. Otherwise, return 'Nothing'. +dVarP_maybe :: DPat -> Maybe Name +dVarP_maybe (DVarP n) = Just n +dVarP_maybe _ = Nothing + +-- | An application of a 'DLamCasesE' to some argument, where each 'DClause' in +-- the 'DLamCasesE' value has exactly one 'DPat'. This pattern synonym is +-- provided for backwards compatibility with older versions of @th-desugar@ in +-- which 'DCaseE' was a data constructor of 'DExp'. This pattern synonym is +-- deprecated and will be removed in a future release of @th-desugar@. +pattern DCaseE :: DExp -> [DMatch] -> DExp +pattern DCaseE scrut matches <- (dCaseE_maybe -> Just (scrut, matches)) + where + DCaseE scrut matches = DAppE (dLamCaseE matches) scrut +{-# DEPRECATED DCaseE "Use `dCaseE` or `DLamCasesE` instead." #-} + +-- | Return @'Just' (scrut, matches)@ if the supplied 'DExp' is a 'DLamCasesE' +-- value applied to some argument, where each 'DClause' in the 'DLamCasesE' +-- value has exactly one 'DPat'. Otherwise, return 'Nothing'. +dCaseE_maybe :: DExp -> Maybe (DExp, [DMatch]) +dCaseE_maybe (DAppE (DLamCasesE clauses) scrut) = do + matches <- traverse dMatch_maybe clauses + Just (scrut, matches) +dCaseE_maybe _ = Nothing + +-- | Construct a 'DExp' value that is equivalent to writing a @case@ expression. +-- Under the hood, this uses @\\cases@ ('DLamCasesE'). For instance, given this +-- code: +-- +-- @ +-- case scrut of +-- pat_1 -> rhs_1 +-- ... +-- pat_n -> rhs_n +-- @ +-- +-- The following @\\cases@ expression will be created under the hood: +-- +-- @ +-- (\\cases +-- pat_1 -> rhs_1 +-- ... +-- pat_n -> rhs_n) scrut +-- @ +dCaseE :: DExp -> [DMatch] -> DExp +dCaseE scrut matches = DAppE (dLamCaseE matches) scrut + +-- | Construct a 'DExp' value that is equivalent to writing a lambda expression. +-- Under the hood, this uses @\\cases@ ('DLamCasesE'). For instance, given this +-- code: +-- +-- @ +-- \\var_1 ... var_n -> rhs +-- @ +-- +-- The following @\\cases@ expression will be created under the hood: +-- +-- @ +-- \\cases var_1 ... var_n -> rhs +-- @ +dLamE :: [DPat] -> DExp -> DExp +dLamE pats rhs = DLamCasesE [DClause pats rhs] + +-- | Construct a 'DExp' value that is equivalent to writing a @\\case@ +-- expression. Under the hood, this uses @\\cases@ ('DLamCasesE'). For instance, +-- given this code: +-- +-- @ +-- \\case +-- pat_1 -> rhs_1 +-- ... +-- pat_n -> rhs_n +-- @ +-- +-- The following @\\cases@ expression will be created under the hood: +-- +-- @ +-- \\cases +-- pat_1 -> rhs_1 +-- ... +-- pat_n -> rhs_n +-- @ +dLamCaseE :: [DMatch] -> DExp +dLamCaseE = DLamCasesE . map dMatchToDClause + -- | Corresponds to TH's @Pat@ type. data DPat = DLitP Lit | DVarP Name @@ -39,7 +173,9 @@ | DBangP DPat | DSigP DPat DType | DWildP - deriving (Eq, Show, Data, Generic) + | DTypeP DType + | DInvisP DType + deriving (Eq, Show, Data, Generic, Lift) -- | Corresponds to TH's @Type@ type, used to represent -- types and kinds. @@ -53,7 +189,7 @@ | DArrowT | DLitT TyLit | DWildCardT - deriving (Eq, Show, Data, Generic) + deriving (Eq, Show, Data, Generic, Lift) -- | The type variable binders in a @forall@. data DForallTelescope @@ -64,7 +200,7 @@ | DForallInvis [DTyVarBndrSpec] -- ^ An invisible @forall@ (e.g., @forall a {b} c -> {...}@), -- where each binder has a 'Specificity'. - deriving (Eq, Show, Data, Generic) + deriving (Eq, Show, Data, Generic, Lift) -- | Kinds are types. Corresponds to TH's @Kind@ type DKind = DType @@ -79,7 +215,7 @@ data DTyVarBndr flag = DPlainTV Name flag | DKindedTV Name flag DKind - deriving (Eq, Show, Data, Generic, Functor) + deriving (Eq, Show, Data, Generic, Functor, Foldable, Traversable, Lift) -- | Corresponds to TH's @TyVarBndrSpec@ type DTyVarBndrSpec = DTyVarBndr Specificity @@ -87,32 +223,80 @@ -- | Corresponds to TH's @TyVarBndrUnit@ type DTyVarBndrUnit = DTyVarBndr () +-- | Corresponds to TH's @TyVarBndrVis@ +type DTyVarBndrVis = DTyVarBndr BndrVis + -- | Corresponds to TH's @Match@ type. +-- +-- Note that while @Match@ appears in the TH AST, 'DMatch' does not appear +-- directly in the @th-desugar@ AST. This is because TH's 'Match' is used in +-- lambda (@LamE@) and @case@ (@CaseE@) expressions, but @th-desugar@ does not +-- have counterparts to @LamE@ and @CaseE@ in the 'DExp' data type. Instead, +-- 'DExp' only has a @\\cases@ ('DLamCasesE') construct, which uses 'DClause' +-- instead of 'DMatch'. +-- +-- As such, 'DMatch' only plays a \"vestigial\" role in @th-desugar@ for +-- constructing 'DLamCasesE' values that look like lambda or @case@ expressions. +-- For example, 'DMatch' appears in the type signatures for 'dLamE' and +-- 'dCaseE', which convert the supplied 'DMatch'es to 'DClause's under the hood. data DMatch = DMatch DPat DExp - deriving (Eq, Show, Data, Generic) + deriving (Eq, Show, Data, Generic, Lift) -- | Corresponds to TH's @Clause@ type. data DClause = DClause [DPat] DExp - deriving (Eq, Show, Data, Generic) + deriving (Eq, Show, Data, Generic, Lift) +-- | Convert a 'DMatch' to a 'DClause', where the 'DClause' contains a single +-- pattern taken from the 'DMatch'. +dMatchToDClause :: DMatch -> DClause +dMatchToDClause (DMatch pat rhs) = DClause [pat] rhs + +-- | Return @'Just' match@ if the supplied 'DClause' has exactly one 'DPat', +-- where @match@ matches on that 'DPat'. Otherwise, return 'Nothing'. +dMatch_maybe :: DClause -> Maybe DMatch +dMatch_maybe (DClause pats rhs) = + case pats of + [pat] -> Just (DMatch pat rhs) + _ -> Nothing + -- | Declarations as used in a @let@ statement. data DLetDec = DFunD Name [DClause] | DValD DPat DExp | DSigD Name DType - | DInfixD Fixity Name + | DInfixD Fixity NamespaceSpecifier Name | DPragmaD DPragma - deriving (Eq, Show, Data, Generic) + deriving (Eq, Show, Data, Generic, Lift) --- | Is it a @newtype@ or a @data@ type? -data NewOrData = Newtype - | Data - deriving (Eq, Show, Data, Generic) +#if __GLASGOW_HASKELL__ < 909 +-- | Same as @NamespaceSpecifier@ from TH; defined here for backwards +-- compatibility. +data NamespaceSpecifier + = NoNamespaceSpecifier -- ^ Name may be everything; If there are two + -- names in different namespaces, then consider both + | TypeNamespaceSpecifier -- ^ Name should be a type-level entity, such as a + -- data type, type alias, type family, type class, + -- or type variable + | DataNamespaceSpecifier -- ^ Name should be a term-level entity, such as a + -- function, data constructor, or pattern synonym + deriving (Eq, Ord, Show, Data, Generic, Lift) +#endif -- | Corresponds to TH's @Dec@ type. data DDec = DLetDec DLetDec - | DDataD NewOrData DCxt Name [DTyVarBndrUnit] (Maybe DKind) [DCon] [DDerivClause] - | DTySynD Name [DTyVarBndrUnit] DType - | DClassD DCxt Name [DTyVarBndrUnit] [FunDep] [DDec] + -- | An ordinary (i.e., non-data family) data type declaration. Note + -- that desugaring upholds the following properties regarding the + -- 'DataFlavor' field: + -- + -- * If the 'DataFlavor' is 'NewType', then there will be exactly + -- one 'DCon'. + -- + -- * If the 'DataFlavor' is 'TypeData', then there will be no + -- 'DDerivClause's, the 'DCxt' will be empty, and the 'DConFields' + -- in each 'DCon' will be a 'NormalC' where each 'Bang' is equal + -- to @Bang 'NoSourceUnpackedness' 'NoSourceStrictness'@. + | DDataD DataFlavor DCxt Name [DTyVarBndrVis] (Maybe DKind) [DCon] [DDerivClause] + | DTySynD Name [DTyVarBndrVis] DType + | DClassD DCxt Name [DTyVarBndrVis] [FunDep] [DDec] -- | Note that the @Maybe [DTyVarBndrUnit]@ field is dropped -- entirely when sweetened, so it is only useful for functions -- that directly consume @DDec@s. @@ -120,8 +304,17 @@ | DForeignD DForeign | DOpenTypeFamilyD DTypeFamilyHead | DClosedTypeFamilyD DTypeFamilyHead [DTySynEqn] - | DDataFamilyD Name [DTyVarBndrUnit] (Maybe DKind) - | DDataInstD NewOrData DCxt (Maybe [DTyVarBndrUnit]) DType (Maybe DKind) + | DDataFamilyD Name [DTyVarBndrVis] (Maybe DKind) + -- | A data family instance declaration. Note that desugaring + -- upholds the following properties regarding the 'DataFlavor' + -- field: + -- + -- * If the 'DataFlavor' is 'NewType', then there will be exactly + -- one 'DCon'. + -- + -- * The 'DataFlavor' will never be 'TypeData', as GHC does not + -- permit combining data families with @type data@. + | DDataInstD DataFlavor DCxt (Maybe [DTyVarBndrUnit]) DType (Maybe DKind) [DCon] [DDerivClause] | DTySynInstD DTySynEqn | DRoleAnnotD Name [Role] @@ -136,13 +329,13 @@ -- DKiSigD is part of DDec, not DLetDec, because standalone kind -- signatures can only appear on the top level. | DDefaultD [DType] - deriving (Eq, Show, Data, Generic) + deriving (Eq, Show, Data, Generic, Lift) -- | Corresponds to TH's 'PatSynDir' type data DPatSynDir = DUnidir -- ^ @pattern P x {<-} p@ | DImplBidir -- ^ @pattern P x {=} p@ | DExplBidir [DClause] -- ^ @pattern P x {<-} p where P x = e@ - deriving (Eq, Show, Data, Generic) + deriving (Eq, Show, Data, Generic, Lift) -- | Corresponds to TH's 'PatSynType' type type DPatSynType = DType @@ -153,19 +346,19 @@ = PrefixPatSyn [Name] -- ^ @pattern P {x y z} = p@ | InfixPatSyn Name Name -- ^ @pattern {x P y} = p@ | RecordPatSyn [Name] -- ^ @pattern P { {x,y,z} } = p@ - deriving (Eq, Show, Data, Generic) + deriving (Eq, Show, Data, Generic, Lift) #endif -- | Corresponds to TH's 'TypeFamilyHead' type -data DTypeFamilyHead = DTypeFamilyHead Name [DTyVarBndrUnit] DFamilyResultSig +data DTypeFamilyHead = DTypeFamilyHead Name [DTyVarBndrVis] DFamilyResultSig (Maybe InjectivityAnn) - deriving (Eq, Show, Data, Generic) + deriving (Eq, Show, Data, Generic, Lift) -- | Corresponds to TH's 'FamilyResultSig' type data DFamilyResultSig = DNoSig | DKindSig DKind | DTyVarSig DTyVarBndrUnit - deriving (Eq, Show, Data, Generic) + deriving (Eq, Show, Data, Generic, Lift) -- | Corresponds to TH's 'Con' type. Unlike 'Con', all 'DCon's reflect GADT -- syntax. This is beneficial for @th-desugar@'s since it means @@ -184,13 +377,13 @@ -- * A 'DCon' always has an explicit return type. data DCon = DCon [DTyVarBndrSpec] DCxt Name DConFields DType -- ^ The GADT result type - deriving (Eq, Show, Data, Generic) + deriving (Eq, Show, Data, Generic, Lift) -- | A list of fields either for a standard data constructor or a record -- data constructor. data DConFields = DNormalC DDeclaredInfix [DBangType] | DRecC [DVarBangType] - deriving (Eq, Show, Data, Generic) + deriving (Eq, Show, Data, Generic, Lift) -- | 'True' if a constructor is declared infix. For normal ADTs, this means -- that is was written in infix style. For example, both of the constructors @@ -245,27 +438,34 @@ -- | Corresponds to TH's @Foreign@ type. data DForeign = DImportF Callconv Safety String Name DType | DExportF Callconv String Name DType - deriving (Eq, Show, Data, Generic) + deriving (Eq, Show, Data, Generic, Lift) -- | Corresponds to TH's @Pragma@ type. data DPragma = DInlineP Name Inline RuleMatch Phases - | DSpecialiseP Name DType (Maybe Inline) Phases + | DSpecialiseEP (Maybe [DTyVarBndr ()]) [DRuleBndr] DExp (Maybe Inline) Phases | DSpecialiseInstP DType | DRuleP String (Maybe [DTyVarBndrUnit]) [DRuleBndr] DExp DExp Phases | DAnnP AnnTarget DExp | DLineP Int String | DCompleteP [Name] (Maybe Name) | DOpaqueP Name - deriving (Eq, Show, Data, Generic) + | DSCCP Name (Maybe String) + deriving (Eq, Show, Data, Generic, Lift) +-- | Old-form specialise pragma @{ {\-\# SPECIALISE [INLINE] [phases] (var :: ty) #-} }@. +-- +-- Subsumed by the more general 'DSpecialiseEP' constructor. +pattern DSpecialiseP :: Name -> DType -> Maybe Inline -> Phases -> DPragma +pattern DSpecialiseP nm ty inl phases = DSpecialiseEP Nothing [] (DSigE (DVarE nm) ty) inl phases + -- | Corresponds to TH's @RuleBndr@ type. data DRuleBndr = DRuleVar Name | DTypedRuleVar Name DType - deriving (Eq, Show, Data, Generic) + deriving (Eq, Show, Data, Generic, Lift) -- | Corresponds to TH's @TySynEqn@ type (to store type family equations). data DTySynEqn = DTySynEqn (Maybe [DTyVarBndrUnit]) DType DType - deriving (Eq, Show, Data, Generic) + deriving (Eq, Show, Data, Generic, Lift) -- | Corresponds to TH's @Info@ type. data DInfo = DTyConI DDec (Maybe [DInstanceDec]) @@ -278,17 +478,17 @@ -- ^ The @Int@ is the arity; the @Bool@ is whether this tycon -- is unlifted. | DPatSynI Name DPatSynType - deriving (Eq, Show, Data, Generic) + deriving (Eq, Show, Data, Generic, Lift) type DInstanceDec = DDec -- ^ Guaranteed to be an instance declaration -- | Corresponds to TH's @DerivClause@ type. data DDerivClause = DDerivClause (Maybe DDerivStrategy) DCxt - deriving (Eq, Show, Data, Generic) + deriving (Eq, Show, Data, Generic, Lift) -- | Corresponds to TH's @DerivStrategy@ type. data DDerivStrategy = DStockStrategy -- ^ A \"standard\" derived instance | DAnyclassStrategy -- ^ @-XDeriveAnyClass@ | DNewtypeStrategy -- ^ @-XGeneralizedNewtypeDeriving@ | DViaStrategy DType -- ^ @-XDerivingVia@ - deriving (Eq, Show, Data, Generic) + deriving (Eq, Show, Data, Generic, Lift) diff --git a/Language/Haskell/TH/Desugar/Core.hs b/Language/Haskell/TH/Desugar/Core.hs --- a/Language/Haskell/TH/Desugar/Core.hs +++ b/Language/Haskell/TH/Desugar/Core.hs @@ -14,1967 +14,2438 @@ 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) - -import Control.Monad hiding (forM_, mapM) -import qualified Control.Monad.Fail as Fail -import Control.Monad.Trans (MonadTrans(..)) -import Control.Monad.Writer (MonadWriter(..), WriterT(..)) -import Control.Monad.Zip -import Data.Data (Data) -import Data.Either (lefts) -import Data.Foldable as F hiding (concat, notElem) -import qualified Data.Map as M -import Data.Map (Map) -import Data.Maybe (isJust, mapMaybe) -import Data.Monoid (All(..)) -import qualified Data.Set as S -import Data.Set (Set) -import Data.Traversable - -#if __GLASGOW_HASKELL__ >= 803 -import GHC.OverloadedLabels ( fromLabel ) -#endif - -#if __GLASGOW_HASKELL__ >= 807 -import GHC.Classes (IP(..)) -#endif - -#if __GLASGOW_HASKELL__ >= 902 -import Data.List.NonEmpty (NonEmpty(..)) -import GHC.Records (HasField(..)) -#endif - -import GHC.Exts -import GHC.Generics (Generic) - -import Language.Haskell.TH.Desugar.AST -import Language.Haskell.TH.Desugar.FV -import qualified Language.Haskell.TH.Desugar.OSet as OS -import Language.Haskell.TH.Desugar.OSet (OSet) -import Language.Haskell.TH.Desugar.Util -import Language.Haskell.TH.Desugar.Reify - --- | Desugar an expression -dsExp :: DsMonad q => Exp -> q DExp -dsExp (VarE n) = return $ DVarE n -dsExp (ConE n) = return $ DConE n -dsExp (LitE lit) = return $ DLitE lit -dsExp (AppE e1 e2) = DAppE <$> dsExp e1 <*> dsExp e2 -dsExp (InfixE Nothing op Nothing) = dsExp op -dsExp (InfixE (Just lhs) op Nothing) = DAppE <$> (dsExp op) <*> (dsExp lhs) -dsExp (InfixE Nothing op (Just rhs)) = do - lhsName <- newUniqueName "lhs" - op' <- dsExp op - rhs' <- dsExp rhs - return $ DLamE [lhsName] (foldl DAppE op' [DVarE lhsName, rhs']) -dsExp (InfixE (Just lhs) op (Just rhs)) = - DAppE <$> (DAppE <$> dsExp op <*> dsExp lhs) <*> dsExp rhs -dsExp (UInfixE _ _ _) = - fail "Cannot desugar unresolved infix operators." -dsExp (ParensE exp) = dsExp exp -dsExp (LamE pats exp) = do - exp' <- dsExp exp - (pats', exp'') <- dsPatsOverExp pats exp' - mkDLamEFromDPats pats' exp'' -dsExp (LamCaseE matches) = do - x <- newUniqueName "x" - matches' <- dsMatches x matches - return $ DLamE [x] (DCaseE (DVarE x) matches') -dsExp (TupE exps) = dsTup tupleDataName exps -dsExp (UnboxedTupE exps) = dsTup unboxedTupleDataName exps -dsExp (CondE e1 e2 e3) = - dsExp (CaseE e1 [mkBoolMatch 'True e2, mkBoolMatch 'False e3]) - where - mkBoolMatch :: Name -> Exp -> Match - mkBoolMatch boolDataCon rhs = - Match (ConP boolDataCon -#if __GLASGOW_HASKELL__ >= 901 - [] -#endif - []) (NormalB rhs) [] -dsExp (MultiIfE guarded_exps) = - let failure = mkErrorMatchExpr MultiWayIfAlt in - dsGuards guarded_exps failure -dsExp (LetE decs exp) = do - (decs', ip_binder) <- dsLetDecs decs - exp' <- dsExp exp - return $ DLetE decs' $ ip_binder exp' - -- the following special case avoids creating a new "let" when it's not - -- necessary. See #34. -dsExp (CaseE (VarE scrutinee) matches) = do - matches' <- dsMatches scrutinee matches - return $ DCaseE (DVarE scrutinee) matches' -dsExp (CaseE exp matches) = do - scrutinee <- newUniqueName "scrutinee" - exp' <- dsExp exp - matches' <- dsMatches scrutinee matches - return $ DLetE [DValD (DVarP scrutinee) exp'] $ - DCaseE (DVarE scrutinee) matches' -#if __GLASGOW_HASKELL__ >= 900 -dsExp (DoE mb_mod stmts) = dsDoStmts mb_mod stmts -#else -dsExp (DoE stmts) = dsDoStmts Nothing stmts -#endif -dsExp (CompE stmts) = dsComp stmts -dsExp (ArithSeqE (FromR exp)) = DAppE (DVarE 'enumFrom) <$> dsExp exp -dsExp (ArithSeqE (FromThenR exp1 exp2)) = - DAppE <$> (DAppE (DVarE 'enumFromThen) <$> dsExp exp1) <*> dsExp exp2 -dsExp (ArithSeqE (FromToR exp1 exp2)) = - DAppE <$> (DAppE (DVarE 'enumFromTo) <$> dsExp exp1) <*> dsExp exp2 -dsExp (ArithSeqE (FromThenToR e1 e2 e3)) = - DAppE <$> (DAppE <$> (DAppE (DVarE 'enumFromThenTo) <$> dsExp e1) <*> - dsExp e2) <*> - dsExp e3 -dsExp (ListE exps) = go exps - where go [] = return $ DConE '[] - go (h : t) = DAppE <$> (DAppE (DConE '(:)) <$> dsExp h) <*> go t -dsExp (SigE exp ty) = DSigE <$> dsExp exp <*> dsType ty -dsExp (RecConE con_name field_exps) = do - con <- dataConNameToCon con_name - reordered <- reorder con - return $ foldl DAppE (DConE con_name) reordered - where - reorder con = case con of - NormalC _name fields -> non_record fields - InfixC field1 _name field2 -> non_record [field1, field2] - RecC _name fields -> reorder_fields fields - ForallC _ _ c -> reorder c - GadtC _names fields _ret_ty -> non_record fields - RecGadtC _names fields _ret_ty -> reorder_fields fields - - reorder_fields fields = reorderFields con_name fields field_exps - (repeat $ DVarE 'undefined) - - non_record fields | null field_exps - -- Special case: record construction is allowed for any - -- constructor, regardless of whether the constructor - -- actually was declared with records, provided that no - -- records are given in the expression itself. (See #59). - -- - -- Con{} desugars down to Con undefined ... undefined. - = return $ replicate (length fields) $ DVarE 'undefined - - | otherwise = - impossible $ "Record syntax used with non-record constructor " - ++ (show con_name) ++ "." - -dsExp (RecUpdE exp field_exps) = do - -- here, we need to use one of the field names to find the tycon, somewhat dodgily - first_name <- case field_exps of - ((name, _) : _) -> return name - _ -> impossible "Record update with no fields listed." - info <- reifyWithLocals first_name - applied_type <- case info of - VarI _name ty _m_dec -> extract_first_arg ty - _ -> impossible "Record update with an invalid field name." - type_name <- extract_type_name applied_type - (_, cons) <- getDataD "This seems to be an error in GHC." type_name - let filtered_cons = filter_cons_with_names cons (map fst field_exps) - exp' <- dsExp exp - matches <- mapM con_to_dmatch filtered_cons - let all_matches - | length filtered_cons == length cons = matches - | otherwise = matches ++ [error_match] - return $ DCaseE exp' all_matches - where - extract_first_arg :: DsMonad q => Type -> q Type - extract_first_arg (AppT (AppT ArrowT arg) _) = return arg - extract_first_arg (ForallT _ _ t) = extract_first_arg t - extract_first_arg (SigT t _) = extract_first_arg t - extract_first_arg _ = impossible "Record selector not a function." - - extract_type_name :: DsMonad q => Type -> q Name - extract_type_name (AppT t1 _) = extract_type_name t1 - extract_type_name (SigT t _) = extract_type_name t - extract_type_name (ConT n) = return n - extract_type_name _ = impossible "Record selector domain not a datatype." - - filter_cons_with_names cons field_names = - filter has_names cons - where - args_contain_names args = - let con_field_names = map fst_of_3 args in - all (`elem` con_field_names) field_names - - has_names (RecC _con_name args) = - args_contain_names args - has_names (RecGadtC _con_name args _ret_ty) = - args_contain_names args - has_names (ForallC _ _ c) = has_names c - has_names _ = False - - rec_con_to_dmatch con_name args = do - let con_field_names = map fst_of_3 args - field_var_names <- mapM (newUniqueName . nameBase) con_field_names - DMatch (DConP con_name [] (map DVarP field_var_names)) <$> - (foldl DAppE (DConE con_name) <$> - (reorderFields con_name args field_exps (map DVarE field_var_names))) - - con_to_dmatch :: DsMonad q => Con -> q DMatch - con_to_dmatch (RecC con_name args) = rec_con_to_dmatch con_name args - -- We're assuming the GADT constructor has only one Name here, but since - -- this constructor was reified, this assumption should always hold true. - con_to_dmatch (RecGadtC [con_name] args _ret_ty) = rec_con_to_dmatch con_name args - con_to_dmatch (ForallC _ _ c) = con_to_dmatch c - con_to_dmatch _ = impossible "Internal error within th-desugar." - - error_match = DMatch DWildP (mkErrorMatchExpr RecUpd) - - fst_of_3 (x, _, _) = x -dsExp (StaticE exp) = DStaticE <$> dsExp exp -dsExp (UnboundVarE n) = return (DVarE n) -#if __GLASGOW_HASKELL__ >= 801 -dsExp (AppTypeE exp ty) = DAppTypeE <$> dsExp exp <*> dsType ty -dsExp (UnboxedSumE exp alt arity) = - DAppE (DConE $ unboxedSumDataName alt arity) <$> dsExp exp -#endif -#if __GLASGOW_HASKELL__ >= 803 -dsExp (LabelE str) = return $ DVarE 'fromLabel `DAppTypeE` DLitT (StrTyLit str) -#endif -#if __GLASGOW_HASKELL__ >= 807 -dsExp (ImplicitParamVarE n) = return $ DVarE 'ip `DAppTypeE` DLitT (StrTyLit n) -dsExp (MDoE {}) = fail "th-desugar currently does not support RecursiveDo" -#endif -#if __GLASGOW_HASKELL__ >= 902 -dsExp (GetFieldE arg field) = DAppE (mkGetFieldProj field) <$> dsExp arg -dsExp (ProjectionE fields) = - case fields of - f :| fs -> return $ foldl' comp (mkGetFieldProj f) fs - where - comp :: DExp -> String -> DExp - comp acc f = DVarE '(.) `DAppE` mkGetFieldProj f `DAppE` acc -#endif -#if __GLASGOW_HASKELL__ >= 903 -dsExp (LamCasesE clauses) = do - clauses' <- dsClauses CaseAlt clauses - numArgs <- - case clauses' of - (DClause pats _:_) -> return $ length pats - [] -> fail "\\cases expression must have at least one alternative" - args <- replicateM numArgs (newUniqueName "x") - return $ DLamE args $ DCaseE (mkUnboxedTupleDExp (map DVarE args)) - (map dClauseToUnboxedTupleMatch clauses') -#endif - --- | Convert a 'DClause' to a 'DMatch' by bundling all of the clause's patterns --- into a match on a single unboxed tuple pattern. That is, convert this: --- --- @ --- f x y z = rhs --- @ --- --- To this: --- --- @ --- f (# x, y, z #) = rhs --- @ --- --- This is used to desugar @\\cases@ expressions into lambda expressions. -dClauseToUnboxedTupleMatch :: DClause -> DMatch -dClauseToUnboxedTupleMatch (DClause pats rhs) = - DMatch (mkUnboxedTupleDPat pats) rhs - -#if __GLASGOW_HASKELL__ >= 809 -dsTup :: DsMonad q => (Int -> Name) -> [Maybe Exp] -> q DExp -dsTup = ds_tup -#else -dsTup :: DsMonad q => (Int -> Name) -> [Exp] -> q DExp -dsTup tuple_data_name = ds_tup tuple_data_name . map Just -#endif - --- | Desugar a tuple (or tuple section) expression. -ds_tup :: forall q. DsMonad q - => (Int -> Name) -- ^ Compute the 'Name' of a tuple (boxed or unboxed) - -- data constructor from its arity. - -> [Maybe Exp] -- ^ The tuple's subexpressions. 'Nothing' entries - -- denote empty fields in a tuple section. - -> q DExp -ds_tup tuple_data_name mb_exps = do - section_exps <- mapM ds_section_exp mb_exps - let section_vars = lefts section_exps - tup_body = mk_tup_body section_exps - if null section_vars - then return tup_body -- If this isn't a tuple section, - -- don't create a lambda. - else mkDLamEFromDPats (map DVarP section_vars) tup_body - where - -- If dealing with an empty field in a tuple section (Nothing), create a - -- unique name and return Left. These names will be used to construct the - -- lambda expression that it desugars to. - -- (For example, `(,5)` desugars to `\ts -> (,) ts 5`.) - -- - -- If dealing with a tuple subexpression (Just), desugar it and return - -- Right. - ds_section_exp :: Maybe Exp -> q (Either Name DExp) - ds_section_exp = maybe (Left <$> qNewName "ts") (fmap Right . dsExp) - - mk_tup_body :: [Either Name DExp] -> DExp - mk_tup_body section_exps = - foldl' apply_tup_body (DConE $ tuple_data_name (length section_exps)) - section_exps - - apply_tup_body :: DExp -> Either Name DExp -> DExp - apply_tup_body f (Left n) = f `DAppE` DVarE n - apply_tup_body f (Right e) = f `DAppE` e - --- | Convert a list of 'DPat' arguments and a 'DExp' body into a 'DLamE'. This --- is needed since 'DLamE' takes a list of 'Name's for its bound variables --- instead of 'DPat's, so some reorganization is needed. -mkDLamEFromDPats :: Quasi q => [DPat] -> DExp -> q DExp -mkDLamEFromDPats pats exp - | Just names <- mapM stripDVarP_maybe pats - = return $ DLamE names exp - | otherwise - = do arg_names <- replicateM (length pats) (newUniqueName "arg") - let scrutinee = mkUnboxedTupleDExp (map DVarE arg_names) - match = DMatch (mkUnboxedTupleDPat pats) exp - return $ DLamE arg_names (DCaseE scrutinee [match]) - where - stripDVarP_maybe :: DPat -> Maybe Name - stripDVarP_maybe (DVarP n) = Just n - stripDVarP_maybe _ = Nothing - -#if __GLASGOW_HASKELL__ >= 902 -mkGetFieldProj :: String -> DExp -mkGetFieldProj field = DVarE 'getField `DAppTypeE` DLitT (StrTyLit field) -#endif - --- | Desugar a list of matches for a @case@ statement -dsMatches :: DsMonad q - => Name -- ^ Name of the scrutinee, which must be a bare var - -> [Match] -- ^ Matches of the @case@ statement - -> q [DMatch] -dsMatches scr = go - where - go :: DsMonad q => [Match] -> q [DMatch] - go [] = return [] - go (Match pat body where_decs : rest) = do - rest' <- go rest - let failure = maybeDCaseE CaseAlt (DVarE scr) rest' - exp' <- dsBody body where_decs failure - (pat', exp'') <- dsPatOverExp pat exp' - uni_pattern <- isUniversalPattern pat' -- incomplete attempt at #6 - if uni_pattern - then return [DMatch pat' exp''] - else return (DMatch pat' exp'' : rest') - --- | Desugar a @Body@ -dsBody :: DsMonad q - => Body -- ^ body to desugar - -> [Dec] -- ^ "where" declarations - -> DExp -- ^ what to do if the guards don't match - -> q DExp -dsBody (NormalB exp) decs _ = do - (decs', ip_binder) <- dsLetDecs decs - exp' <- dsExp exp - return $ maybeDLetE decs' $ ip_binder exp' -dsBody (GuardedB guarded_exps) decs failure = do - (decs', ip_binder) <- dsLetDecs decs - guarded_exp' <- dsGuards guarded_exps failure - return $ maybeDLetE decs' $ ip_binder guarded_exp' - --- | If decs is non-empty, delcare them in a let: -maybeDLetE :: [DLetDec] -> DExp -> DExp -maybeDLetE [] exp = exp -maybeDLetE decs exp = DLetE decs exp - --- | If matches is non-empty, make a case statement; otherwise make an error statement -maybeDCaseE :: MatchContext -> DExp -> [DMatch] -> DExp -maybeDCaseE mc _ [] = mkErrorMatchExpr mc -maybeDCaseE _ scrut matches = DCaseE scrut matches - --- | Desugar guarded expressions -dsGuards :: DsMonad q - => [(Guard, Exp)] -- ^ Guarded expressions - -> DExp -- ^ What to do if none of the guards match - -> q DExp -dsGuards [] thing_inside = return thing_inside -dsGuards ((NormalG gd, exp) : rest) thing_inside = - dsGuards ((PatG [NoBindS gd], exp) : rest) thing_inside -dsGuards ((PatG stmts, exp) : rest) thing_inside = do - success <- dsExp exp - failure <- dsGuards rest thing_inside - dsGuardStmts stmts success failure - --- | Desugar the @Stmt@s in a guard -dsGuardStmts :: DsMonad q - => [Stmt] -- ^ The @Stmt@s to desugar - -> DExp -- ^ What to do if the @Stmt@s yield success - -> DExp -- ^ What to do if the @Stmt@s yield failure - -> q DExp -dsGuardStmts [] success _failure = return success -dsGuardStmts (BindS pat exp : rest) success failure = do - success' <- dsGuardStmts rest success failure - (pat', success'') <- dsPatOverExp pat success' - exp' <- dsExp exp - return $ DCaseE exp' [DMatch pat' success'', DMatch DWildP failure] -dsGuardStmts (LetS decs : rest) success failure = do - (decs', ip_binder) <- dsLetDecs decs - success' <- dsGuardStmts rest success failure - return $ DLetE decs' $ ip_binder success' - -- special-case a final pattern containing "otherwise" or "True" - -- note that GHC does this special-casing, too, in DsGRHSs.isTrueLHsExpr -dsGuardStmts [NoBindS exp] success _failure - | VarE name <- exp - , name == 'otherwise - = return success - - | ConE name <- exp - , name == 'True - = return success -dsGuardStmts (NoBindS exp : rest) success failure = do - exp' <- dsExp exp - success' <- dsGuardStmts rest success failure - return $ DCaseE exp' [ DMatch (DConP 'True [] []) success' - , DMatch (DConP 'False [] []) failure ] -dsGuardStmts (ParS _ : _) _ _ = impossible "Parallel comprehension in a pattern guard." -#if __GLASGOW_HASKELL__ >= 807 -dsGuardStmts (RecS {} : _) _ _ = fail "th-desugar currently does not support RecursiveDo" -#endif - --- | Desugar the @Stmt@s in a @do@ expression -dsDoStmts :: forall q. DsMonad q => Maybe ModName -> [Stmt] -> q DExp -dsDoStmts mb_mod = go - where - go :: [Stmt] -> q DExp - go [] = impossible "do-expression ended with something other than bare statement." - go [NoBindS exp] = dsExp exp - go (BindS pat exp : rest) = do - rest' <- go rest - dsBindS mb_mod exp pat rest' "do expression" - go (LetS decs : rest) = do - (decs', ip_binder) <- dsLetDecs decs - rest' <- go rest - return $ DLetE decs' $ ip_binder rest' - go (NoBindS exp : rest) = do - exp' <- dsExp exp - rest' <- go rest - let sequence_name = mk_qual_do_name mb_mod '(>>) - return $ DAppE (DAppE (DVarE sequence_name) exp') rest' - go (ParS _ : _) = impossible "Parallel comprehension in a do-statement." -#if __GLASGOW_HASKELL__ >= 807 - go (RecS {} : _) = fail "th-desugar currently does not support RecursiveDo" -#endif - --- | Desugar the @Stmt@s in a list or monad comprehension -dsComp :: DsMonad q => [Stmt] -> q DExp -dsComp [] = impossible "List/monad comprehension ended with something other than a bare statement." -dsComp [NoBindS exp] = DAppE (DVarE 'return) <$> dsExp exp -dsComp (BindS pat exp : rest) = do - rest' <- dsComp rest - dsBindS Nothing exp pat rest' "monad comprehension" -dsComp (LetS decs : rest) = do - (decs', ip_binder) <- dsLetDecs decs - rest' <- dsComp rest - return $ DLetE decs' $ ip_binder rest' -dsComp (NoBindS exp : rest) = do - exp' <- dsExp exp - rest' <- dsComp rest - return $ DAppE (DAppE (DVarE '(>>)) (DAppE (DVarE 'guard) exp')) rest' -dsComp (ParS stmtss : rest) = do - (pat, exp) <- dsParComp stmtss - rest' <- dsComp rest - DAppE (DAppE (DVarE '(>>=)) exp) <$> mkDLamEFromDPats [pat] rest' -#if __GLASGOW_HASKELL__ >= 807 -dsComp (RecS {} : _) = fail "th-desugar currently does not support RecursiveDo" -#endif - --- Desugar a binding statement in a do- or list comprehension. --- --- In the event that the pattern in the statement is partial, the desugared --- case expression will contain a catch-all case that calls 'fail' from either --- 'MonadFail' or 'Monad', depending on whether the @MonadFailDesugaring@ --- language extension is enabled or not. (On GHCs older than 8.0, 'fail' from --- 'Monad' is always used.) -dsBindS :: forall q. DsMonad q - => Maybe ModName -> Exp -> Pat -> DExp -> String -> q DExp -dsBindS mb_mod bind_arg_exp success_pat success_exp ctxt = do - bind_arg_exp' <- dsExp bind_arg_exp - (success_pat', success_exp') <- dsPatOverExp success_pat success_exp - is_univ_pat <- isUniversalPattern success_pat' - let bind_into = DAppE (DAppE (DVarE bind_name) bind_arg_exp') - if is_univ_pat - then bind_into <$> mkDLamEFromDPats [success_pat'] success_exp' - else do arg_name <- newUniqueName "arg" - fail_name <- mk_fail_name - return $ bind_into $ DLamE [arg_name] $ DCaseE (DVarE arg_name) - [ DMatch success_pat' success_exp' - , DMatch DWildP $ - DVarE fail_name `DAppE` - DLitE (StringL $ "Pattern match failure in " ++ ctxt) - ] - where - bind_name = mk_qual_do_name mb_mod '(>>=) - - mk_fail_name :: q Name -#if __GLASGOW_HASKELL__ >= 807 - -- GHC 8.8 deprecates the MonadFailDesugaring extension since its effects - -- are always enabled. Furthermore, MonadFailDesugaring is no longer - -- enabled by default, so simply use MonadFail.fail. (That happens to - -- be the same as Prelude.fail in 8.8+.) - mk_fail_name = return fail_MonadFail_name -#else - mk_fail_name = do - mfd <- qIsExtEnabled MonadFailDesugaring - return $ if mfd then fail_MonadFail_name else fail_Prelude_name -#endif - - fail_MonadFail_name = mk_qual_do_name mb_mod 'Fail.fail - -#if __GLASGOW_HASKELL__ < 807 - fail_Prelude_name = mk_qual_do_name mb_mod 'Prelude.fail -#endif - --- | Desugar the contents of a parallel comprehension. --- Returns a @Pat@ containing a tuple of all bound variables and an expression --- to produce the values for those variables -dsParComp :: DsMonad q => [[Stmt]] -> q (DPat, DExp) -dsParComp [] = impossible "Empty list of parallel comprehension statements." -dsParComp [r] = do - let rv = foldMap extractBoundNamesStmt r - dsR <- dsComp (r ++ [mk_tuple_stmt rv]) - return (mk_tuple_dpat rv, dsR) -dsParComp (q : rest) = do - let qv = foldMap extractBoundNamesStmt q - (rest_pat, rest_exp) <- dsParComp rest - dsQ <- dsComp (q ++ [mk_tuple_stmt qv]) - let zipped = DAppE (DAppE (DVarE 'mzip) dsQ) rest_exp - return (DConP (tupleDataName 2) [] [mk_tuple_dpat qv, rest_pat], zipped) - --- helper function for dsParComp -mk_tuple_stmt :: OSet Name -> Stmt -mk_tuple_stmt name_set = - NoBindS (mkTupleExp (F.foldr ((:) . VarE) [] name_set)) - --- helper function for dsParComp -mk_tuple_dpat :: OSet Name -> DPat -mk_tuple_dpat name_set = - mkTupleDPat (F.foldr ((:) . DVarP) [] name_set) - --- | Desugar a pattern, along with processing a (desugared) expression that --- is the entire scope of the variables bound in the pattern. -dsPatOverExp :: DsMonad q => Pat -> DExp -> q (DPat, DExp) -dsPatOverExp pat exp = do - (pat', vars) <- runWriterT $ dsPat pat - let name_decs = map (uncurry (DValD . DVarP)) vars - return (pat', maybeDLetE name_decs exp) - --- | Desugar multiple patterns. Like 'dsPatOverExp'. -dsPatsOverExp :: DsMonad q => [Pat] -> DExp -> q ([DPat], DExp) -dsPatsOverExp pats exp = do - (pats', vars) <- runWriterT $ mapM dsPat pats - let name_decs = map (uncurry (DValD . DVarP)) vars - return (pats', maybeDLetE name_decs exp) - --- | Desugar a pattern, returning a list of (Name, DExp) pairs of extra --- variables that must be bound within the scope of the pattern -dsPatX :: DsMonad q => Pat -> q (DPat, [(Name, DExp)]) -dsPatX = runWriterT . dsPat - --- | Desugaring a pattern also returns the list of variables bound in as-patterns --- and the values they should be bound to. This variables must be brought into --- scope in the "body" of the pattern. -type PatM q = WriterT [(Name, DExp)] q - --- | Desugar a pattern. -dsPat :: DsMonad q => Pat -> PatM q DPat -dsPat (LitP lit) = return $ DLitP lit -dsPat (VarP n) = return $ DVarP n -dsPat (TupP pats) = DConP (tupleDataName (length pats)) [] <$> mapM dsPat pats -dsPat (UnboxedTupP pats) = DConP (unboxedTupleDataName (length pats)) [] <$> - mapM dsPat pats -#if __GLASGOW_HASKELL__ >= 901 -dsPat (ConP name tys pats) = DConP name <$> mapM dsType tys <*> mapM dsPat pats -#else -dsPat (ConP name pats) = DConP name [] <$> mapM dsPat pats -#endif -dsPat (InfixP p1 name p2) = DConP name [] <$> mapM dsPat [p1, p2] -dsPat (UInfixP _ _ _) = - fail "Cannot desugar unresolved infix operators." -dsPat (ParensP pat) = dsPat pat -dsPat (TildeP pat) = DTildeP <$> dsPat pat -dsPat (BangP pat) = DBangP <$> dsPat pat -dsPat (AsP name pat) = do - pat' <- dsPat pat - pat'' <- lift $ removeWilds pat' - tell [(name, dPatToDExp pat'')] - return pat'' -dsPat WildP = return DWildP -dsPat (RecP con_name field_pats) = do - con <- lift $ dataConNameToCon con_name - reordered <- reorder con - return $ DConP con_name [] reordered - where - reorder con = case con of - NormalC _name fields -> non_record fields - InfixC field1 _name field2 -> non_record [field1, field2] - RecC _name fields -> reorder_fields_pat fields - ForallC _ _ c -> reorder c - GadtC _names fields _ret_ty -> non_record fields - RecGadtC _names fields _ret_ty -> reorder_fields_pat fields - - reorder_fields_pat fields = reorderFieldsPat con_name fields field_pats - - non_record fields | null field_pats - -- Special case: record patterns are allowed for any - -- constructor, regardless of whether the constructor - -- actually was declared with records, provided that - -- no records are given in the pattern itself. (See #59). - -- - -- Con{} desugars down to Con _ ... _. - = return $ replicate (length fields) DWildP - | otherwise = lift $ impossible - $ "Record syntax used with non-record constructor " - ++ (show con_name) ++ "." - -dsPat (ListP pats) = go pats - where go [] = return $ DConP '[] [] [] - go (h : t) = do - h' <- dsPat h - t' <- go t - return $ DConP '(:) [] [h', t'] -dsPat (SigP pat ty) = DSigP <$> dsPat pat <*> dsType ty -#if __GLASGOW_HASKELL__ >= 801 -dsPat (UnboxedSumP pat alt arity) = - DConP (unboxedSumDataName alt arity) [] <$> ((:[]) <$> dsPat pat) -#endif -dsPat (ViewP _ _) = - fail "View patterns are not supported in th-desugar. Use pattern guards instead." - --- | Convert a 'DPat' to a 'DExp'. Fails on 'DWildP'. -dPatToDExp :: DPat -> DExp -dPatToDExp (DLitP lit) = DLitE lit -dPatToDExp (DVarP name) = DVarE name -dPatToDExp (DConP name tys pats) = foldl DAppE (foldl DAppTypeE (DConE name) tys) (map dPatToDExp pats) -dPatToDExp (DTildeP pat) = dPatToDExp pat -dPatToDExp (DBangP pat) = dPatToDExp pat -dPatToDExp (DSigP pat ty) = DSigE (dPatToDExp pat) ty -dPatToDExp DWildP = error "Internal error in th-desugar: wildcard in rhs of as-pattern" - --- | Remove all wildcards from a pattern, replacing any wildcard with a fresh --- variable -removeWilds :: DsMonad q => DPat -> q DPat -removeWilds p@(DLitP _) = return p -removeWilds p@(DVarP _) = return p -removeWilds (DConP con_name tys pats) = DConP con_name tys <$> mapM removeWilds pats -removeWilds (DTildeP pat) = DTildeP <$> removeWilds pat -removeWilds (DBangP pat) = DBangP <$> removeWilds pat -removeWilds (DSigP pat ty) = DSigP <$> removeWilds pat <*> pure ty -removeWilds DWildP = DVarP <$> newUniqueName "wild" - --- | Desugar @Info@ -dsInfo :: DsMonad q => Info -> q DInfo -dsInfo (ClassI dec instances) = do - [ddec] <- dsDec dec - dinstances <- dsDecs instances - return $ DTyConI ddec (Just dinstances) -dsInfo (ClassOpI name ty parent) = - DVarI name <$> dsType ty <*> pure (Just parent) -dsInfo (TyConI dec) = do - [ddec] <- dsDec dec - return $ DTyConI ddec Nothing -dsInfo (FamilyI dec instances) = do - [ddec] <- dsDec dec - dinstances <- dsDecs instances - return $ DTyConI ddec (Just dinstances) -dsInfo (PrimTyConI name arity unlifted) = - return $ DPrimTyConI name arity unlifted -dsInfo (DataConI name ty parent) = - DVarI name <$> dsType ty <*> pure (Just parent) -dsInfo (VarI name ty Nothing) = - DVarI name <$> dsType ty <*> pure Nothing -dsInfo (VarI name _ (Just _)) = - impossible $ "Declaration supplied with variable: " ++ show name -dsInfo (TyVarI name ty) = DTyVarI name <$> dsType ty -#if __GLASGOW_HASKELL__ >= 801 -dsInfo (PatSynI name ty) = DPatSynI name <$> dsType ty -#endif - --- | Desugar arbitrary @Dec@s -dsDecs :: DsMonad q => [Dec] -> q [DDec] -dsDecs = concatMapM dsDec - --- | Desugar a single @Dec@, perhaps producing multiple 'DDec's -dsDec :: DsMonad q => Dec -> q [DDec] -dsDec d@(FunD {}) = dsTopLevelLetDec d -dsDec d@(ValD {}) = dsTopLevelLetDec d -dsDec (DataD cxt n tvbs mk cons derivings) = - dsDataDec Data cxt n tvbs mk cons derivings -dsDec (NewtypeD cxt n tvbs mk con derivings) = - dsDataDec Newtype cxt n tvbs mk [con] derivings -dsDec (TySynD n tvbs ty) = - (:[]) <$> (DTySynD n <$> mapM dsTvbUnit tvbs <*> dsType ty) -dsDec (ClassD cxt n tvbs fds decs) = - (:[]) <$> (DClassD <$> dsCxt cxt <*> pure n <*> mapM dsTvbUnit tvbs - <*> pure fds <*> dsDecs decs) -dsDec (InstanceD over cxt ty decs) = - (:[]) <$> (DInstanceD over Nothing <$> dsCxt cxt <*> dsType ty <*> dsDecs decs) -dsDec d@(SigD {}) = dsTopLevelLetDec d -dsDec (ForeignD f) = (:[]) <$> (DForeignD <$> dsForeign f) -dsDec d@(InfixD {}) = dsTopLevelLetDec d -dsDec d@(PragmaD {}) = dsTopLevelLetDec d -dsDec (OpenTypeFamilyD tfHead) = - (:[]) <$> (DOpenTypeFamilyD <$> dsTypeFamilyHead tfHead) -dsDec (DataFamilyD n tvbs m_k) = - (:[]) <$> (DDataFamilyD n <$> mapM dsTvbUnit tvbs <*> mapM dsType m_k) -#if __GLASGOW_HASKELL__ >= 807 -dsDec (DataInstD cxt mtvbs lhs mk cons derivings) = - case unfoldType lhs of - (ConT n, tys) -> dsDataInstDec Data cxt n mtvbs tys mk cons derivings - (_, _) -> fail $ "Unexpected data instance LHS: " ++ pprint lhs -dsDec (NewtypeInstD cxt mtvbs lhs mk con derivings) = - case unfoldType lhs of - (ConT n, tys) -> dsDataInstDec Newtype cxt n mtvbs tys mk [con] derivings - (_, _) -> fail $ "Unexpected newtype instance LHS: " ++ pprint lhs -#else -dsDec (DataInstD cxt n tys mk cons derivings) = - dsDataInstDec Data cxt n Nothing (map TANormal tys) mk cons derivings -dsDec (NewtypeInstD cxt n tys mk con derivings) = - dsDataInstDec Newtype cxt n Nothing (map TANormal tys) mk [con] derivings -#endif -#if __GLASGOW_HASKELL__ >= 807 -dsDec (TySynInstD eqn) = (:[]) <$> (DTySynInstD <$> dsTySynEqn unusedArgument eqn) -#else -dsDec (TySynInstD n eqn) = (:[]) <$> (DTySynInstD <$> dsTySynEqn n eqn) -#endif -dsDec (ClosedTypeFamilyD tfHead eqns) = - (:[]) <$> (DClosedTypeFamilyD <$> dsTypeFamilyHead tfHead - <*> mapM (dsTySynEqn (typeFamilyHeadName tfHead)) eqns) -dsDec (RoleAnnotD n roles) = return [DRoleAnnotD n roles] -#if __GLASGOW_HASKELL__ >= 801 -dsDec (PatSynD n args dir pat) = do - dir' <- dsPatSynDir n dir - (pat', vars) <- dsPatX pat - unless (null vars) $ - fail $ "Pattern synonym definition cannot contain as-patterns (@)." - return [DPatSynD n args dir' pat'] -dsDec (PatSynSigD n ty) = (:[]) <$> (DPatSynSigD n <$> dsType ty) -dsDec (StandaloneDerivD mds cxt ty) = - (:[]) <$> (DStandaloneDerivD <$> mapM dsDerivStrategy mds - <*> pure Nothing <*> dsCxt cxt <*> dsType ty) -#else -dsDec (StandaloneDerivD cxt ty) = - (:[]) <$> (DStandaloneDerivD Nothing Nothing <$> dsCxt cxt <*> dsType ty) -#endif -dsDec (DefaultSigD n ty) = (:[]) <$> (DDefaultSigD n <$> dsType ty) -#if __GLASGOW_HASKELL__ >= 807 -dsDec (ImplicitParamBindD {}) = impossible "Non-`let`-bound implicit param binding" -#endif -#if __GLASGOW_HASKELL__ >= 809 -dsDec (KiSigD n ki) = (:[]) <$> (DKiSigD n <$> dsType ki) -#endif -#if __GLASGOW_HASKELL__ >= 903 -dsDec (DefaultD tys) = (:[]) <$> (DDefaultD <$> mapM dsType tys) -#endif - --- | Desugar a 'DataD' or 'NewtypeD'. -dsDataDec :: DsMonad q - => NewOrData -> Cxt -> Name -> [TyVarBndrUnit] - -> Maybe Kind -> [Con] -> [DerivingClause] -> q [DDec] -dsDataDec nd cxt n tvbs mk cons derivings = do - tvbs' <- mapM dsTvbUnit tvbs - let h98_tvbs = case mk of - -- If there's an explicit return kind, we're dealing with a - -- GADT, so this argument goes unused in dsCon. - Just {} -> unusedArgument - Nothing -> tvbs' - h98_return_type = nonFamilyDataReturnType n tvbs' - (:[]) <$> (DDataD nd <$> dsCxt cxt <*> pure n - <*> pure tvbs' <*> mapM dsType mk - <*> concatMapM (dsCon h98_tvbs h98_return_type) cons - <*> mapM dsDerivClause derivings) - --- | Desugar a 'DataInstD' or a 'NewtypeInstD'. -dsDataInstDec :: DsMonad q - => 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 dsTvbUnit) mtvbs - tys' <- mapM dsTypeArg tys - let lhs' = applyDType (DConT n) tys' - h98_tvbs = - case (mk, mtvbs') of - -- If there's an explicit return kind, we're dealing with a - -- GADT, so this argument goes unused in dsCon. - (Just {}, _) -> unusedArgument - -- H98, and there is an explicit `forall` in front. Just reuse the - -- type variable binders from the `forall`. - (Nothing, Just tvbs') -> tvbs' - -- H98, and no explicit `forall`. Compute the bound variables - -- manually. - (Nothing, Nothing) -> dataFamInstTvbs tys' - h98_fam_inst_type = dataFamInstReturnType n tys' - (:[]) <$> (DDataInstD nd <$> dsCxt cxt <*> pure mtvbs' - <*> pure lhs' <*> mapM dsType mk - <*> concatMapM (dsCon h98_tvbs h98_fam_inst_type) cons - <*> mapM dsDerivClause derivings) - --- | Desugar a @FamilyResultSig@ -dsFamilyResultSig :: DsMonad q => FamilyResultSig -> q DFamilyResultSig -dsFamilyResultSig NoSig = return DNoSig -dsFamilyResultSig (KindSig k) = DKindSig <$> dsType k -dsFamilyResultSig (TyVarSig tvb) = DTyVarSig <$> dsTvbUnit tvb - --- | Desugar a @TypeFamilyHead@ -dsTypeFamilyHead :: DsMonad q => TypeFamilyHead -> q DTypeFamilyHead -dsTypeFamilyHead (TypeFamilyHead n tvbs result inj) - = DTypeFamilyHead n <$> mapM dsTvbUnit tvbs - <*> dsFamilyResultSig result - <*> pure inj - -typeFamilyHeadName :: TypeFamilyHead -> Name -typeFamilyHeadName (TypeFamilyHead n _ _ _) = n - --- | Desugar @Dec@s that can appear in a @let@ expression. See the --- documentation for 'dsLetDec' for an explanation of what the return type --- represents. -dsLetDecs :: DsMonad q => [Dec] -> q ([DLetDec], DExp -> DExp) -dsLetDecs decs = do - (let_decss, ip_binders) <- mapAndUnzipM dsLetDec decs - let let_decs :: [DLetDec] - let_decs = concat let_decss - - ip_binder :: DExp -> DExp - ip_binder = foldr (.) id ip_binders - return (let_decs, ip_binder) - --- | Desugar a single 'Dec' that can appear in a @let@ expression. --- This produces the following output: --- --- * One or more 'DLetDec's (a single 'Dec' can produce multiple 'DLetDec's --- in the event of a value declaration that binds multiple things by way --- of pattern matching. --- --- * A function of type @'DExp' -> 'DExp'@, which should be applied to the --- expression immediately following the 'DLetDec's. This function prepends --- binding forms for any implicit params that were bound in the argument --- 'Dec'. (If no implicit params are bound, this is simply the 'id' --- function.) --- --- For instance, if the argument to 'dsLetDec' is the @?x = 42@ part of this --- expression: --- --- @ --- let { ?x = 42 } in ?x --- @ --- --- Then the output is: --- --- * @let new_x_val = 42@ --- --- * @\\z -> 'bindIP' \@\"x\" new_x_val z@ --- --- This way, the expression --- @let { new_x_val = 42 } in 'bindIP' \@"x" new_x_val ('ip' \@\"x\")@ can be --- formed. The implicit param binders always come after all the other --- 'DLetDec's to support parallel assignment of implicit params. -dsLetDec :: DsMonad q => Dec -> q ([DLetDec], DExp -> DExp) -dsLetDec (FunD name clauses) = do - clauses' <- dsClauses (FunRhs name) clauses - return ([DFunD name clauses'], id) -dsLetDec (ValD pat body where_decs) = do - (pat', vars) <- dsPatX pat - body' <- dsBody body where_decs error_exp - let extras = uncurry (zipWith (DValD . DVarP)) $ unzip vars - return (DValD pat' body' : extras, id) - where - error_exp = mkErrorMatchExpr (LetDecRhs pat) -dsLetDec (SigD name ty) = do - ty' <- dsType ty - return ([DSigD name ty'], id) -dsLetDec (InfixD fixity name) = return ([DInfixD fixity name], id) -dsLetDec (PragmaD prag) = do - prag' <- dsPragma prag - return ([DPragmaD prag'], id) -#if __GLASGOW_HASKELL__ >= 807 -dsLetDec (ImplicitParamBindD n e) = do - new_n_name <- qNewName $ "new_" ++ n ++ "_val" - e' <- dsExp e - let let_dec :: DLetDec - let_dec = DValD (DVarP new_n_name) e' - - ip_binder :: DExp -> DExp - ip_binder = (DVarE 'bindIP `DAppTypeE` - DLitT (StrTyLit n) `DAppE` - DVarE new_n_name `DAppE`) - return ([let_dec], ip_binder) -#endif -dsLetDec _dec = impossible "Illegal declaration in let expression." - --- | Desugar a single 'Dec' corresponding to something that could appear after --- the @let@ in a @let@ expression, but occurring at the top level. Because the --- 'Dec' occurs at the top level, there is nothing that would correspond to the --- @in ...@ part of the @let@ expression. As a consequence, this function does --- not return a @'DExp' -> 'DExp'@ function corresonding to implicit param --- binders (these cannot occur at the top level). -dsTopLevelLetDec :: DsMonad q => Dec -> q [DDec] -dsTopLevelLetDec = fmap (map DLetDec . fst) . dsLetDec - -- Note the use of fst above: we're silently throwing away any implicit param - -- binders that dsLetDec returns, since there is invariant that there will be - -- no implicit params in the first place. - --- | Desugar a single @Con@. --- --- Because we always desugar @Con@s to GADT syntax (see the documentation for --- 'DCon'), it is not always possible to desugar with just a 'Con' alone. --- For instance, we must desugar: --- --- @ --- data Foo a = forall b. MkFoo b --- @ --- --- To this: --- --- @ --- data Foo a :: Type where --- MkFoo :: forall a b. b -> Foo a --- @ --- --- If our only argument was @forall b. MkFoo b@, it would be somewhat awkward --- to figure out (1) what the set of universally quantified type variables --- (@[a]@) was, and (2) what the return type (@Foo a@) was. For this reason, --- we require passing these as arguments. (If we desugar an actual GADT --- constructor, these arguments are ignored.) -dsCon :: DsMonad q - => [DTyVarBndrUnit] -- ^ The universally quantified type variables - -- (used if desugaring a non-GADT constructor). - -> DType -- ^ The original data declaration's type - -- (used if desugaring a non-GADT constructor). - -> Con -> q [DCon] -dsCon univ_dtvbs data_type con = do - dcons' <- dsCon' con - return $ flip map dcons' $ \(n, dtvbs, dcxt, fields, m_gadt_type) -> - case m_gadt_type of - Nothing -> - let ex_dtvbs = dtvbs - expl_dtvbs = changeDTVFlags SpecifiedSpec univ_dtvbs ++ - ex_dtvbs - impl_dtvbs = changeDTVFlags SpecifiedSpec $ - toposortTyVarsOf $ mapMaybe extractTvbKind expl_dtvbs in - DCon (impl_dtvbs ++ expl_dtvbs) dcxt n fields data_type - Just gadt_type -> - let univ_ex_dtvbs = dtvbs in - DCon univ_ex_dtvbs dcxt n fields gadt_type - --- Desugar a Con in isolation. The meaning of the returned DTyVarBndrs changes --- depending on what the returned Maybe DType value is: --- --- * If returning Just gadt_ty, then we've encountered a GadtC or RecGadtC, --- so the returned DTyVarBndrs are both the universally and existentially --- quantified tyvars. --- * If returning Nothing, we're dealing with a non-GADT constructor, so --- the returned DTyVarBndrs are the existentials only. -dsCon' :: DsMonad q - => Con -> q [(Name, [DTyVarBndrSpec], DCxt, DConFields, Maybe DType)] -dsCon' (NormalC n stys) = do - dtys <- mapM dsBangType stys - return [(n, [], [], DNormalC False dtys, Nothing)] -dsCon' (RecC n vstys) = do - vdtys <- mapM dsVarBangType vstys - return [(n, [], [], DRecC vdtys, Nothing)] -dsCon' (InfixC sty1 n sty2) = do - dty1 <- dsBangType sty1 - dty2 <- dsBangType sty2 - return [(n, [], [], DNormalC True [dty1, dty2], Nothing)] -dsCon' (ForallC tvbs cxt con) = do - dtvbs <- mapM dsTvbSpec tvbs - dcxt <- dsCxt cxt - dcons' <- dsCon' con - return $ flip map dcons' $ \(n, dtvbs', dcxt', fields, m_gadt_type) -> - (n, dtvbs ++ dtvbs', dcxt ++ dcxt', fields, m_gadt_type) -dsCon' (GadtC nms btys rty) = do - dbtys <- mapM dsBangType btys - drty <- dsType rty - sequence $ flip map nms $ \nm -> do - mbFi <- reifyFixityWithLocals nm - -- A GADT data constructor is declared infix when these three - -- properties hold: - let decInfix = isInfixDataCon (nameBase nm) -- 1. Its name uses operator syntax - -- (e.g., (:*:)) - && length dbtys == 2 -- 2. It has exactly two fields - && isJust mbFi -- 3. It has a programmer-specified - -- fixity declaration - return (nm, [], [], DNormalC decInfix dbtys, Just drty) -dsCon' (RecGadtC nms vbtys rty) = do - dvbtys <- mapM dsVarBangType vbtys - drty <- dsType rty - return $ flip map nms $ \nm -> - (nm, [], [], DRecC dvbtys, Just drty) - --- | Desugar a @BangType@. -dsBangType :: DsMonad q => BangType -> q DBangType -dsBangType (b, ty) = (b, ) <$> dsType ty - --- | Desugar a @VarBangType@. -dsVarBangType :: DsMonad q => VarBangType -> q DVarBangType -dsVarBangType (n, b, ty) = (n, b, ) <$> dsType ty - --- | Desugar a @Foreign@. -dsForeign :: DsMonad q => Foreign -> q DForeign -dsForeign (ImportF cc safety str n ty) = DImportF cc safety str n <$> dsType ty -dsForeign (ExportF cc str n ty) = DExportF cc str n <$> dsType ty - --- | Desugar a @Pragma@. -dsPragma :: DsMonad q => Pragma -> q DPragma -dsPragma (InlineP n inl rm phases) = return $ DInlineP n inl rm phases -dsPragma (SpecialiseP n ty m_inl phases) = DSpecialiseP n <$> dsType ty - <*> pure m_inl - <*> pure phases -dsPragma (SpecialiseInstP ty) = DSpecialiseInstP <$> dsType ty -#if __GLASGOW_HASKELL__ >= 807 -dsPragma (RuleP str mtvbs rbs lhs rhs phases) - = DRuleP str <$> mapM (mapM dsTvbUnit) mtvbs - <*> mapM dsRuleBndr rbs - <*> dsExp lhs - <*> dsExp rhs - <*> pure phases -#else -dsPragma (RuleP str rbs lhs rhs phases) = DRuleP str Nothing - <$> mapM dsRuleBndr rbs - <*> dsExp lhs - <*> dsExp rhs - <*> pure phases -#endif -dsPragma (AnnP target exp) = DAnnP target <$> dsExp exp -dsPragma (LineP n str) = return $ DLineP n str -#if __GLASGOW_HASKELL__ >= 801 -dsPragma (CompleteP cls mty) = return $ DCompleteP cls mty -#endif -#if __GLASGOW_HASKELL__ >= 903 -dsPragma (OpaqueP n) = return $ DOpaqueP n -#endif - --- | Desugar a @RuleBndr@. -dsRuleBndr :: DsMonad q => RuleBndr -> q DRuleBndr -dsRuleBndr (RuleVar n) = return $ DRuleVar n -dsRuleBndr (TypedRuleVar n ty) = DTypedRuleVar n <$> dsType ty - -#if __GLASGOW_HASKELL__ >= 807 --- | Desugar a @TySynEqn@. (Available only with GHC 7.8+) --- --- This requires a 'Name' as an argument since 'TySynEqn's did not have --- this information prior to GHC 8.8. -dsTySynEqn :: DsMonad q => Name -> TySynEqn -> q DTySynEqn -dsTySynEqn _ (TySynEqn mtvbs lhs rhs) = - DTySynEqn <$> mapM (mapM dsTvbUnit) mtvbs <*> dsType lhs <*> dsType rhs -#else --- | Desugar a @TySynEqn@. (Available only with GHC 7.8+) -dsTySynEqn :: DsMonad q => Name -> TySynEqn -> q DTySynEqn -dsTySynEqn n (TySynEqn lhss rhs) = do - lhss' <- mapM dsType lhss - let lhs' = applyDType (DConT n) $ map DTANormal lhss' - DTySynEqn Nothing lhs' <$> dsType rhs -#endif - --- | Desugar clauses to a function definition -dsClauses :: DsMonad q - => MatchContext -- ^ The context in which the clauses arise - -> [Clause] -- ^ Clauses to desugar - -> q [DClause] -dsClauses _ [] = return [] -dsClauses mc (Clause pats (NormalB exp) where_decs : rest) = do - -- this case is necessary to maintain the roundtrip property. - rest' <- dsClauses mc rest - exp' <- dsExp exp - (where_decs', ip_binder) <- dsLetDecs where_decs - let exp_with_wheres = maybeDLetE where_decs' (ip_binder exp') - (pats', exp'') <- dsPatsOverExp pats exp_with_wheres - return $ DClause pats' exp'' : rest' -dsClauses mc clauses@(Clause outer_pats _ _ : _) = do - arg_names <- replicateM (length outer_pats) (newUniqueName "arg") - let scrutinee = mkUnboxedTupleDExp (map DVarE arg_names) - clause <- DClause (map DVarP arg_names) <$> - (DCaseE scrutinee <$> foldrM (clause_to_dmatch scrutinee) [] clauses) - return [clause] - where - clause_to_dmatch :: DsMonad q => DExp -> Clause -> [DMatch] -> q [DMatch] - clause_to_dmatch scrutinee (Clause pats body where_decs) failure_matches = do - let failure_exp = maybeDCaseE mc scrutinee failure_matches - exp <- dsBody body where_decs failure_exp - (pats', exp') <- dsPatsOverExp pats exp - uni_pats <- fmap getAll $ concatMapM (fmap All . isUniversalPattern) pats' - let match = DMatch (mkUnboxedTupleDPat pats') exp' - if uni_pats - then return [match] - else return (match : failure_matches) - --- | The context of a pattern match. This is used to produce --- @Non-exhaustive patterns in...@ messages that are tailored to specific --- situations. Compare this to GHC's @HsMatchContext@ data type --- (https://gitlab.haskell.org/ghc/ghc/-/blob/81cf52bb301592ff3d043d03eb9a0d547891a3e1/compiler/Language/Haskell/Syntax/Expr.hs#L1662-1695), --- from which the @MatchContext@ data type takes inspiration. -data MatchContext - = FunRhs Name - -- ^ A pattern matching on an argument of a function binding - | LetDecRhs Pat - -- ^ A pattern in a @let@ declaration - | RecUpd - -- ^ A record update - | MultiWayIfAlt - -- ^ Guards in a multi-way if alternative - | CaseAlt - -- ^ Patterns and guards in a case alternative - --- | Construct an expression that throws an error when encountering a pattern --- at runtime that is not covered by pattern matching. -mkErrorMatchExpr :: MatchContext -> DExp -mkErrorMatchExpr mc = - DAppE (DVarE 'error) (DLitE (StringL ("Non-exhaustive patterns in " ++ pp_context))) - where - pp_context = - case mc of - FunRhs n -> show n - LetDecRhs pat -> pprint pat - RecUpd -> "record update" - MultiWayIfAlt -> "multi-way if" - CaseAlt -> "case" - --- | Desugar a type -dsType :: DsMonad q => Type -> q DType -#if __GLASGOW_HASKELL__ >= 900 --- See Note [Gracefully handling linear types] -dsType (MulArrowT `AppT` _) = return DArrowT -dsType MulArrowT = fail "Cannot desugar exotic uses of linear types." -#endif -dsType (ForallT tvbs preds ty) = - mkDForallConstrainedT <$> (DForallInvis <$> mapM dsTvbSpec tvbs) - <*> dsCxt preds <*> dsType ty -dsType (AppT t1 t2) = DAppT <$> dsType t1 <*> dsType t2 -dsType (SigT ty ki) = DSigT <$> dsType ty <*> dsType ki -dsType (VarT name) = return $ DVarT name -dsType (ConT name) = return $ DConT name --- The PromotedT case is identical to the ConT case above. --- See Note [Desugaring promoted types]. -dsType (PromotedT name) = return $ DConT name -dsType (TupleT n) = return $ DConT (tupleTypeName n) -dsType (UnboxedTupleT n) = return $ DConT (unboxedTupleTypeName n) -dsType ArrowT = return DArrowT -dsType ListT = return $ DConT ''[] -dsType (PromotedTupleT n) = return $ DConT (tupleDataName n) -dsType PromotedNilT = return $ DConT '[] -dsType PromotedConsT = return $ DConT '(:) -dsType StarT = return $ DConT typeKindName -dsType ConstraintT = return $ DConT ''Constraint -dsType (LitT lit) = return $ DLitT lit -dsType EqualityT = return $ DConT ''(~) -dsType (InfixT t1 n t2) = dsInfixT t1 n t2 -dsType (UInfixT{}) = dsUInfixT -dsType (ParensT t) = dsType t -dsType WildCardT = return DWildCardT -#if __GLASGOW_HASKELL__ >= 801 -dsType (UnboxedSumT arity) = return $ DConT (unboxedSumTypeName arity) -#endif -#if __GLASGOW_HASKELL__ >= 807 -dsType (AppKindT t k) = DAppKindT <$> dsType t <*> dsType k -dsType (ImplicitParamT n t) = do - t' <- dsType t - return $ DConT ''IP `DAppT` DLitT (StrTyLit n) `DAppT` t' -#endif -#if __GLASGOW_HASKELL__ >= 809 -dsType (ForallVisT tvbs ty) = - DForallT <$> (DForallVis <$> mapM dsTvbUnit tvbs) <*> dsType ty -#endif -#if __GLASGOW_HASKELL__ >= 903 --- The PromotedInfixT case is identical to the InfixT case above. --- See Note [Desugaring promoted types]. -dsType (PromotedInfixT t1 n t2) = dsInfixT t1 n t2 -dsType PromotedUInfixT{} = dsUInfixT -#endif - -#if __GLASGOW_HASKELL__ >= 900 --- | Desugar a 'TyVarBndr'. -dsTvb :: DsMonad q => TyVarBndr_ flag -> q (DTyVarBndr flag) -dsTvb (PlainTV n flag) = return $ DPlainTV n flag -dsTvb (KindedTV n flag k) = DKindedTV n flag <$> dsType k -#else --- | Desugar a 'TyVarBndr' with a particular @flag@. -dsTvb :: DsMonad q => flag -> TyVarBndr -> q (DTyVarBndr flag) -dsTvb flag (PlainTV n) = return $ DPlainTV n flag -dsTvb flag (KindedTV n k) = DKindedTV n flag <$> dsType k -#endif - -{- -Note [Gracefully handling linear types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Per the README, th-desugar does not currently support linear types. -Unfortunately, we cannot simply reject all occurrences of -multiplicity-polymorphic function arrows (i.e., MulArrowT), as it is possible -for "non-linear" code to contain them when reified. For example, the type of a -Haskell98 data constructor such as `Just` will be reified as - - a #-> Maybe a - -In terms of the TH AST, that is: - - MulArrowT `AppT` PromotedConT 'One `AppT` VarT a `AppT` (ConT ''Maybe `AppT` VarT a) - -Therefore, in order to desugar these sorts of types, we have to do *something* -with MulArrowT. The approach that th-desugar takes is to pretend that all -multiplicity-polymorphic function arrows are actually ordinary function arrows -(->) when desugaring types. In other words, whenever th-desugar sees -(MulArrowT `AppT` m), for any particular value of `m`, it will turn it into -DArrowT. - -This approach is enough to gracefully handle most uses of MulArrowT, as TH -reification always generates MulArrowT applied to some particular multiplicity -(as of GHC 9.0, at least). It's conceivable that some wily user could manually -construct a TH AST containing MulArrowT in a different position, but since this -situation is rare, we simply throw an error in such cases. - -We adopt a similar stance in L.H.TH.Desugar.Reify when locally reifying the -types of data constructors: since th-desugar doesn't currently support linear -types, we pretend as if MulArrowT does not exist. As a result, the type of -`Just` would be locally reified as `a -> Maybe a`, not `a #-> Maybe a`. - -Note [Desugaring promoted types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -ConT and PromotedT both contain Names as a payload, the only difference being -that PromotedT is intended to refer exclusively to promoted data constructor -Names, while ConT can refer to both type and data constructor Names alike. - -When desugaring a PromotedT, we make the assumption that the TH quoting -mechanism produced the correct Name and wrap the name in a DConT. In other -words, we desugar ConT and PromotedT identically. This assumption about -PromotedT may not always be correct, however. Consider this example: - - data a :+: b = Inl a | Inr b - data Exp a = ... | Exp :+: Exp - -How should `PromotedT (mkName ":+:")` be desugared? Morally, it ought to be -desugared to a DConT that contains (:+:) the data constructor, not (:+:) the -type constructor. Deciding between the two is not always straightforward, -however. We could use the `lookupDataName` function to try and distinguish -between the two Names, but this may not necessarily work. This is because the -Name passed to `lookupDataName` could have its original module attached, which -may not be in scope. - -Long story short: we make things simple (albeit slightly wrong) by desugaring -ConT and PromotedT identically. We'll wait for someone to complain about the -wrongness of this approach before researching a more accurate solution. - -Note that the same considerations also apply to InfixT and PromotedInfixT, -which are also desugared identically. --} - --- | Desugar an infix 'Type'. -dsInfixT :: DsMonad q => Type -> Name -> Type -> q DType -dsInfixT t1 n t2 = DAppT <$> (DAppT (DConT n) <$> dsType t1) <*> dsType t2 - --- | We cannot desugar unresolved infix operators, so fail if we encounter one. -dsUInfixT :: Fail.MonadFail m => m a -dsUInfixT = fail "Cannot desugar unresolved infix operators." - --- | Desugar a 'TyVarBndrSpec'. -dsTvbSpec :: DsMonad q => TyVarBndrSpec -> q DTyVarBndrSpec -#if __GLASGOW_HASKELL__ >= 900 -dsTvbSpec = dsTvb -#else -dsTvbSpec = dsTvb SpecifiedSpec -#endif - --- | Desugar a 'TyVarBndrUnit'. -dsTvbUnit :: DsMonad q => TyVarBndrUnit -> q DTyVarBndrUnit -#if __GLASGOW_HASKELL__ >= 900 -dsTvbUnit = dsTvb -#else -dsTvbUnit = dsTvb () -#endif - --- | Desugar a @Cxt@ -dsCxt :: DsMonad q => Cxt -> q DCxt -dsCxt = concatMapM dsPred - -#if __GLASGOW_HASKELL__ >= 801 --- | A backwards-compatible type synonym for the thing representing a single --- derived class in a @deriving@ clause. (This is a @DerivClause@, @Pred@, or --- @Name@ depending on the GHC version.) -type DerivingClause = DerivClause - --- | Desugar a @DerivingClause@. -dsDerivClause :: DsMonad q => DerivingClause -> q DDerivClause -dsDerivClause (DerivClause mds cxt) = - DDerivClause <$> mapM dsDerivStrategy mds <*> dsCxt cxt -#else -type DerivingClause = Pred - -dsDerivClause :: DsMonad q => DerivingClause -> q DDerivClause -dsDerivClause p = DDerivClause Nothing <$> dsPred p -#endif - -#if __GLASGOW_HASKELL__ >= 801 --- | Desugar a @DerivStrategy@. -dsDerivStrategy :: DsMonad q => DerivStrategy -> q DDerivStrategy -dsDerivStrategy StockStrategy = pure DStockStrategy -dsDerivStrategy AnyclassStrategy = pure DAnyclassStrategy -dsDerivStrategy NewtypeStrategy = pure DNewtypeStrategy -#if __GLASGOW_HASKELL__ >= 805 -dsDerivStrategy (ViaStrategy ty) = DViaStrategy <$> dsType ty -#endif -#endif - -#if __GLASGOW_HASKELL__ >= 801 --- | Desugar a @PatSynDir@. (Available only with GHC 8.2+) -dsPatSynDir :: DsMonad q => Name -> PatSynDir -> q DPatSynDir -dsPatSynDir _ Unidir = pure DUnidir -dsPatSynDir _ ImplBidir = pure DImplBidir -dsPatSynDir n (ExplBidir clauses) = DExplBidir <$> dsClauses (FunRhs n) clauses -#endif - --- | Desugar a @Pred@, flattening any internal tuples -dsPred :: DsMonad q => Pred -> q DCxt -dsPred t - | Just ts <- splitTuple_maybe t - = concatMapM dsPred ts -dsPred (ForallT tvbs cxt p) = dsForallPred tvbs cxt p -dsPred (AppT t1 t2) = do - [p1] <- dsPred t1 -- tuples can't be applied! - (:[]) <$> DAppT p1 <$> dsType t2 -dsPred (SigT ty ki) = do - preds <- dsPred ty - case preds of - [p] -> (:[]) <$> DSigT p <$> dsType ki - other -> return other -- just drop the kind signature on a tuple. -dsPred (VarT n) = return [DVarT n] -dsPred (ConT n) = return [DConT n] -dsPred t@(PromotedT _) = - impossible $ "Promoted type seen as head of constraint: " ++ show t -dsPred (TupleT 0) = return [DConT (tupleTypeName 0)] -dsPred (TupleT _) = - impossible "Internal error in th-desugar in detecting tuple constraints." -dsPred t@(UnboxedTupleT _) = - impossible $ "Unboxed tuple seen as head of constraint: " ++ show t -dsPred ArrowT = impossible "Arrow seen as head of constraint." -dsPred ListT = impossible "List seen as head of constraint." -dsPred (PromotedTupleT _) = - impossible "Promoted tuple seen as head of constraint." -dsPred PromotedNilT = impossible "Promoted nil seen as head of constraint." -dsPred PromotedConsT = impossible "Promoted cons seen as head of constraint." -dsPred StarT = impossible "* seen as head of constraint." -dsPred ConstraintT = - impossible "The kind `Constraint' seen as head of constraint." -dsPred t@(LitT _) = - impossible $ "Type literal seen as head of constraint: " ++ show t -dsPred EqualityT = return [DConT ''(~)] -dsPred (InfixT t1 n t2) = (:[]) <$> dsInfixT t1 n t2 -dsPred (UInfixT{}) = dsUInfixT -dsPred (ParensT t) = dsPred t -dsPred WildCardT = return [DWildCardT] -#if __GLASGOW_HASKELL__ >= 801 -dsPred t@(UnboxedSumT {}) = - impossible $ "Unboxed sum seen as head of constraint: " ++ show t -#endif -#if __GLASGOW_HASKELL__ >= 807 -dsPred (AppKindT t k) = do - [p] <- dsPred t - (:[]) <$> (DAppKindT p <$> dsType k) -dsPred (ImplicitParamT n t) = do - t' <- dsType t - return [DConT ''IP `DAppT` DLitT (StrTyLit n) `DAppT` t'] -#endif -#if __GLASGOW_HASKELL__ >= 809 -dsPred t@(ForallVisT {}) = - impossible $ "Visible dependent quantifier seen as head of constraint: " ++ show t -#endif -#if __GLASGOW_HASKELL__ >= 900 -dsPred MulArrowT = impossible "Linear arrow seen as head of constraint." -#endif -#if __GLASGOW_HASKELL__ >= 903 -dsPred t@PromotedInfixT{} = - impossible $ "Promoted infix type seen as head of constraint: " ++ show t -dsPred PromotedUInfixT{} = dsUInfixT -#endif - --- | Desugar a quantified constraint. -dsForallPred :: DsMonad q => [TyVarBndrSpec] -> Cxt -> Pred -> q DCxt -dsForallPred tvbs cxt p = do - ps' <- dsPred p - case ps' of - [p'] -> (:[]) <$> (mkDForallConstrainedT <$> - (DForallInvis <$> mapM dsTvbSpec tvbs) <*> dsCxt cxt <*> pure p') - _ -> fail "Cannot desugar constraint tuples in the body of a quantified constraint" - -- See GHC #15334. - --- | Like 'reify', but safer and desugared. Uses local declarations where --- available. -dsReify :: DsMonad q => Name -> q (Maybe DInfo) -dsReify = traverse dsInfo <=< reifyWithLocals_maybe - --- | Like 'reifyType', but safer and desugared. Uses local declarations where --- available. -dsReifyType :: DsMonad q => Name -> q (Maybe DType) -dsReifyType = traverse dsType <=< reifyTypeWithLocals_maybe - --- Given a list of `forall`ed type variable binders and a context, construct --- a DType using DForallT and DConstrainedT as appropriate. The phrase --- "as appropriate" is used because DConstrainedT will not be used if the --- context is empty, per Note [Desugaring and sweetening ForallT]. -mkDForallConstrainedT :: DForallTelescope -> DCxt -> DType -> DType -mkDForallConstrainedT tele ctxt ty = - DForallT tele $ if null ctxt then ty else DConstrainedT ctxt ty - --- create a list of expressions in the same order as the fields in the first argument --- but with the values as given in the second argument --- if a field is missing from the second argument, use the corresponding expression --- from the third argument -reorderFields :: DsMonad q => Name -> [VarStrictType] -> [FieldExp] -> [DExp] -> q [DExp] -reorderFields = reorderFields' dsExp - -reorderFieldsPat :: DsMonad q => Name -> [VarStrictType] -> [FieldPat] -> PatM q [DPat] -reorderFieldsPat con_name field_decs field_pats = - reorderFields' dsPat con_name field_decs field_pats (repeat DWildP) - -reorderFields' :: (Applicative m, Fail.MonadFail m) - => (a -> m da) - -> Name -- ^ The name of the constructor (used for error reporting) - -> [VarStrictType] -> [(Name, a)] - -> [da] -> m [da] -reorderFields' ds_thing con_name field_names_types field_things deflts = - check_valid_fields >> reorder field_names deflts - where - field_names = map (\(a, _, _) -> a) field_names_types - - check_valid_fields = - forM_ field_things $ \(thing_name, _) -> - unless (thing_name `elem` field_names) $ - fail $ "Constructor ‘" ++ nameBase con_name ++ "‘ does not have field ‘" - ++ nameBase thing_name ++ "‘" - - reorder [] _ = return [] - reorder (field_name : rest) (deflt : rest_deflt) = do - rest' <- reorder rest rest_deflt - case find (\(thing_name, _) -> thing_name == field_name) field_things of - Just (_, thing) -> (: rest') <$> ds_thing thing - Nothing -> return $ deflt : rest' - reorder (_ : _) [] = error "Internal error in th-desugar." - --- mkTupleDExp, mkUnboxedTupleDExp, and friends construct tuples, avoiding the --- use of 1-tuples. These are used to create auxiliary tuple values when --- desugaring pattern-matching constructs to simpler forms. --- See Note [Auxiliary tuples in pattern matching]. - --- | Make a tuple 'DExp' from a list of 'DExp's. Avoids using a 1-tuple. -mkTupleDExp :: [DExp] -> DExp -mkTupleDExp [exp] = exp -mkTupleDExp exps = foldl DAppE (DConE $ tupleDataName (length exps)) exps - --- | Make an unboxed tuple 'DExp' from a list of 'DExp's. Avoids using a 1-tuple. -mkUnboxedTupleDExp :: [DExp] -> DExp -mkUnboxedTupleDExp [exp] = exp -mkUnboxedTupleDExp exps = foldl DAppE (DConE $ unboxedTupleDataName (length exps)) exps - --- | Make a tuple 'Exp' from a list of 'Exp's. Avoids using a 1-tuple. -mkTupleExp :: [Exp] -> Exp -mkTupleExp [exp] = exp -mkTupleExp exps = foldl AppE (ConE $ tupleDataName (length exps)) exps - --- | Make an unboxed tuple 'Exp' from a list of 'Exp's. Avoids using a 1-tuple. -mkUnboxedTupleExp :: [Exp] -> Exp -mkUnboxedTupleExp [exp] = exp -mkUnboxedTupleExp exps = foldl AppE (ConE $ unboxedTupleDataName (length exps)) exps - --- | Make a tuple 'DPat' from a list of 'DPat's. Avoids using a 1-tuple. -mkTupleDPat :: [DPat] -> DPat -mkTupleDPat [pat] = pat -mkTupleDPat pats = DConP (tupleDataName (length pats)) [] pats - --- | Make an unboxed tuple 'DPat' from a list of 'DPat's. Avoids using a 1-tuple. -mkUnboxedTupleDPat :: [DPat] -> DPat -mkUnboxedTupleDPat [pat] = pat -mkUnboxedTupleDPat pats = DConP (unboxedTupleDataName (length pats)) [] pats - --- | Is this pattern guaranteed to match? -isUniversalPattern :: DsMonad q => DPat -> q Bool -isUniversalPattern (DLitP {}) = return False -isUniversalPattern (DVarP {}) = return True -isUniversalPattern (DConP con_name _ pats) = do - data_name <- dataConNameToDataName con_name - (_tvbs, cons) <- getDataD "Internal error." data_name - if length cons == 1 - then fmap and $ mapM isUniversalPattern pats - else return False -isUniversalPattern (DTildeP {}) = return True -isUniversalPattern (DBangP pat) = isUniversalPattern pat -isUniversalPattern (DSigP pat _) = isUniversalPattern pat -isUniversalPattern DWildP = return True - --- | Apply one 'DExp' to a list of arguments -applyDExp :: DExp -> [DExp] -> DExp -applyDExp = foldl DAppE - --- | Apply one 'DType' to a list of arguments -applyDType :: DType -> [DTypeArg] -> DType -applyDType = foldl apply - where - apply :: DType -> DTypeArg -> DType - apply f (DTANormal x) = f `DAppT` x - apply f (DTyArg x) = f `DAppKindT` x - --- | An argument to a type, either a normal type ('DTANormal') or a visible --- kind application ('DTyArg'). --- --- 'DTypeArg' does not appear directly in the @th-desugar@ AST, but it is --- useful when decomposing an application of a 'DType' to its arguments. -data DTypeArg - = DTANormal DType - | DTyArg DKind - deriving (Eq, Show, Data, Generic) - --- | Desugar a 'TypeArg'. -dsTypeArg :: DsMonad q => TypeArg -> q DTypeArg -dsTypeArg (TANormal t) = DTANormal <$> dsType t -dsTypeArg (TyArg k) = DTyArg <$> dsType k - --- | Filter the normal type arguments from a list of 'DTypeArg's. -filterDTANormals :: [DTypeArg] -> [DType] -filterDTANormals = mapMaybe getDTANormal - where - getDTANormal :: DTypeArg -> Maybe DType - getDTANormal (DTANormal t) = Just t - getDTANormal (DTyArg {}) = Nothing - --- | Convert a 'DTyVarBndr' into a 'DType' -dTyVarBndrToDType :: DTyVarBndr flag -> DType -dTyVarBndrToDType (DPlainTV a _) = DVarT a -dTyVarBndrToDType (DKindedTV a _ k) = DVarT a `DSigT` k - --- | Extract the underlying 'DType' or 'DKind' from a 'DTypeArg'. This forgets --- information about whether a type is a normal argument or not, so use with --- caution. -probablyWrongUnDTypeArg :: DTypeArg -> DType -probablyWrongUnDTypeArg (DTANormal t) = t -probablyWrongUnDTypeArg (DTyArg k) = k - --- Take a data type name (which does not belong to a data family) and --- apply it to its type variable binders to form a DType. -nonFamilyDataReturnType :: Name -> [DTyVarBndrUnit] -> DType -nonFamilyDataReturnType con_name = - applyDType (DConT con_name) . map (DTANormal . dTyVarBndrToDType) - --- Take a data family name and apply it to its argument types to form a --- data family instance DType. -dataFamInstReturnType :: Name -> [DTypeArg] -> DType -dataFamInstReturnType fam_name = applyDType (DConT fam_name) - --- Data family instance declarations did not come equipped with a list of bound --- type variables until GHC 8.8 (and even then, it's optional whether the user --- provides them or not). This means that there are situations where we must --- reverse engineer this information ourselves from the list of type --- arguments. We accomplish this by taking the free variables of the types --- and performing a reverse topological sort on them to ensure that the --- returned list is well scoped. -dataFamInstTvbs :: [DTypeArg] -> [DTyVarBndrUnit] -dataFamInstTvbs = toposortTyVarsOf . map probablyWrongUnDTypeArg - --- | Take a list of 'DType's, find their free variables, and sort them in --- reverse topological order to ensure that they are well scoped. In other --- words, the free variables are ordered such that: --- --- 1. Whenever an explicit kind signature of the form @(A :: K)@ is --- encountered, the free variables of @K@ will always appear to the left of --- the free variables of @A@ in the returned result. --- --- 2. The constraint in (1) notwithstanding, free variables will appear in --- left-to-right order of their original appearance. --- --- On older GHCs, this takes measures to avoid returning explicitly bound --- kind variables, which was not possible before @TypeInType@. -toposortTyVarsOf :: [DType] -> [DTyVarBndrUnit] -toposortTyVarsOf tys = - let freeVars :: [Name] - freeVars = F.toList $ foldMap fvDType tys - - varKindSigs :: Map Name DKind - varKindSigs = foldMap go_ty tys - where - go_ty :: DType -> Map Name DKind - go_ty (DForallT tele t) = go_tele tele (go_ty t) - go_ty (DConstrainedT ctxt t) = foldMap go_ty ctxt `mappend` go_ty t - go_ty (DAppT t1 t2) = go_ty t1 `mappend` go_ty t2 - go_ty (DAppKindT t k) = go_ty t `mappend` go_ty k - go_ty (DSigT t k) = - let kSigs = go_ty k - in case t of - DVarT n -> M.insert n k kSigs - _ -> go_ty t `mappend` kSigs - go_ty (DVarT {}) = mempty - go_ty (DConT {}) = mempty - go_ty DArrowT = mempty - go_ty (DLitT {}) = mempty - go_ty DWildCardT = mempty - - go_tele :: DForallTelescope -> Map Name DKind -> Map Name DKind - go_tele (DForallVis tvbs) = go_tvbs tvbs - go_tele (DForallInvis tvbs) = go_tvbs tvbs - - go_tvbs :: [DTyVarBndr flag] -> Map Name DKind -> Map Name DKind - go_tvbs tvbs m = foldr go_tvb m tvbs - - go_tvb :: DTyVarBndr flag -> Map Name DKind -> Map Name DKind - go_tvb (DPlainTV n _) m = M.delete n m - go_tvb (DKindedTV n _ k) m = M.delete n m `mappend` go_ty k - - -- | Do a topological sort on a list of tyvars, - -- so that binders occur before occurrences - -- E.g. given [ a::k, k::*, b::k ] - -- it'll return a well-scoped list [ k::*, a::k, b::k ] - -- - -- This is a deterministic sorting operation - -- (that is, doesn't depend on Uniques). - -- - -- It is also meant to be stable: that is, variables should not - -- be reordered unnecessarily. - scopedSort :: [Name] -> [Name] - scopedSort = go [] [] - - go :: [Name] -- already sorted, in reverse order - -> [Set Name] -- each set contains all the variables which must be placed - -- before the tv corresponding to the set; they are accumulations - -- of the fvs in the sorted tvs' kinds - - -- This list is in 1-to-1 correspondence with the sorted tyvars - -- INVARIANT: - -- all (\tl -> all (`isSubsetOf` head tl) (tail tl)) (tails fv_list) - -- That is, each set in the list is a superset of all later sets. - -> [Name] -- yet to be sorted - -> [Name] - go acc _fv_list [] = reverse acc - go acc fv_list (tv:tvs) - = go acc' fv_list' tvs - where - (acc', fv_list') = insert tv acc fv_list - - insert :: Name -- var to insert - -> [Name] -- sorted list, in reverse order - -> [Set Name] -- list of fvs, as above - -> ([Name], [Set Name]) -- augmented lists - insert tv [] [] = ([tv], [kindFVSet tv]) - insert tv (a:as) (fvs:fvss) - | tv `S.member` fvs - , (as', fvss') <- insert tv as fvss - = (a:as', fvs `S.union` fv_tv : fvss') - - | otherwise - = (tv:a:as, fvs `S.union` fv_tv : fvs : fvss) - where - fv_tv = kindFVSet tv - - -- lists not in correspondence - insert _ _ _ = error "scopedSort" - - kindFVSet n = - maybe S.empty (OS.toSet . fvDType) - (M.lookup n varKindSigs) - ascribeWithKind n = - maybe (DPlainTV n ()) (DKindedTV n ()) (M.lookup n varKindSigs) - - in map ascribeWithKind $ - scopedSort freeVars - -dtvbName :: DTyVarBndr flag -> Name -dtvbName (DPlainTV n _) = n -dtvbName (DKindedTV n _ _) = n - --- @mk_qual_do_name mb_mod orig_name@ will simply return @orig_name@ if --- @mb_mod@ is Nothing. If @mb_mod@ is @Just mod_@, then a new 'Name' will be --- returned that uses @mod_@ as the new module prefix. This is useful for --- emulating the behavior of the @QualifiedDo@ extension, which adds module --- prefixes to functions such as ('>>=') and ('>>'). -mk_qual_do_name :: Maybe ModName -> Name -> Name -mk_qual_do_name mb_mod orig_name = case mb_mod of - Nothing -> orig_name - Just mod_ -> Name (OccName (nameBase orig_name)) (NameQ mod_) - --- | Reconstruct an arrow 'DType' from its argument and result types. -ravelDType :: DFunArgs -> DType -> DType -ravelDType DFANil res = res -ravelDType (DFAForalls tele args) res = DForallT tele (ravelDType args res) -ravelDType (DFACxt cxt args) res = DConstrainedT cxt (ravelDType args res) -ravelDType (DFAAnon t args) res = DAppT (DAppT DArrowT t) (ravelDType args res) - --- | Decompose a function 'DType' into its arguments (the 'DFunArgs') and its --- result type (the 'DType). -unravelDType :: DType -> (DFunArgs, DType) -unravelDType (DForallT tele ty) = - let (args, res) = unravelDType ty in - (DFAForalls tele args, res) -unravelDType (DConstrainedT cxt ty) = - let (args, res) = unravelDType ty in - (DFACxt cxt args, res) -unravelDType (DAppT (DAppT DArrowT t1) t2) = - let (args, res) = unravelDType t2 in - (DFAAnon t1 args, res) -unravelDType t = (DFANil, t) - --- | The list of arguments in a function 'DType'. -data DFunArgs - = DFANil - -- ^ No more arguments. - | DFAForalls DForallTelescope DFunArgs - -- ^ A series of @forall@ed type variables followed by a dot (if - -- 'ForallInvis') or an arrow (if 'ForallVis'). For example, - -- the type variables @a1 ... an@ in @forall a1 ... an. r@. - | DFACxt DCxt DFunArgs - -- ^ A series of constraint arguments followed by @=>@. For example, - -- the @(c1, ..., cn)@ in @(c1, ..., cn) => r@. - | DFAAnon DType DFunArgs - -- ^ An anonymous argument followed by an arrow. For example, the @a@ - -- in @a -> r@. - deriving (Eq, Show, Data, Generic) - --- | A /visible/ function argument type (i.e., one that must be supplied --- explicitly in the source code). This is in contrast to /invisible/ --- arguments (e.g., the @c@ in @c => r@), which are instantiated without --- the need for explicit user input. -data DVisFunArg - = DVisFADep DTyVarBndrUnit - -- ^ A visible @forall@ (e.g., @forall a -> a@). - | DVisFAAnon DType - -- ^ An anonymous argument followed by an arrow (e.g., @a -> r@). - deriving (Eq, Show, Data, Generic) - --- | Filter the visible function arguments from a list of 'DFunArgs'. -filterDVisFunArgs :: DFunArgs -> [DVisFunArg] -filterDVisFunArgs DFANil = [] -filterDVisFunArgs (DFAForalls tele args) = - case tele of - DForallVis tvbs -> map DVisFADep tvbs ++ args' - DForallInvis _ -> args' - where - args' = filterDVisFunArgs args -filterDVisFunArgs (DFACxt _ args) = - filterDVisFunArgs args -filterDVisFunArgs (DFAAnon t args) = - DVisFAAnon t:filterDVisFunArgs args - --- | Decompose an applied type into its individual components. For example, this: --- --- @ --- Proxy \@Type Char --- @ --- --- would be unfolded to this: --- --- @ --- ('DConT' ''Proxy, ['DTyArg' ('DConT' ''Type), 'DTANormal' ('DConT' ''Char)]) --- @ -unfoldDType :: DType -> (DType, [DTypeArg]) -unfoldDType = go [] - where - go :: [DTypeArg] -> DType -> (DType, [DTypeArg]) - go acc (DForallT _ ty) = go acc ty - go acc (DAppT ty1 ty2) = go (DTANormal ty2:acc) ty1 - go acc (DAppKindT ty ki) = go (DTyArg ki:acc) ty - go acc (DSigT ty _) = go acc ty - go acc ty = (ty, acc) - --- | Extract the kind from a 'DTyVarBndr', if one is present. -extractTvbKind :: DTyVarBndr flag -> Maybe DKind -extractTvbKind (DPlainTV _ _) = Nothing -extractTvbKind (DKindedTV _ _ k) = Just k - --- | Set the flag in a list of 'DTyVarBndr's. This is often useful in contexts --- where one needs to re-use a list of 'DTyVarBndr's from one flag setting to --- another flag setting. For example, in order to re-use the 'DTyVarBndr's bound --- by a 'DDataD' in a 'DForallT', one can do the following: --- --- @ --- case x of --- 'DDataD' _ _ _ tvbs _ _ _ -> --- 'DForallT' ('DForallInvis' ('changeDTVFlags' 'SpecifiedSpec' tvbs)) ... --- @ -changeDTVFlags :: newFlag -> [DTyVarBndr oldFlag] -> [DTyVarBndr newFlag] -changeDTVFlags new_flag = map (new_flag <$) - --- | Some functions in this module only use certain arguments on particular --- versions of GHC. Other versions of GHC (that don't make use of those --- arguments) might need to conjure up those arguments out of thin air at the --- functions' call sites, so this function serves as a placeholder to use in --- those situations. (In other words, this is a slightly more informative --- version of 'undefined'.) -unusedArgument :: a -unusedArgument = error "Unused" - -{- -Note [Desugaring and sweetening ForallT] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The ForallT constructor from template-haskell is tremendously awkward. Because -ForallT contains both a list of type variable binders and constraint arguments, -ForallT expressions can be ambiguous when one of these lists is empty. For -example, consider this expression with no constraints: - - ForallT [PlainTV a] [] (VarT a) - -What should this desugar to in th-desugar, which must maintain a clear -separation between type variable binders and constraints? There are two -possibilities: - -1. DForallT DForallInvis [DPlainTV a] (DVarT a) - (i.e., forall a. a) -2. DForallT DForallInvis [DPlainTV a] (DConstrainedT [] (DVarT a)) - (i.e., forall a. () => a) - -Template Haskell generally drops these empty lists when splicing Template -Haskell expressions, so we would like to do the same in th-desugar to mimic -TH's behavior as closely as possible. However, there are some situations where -dropping empty lists of `forall`ed type variable binders can change the -semantics of a program. For instance, contrast `foo :: forall. a -> a` (which -is an error) with `foo :: a -> a` (which is fine). Therefore, we try to -preserve empty `forall`s to the best of our ability. - -Here is an informal specification of how th-desugar should handle different sorts -of ambiguity. First, a specification for desugaring. -Let `tvbs` and `ctxt` be non-empty: - -* `ForallT tvbs [] ty` should desugar to `DForallT DForallInvis tvbs ty`. -* `ForallT [] ctxt ty` should desguar to `DForallT DForallInvis [] (DConstrainedT ctxt ty)`. -* `ForallT [] [] ty` should desugar to `DForallT DForallInvis [] ty`. -* For all other cases, just straightforwardly desugar - `ForallT tvbs ctxt ty` to `DForallT DForallInvis tvbs (DConstraintedT ctxt ty)`. - -For sweetening: - -* `DForallT DForallInvis tvbs (DConstrainedT ctxt ty)` should sweeten to `ForallT tvbs ctxt ty`. -* `DForallT DForallInvis [] (DConstrainedT ctxt ty)` should sweeten to `ForallT [] ctxt ty`. -* `DForallT DForallInvis tvbs (DConstrainedT [] ty)` should sweeten to `ForallT tvbs [] ty`. -* `DForallT DForallInvis [] (DConstrainedT [] ty)` should sweeten to `ForallT [] [] ty`. -* For all other cases, just straightforwardly sweeten - `DForallT DForallInvis tvbs ty` to `ForallT tvbs [] ty` and - `DConstrainedT ctxt ty` to `ForallT [] ctxt ty`. - -Note [Auxiliary tuples in pattern matching] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -th-desugar simplifies the overall treatment of pattern matching in two -notable ways: - -1. Lambda expressions only bind variables and do not directly perform pattern - matching. For example, this: - - \True False -> () - - Roughly desugars to: - - \x y -> case (x, y) of - (True, False) -> () - _ -> error "Non-exhaustive patterns" -2. th-desugar does not have guards, as guards are desugared into pattern - matches. For example, this: - - f x y | True <- x - , False <- y - = () - - Roughly desugars to: - - f x y = case (x, y) of - (True, False) -> () - _ -> error "Non-exhaustive patterns" - -In both of these examples, there are multiple expressions being matched on -simultaneously. When desugaring these examples to `case` expressions, we need a -construct that allows us to group these patterns together. Auxiliary tuples are -one way to accomplish this. - -While this use of tuples works well when the arguments have lifted types, such -as Bool, it doesn't work when the arguments have unlifted types, such as Int#. -Imagine desugaring this lambda expression, for instance: - - \27# 42# -> () - -The approach above would desugar this to: - - \x y -> case (x, y) of - (27#, 42#) -> () - _ -> error "Non-exhaustive patterns" - -This will not typecheck, however, as we are using _lifted_ tuples, which -require their arguments to have lifted types. If we want to support unlifted -types, we need a different approach. - -One idea that seems tempting at first is to create an auxiliary `let` -expression, e.g., - - \x y -> - let aux 27# 42# = () - in aux x y - -This avoids having to use lifted tuples, but it creates a new problem: type -inference. In the general case, auxiliary `let` expressions aren't enough to -handle GADT pattern matches, such as in this example: - - data T a where - MkT :: Int -> T Int - - g :: T a -> T a -> a - g = \(MkT x1) (MkT x2) -> x1 + x2 - -If you desugar `g` to use an auxiliary `let` expression: - - g :: T a -> T a -> a - g = \t1 t2 -> - let aux (MkT x1) (MkT x2) = x1 + x2 - in aux t1 t2 - -Then it will not typecheck. To make this work, you'd need to give `aux` a type -signature. Doing this in general is tantamount to performing type inference, -however, which is very challenging in a Template Haskell setting. - -Another approach, which is what th-desugar currently uses, is to use auxiliary -_unboxed_ tuples. This is identical to the previous tuple approach, but with -slightly different syntax: - - \x y -> case (# x, y #) of - (# 27#, 42# #) -> () - _ -> error "Non-exhaustive patterns" - -Unboxed tuples can handle lifted and unlifted arguments alike, so it is capable -of handling all the examples above. - -You might worry that this approach would require clients of th-desugar to -enable the UnboxedTuples extension in non-obvious places, but fortunately, this -is not the case. For one thing, all unboxed tuples produced by th-desugar would -be TH-generated, so we would bypass the need to enable UnboxedTuples to lex -unboxed tuple syntax. GHC's typechecker also imposes a requirement that -UnboxedTuples be enabled if a variable has an unboxed tuple type, but this -never happens in th-desugar by construction. It's possible that a future -version of GHC might be stricter about this, but it seems unlikely. - -There are a couple of exceptions to the general rule that auxiliary binders -should be unboxed: - -1. ParallelListComp is desugared using the `mzip` function, which returns a - lifted pair. As a result, the variables bound in a parallel list - comprehension must be lifted. This is a restriction which is inherited from - GHC itself—https://gitlab.haskell.org/ghc/ghc/-/merge_requests/7270. - -2. Match flattening desugars lazy patterns that bind multiple variables to code - that extracts fields from tuples. For instance, this: - - data Pair a b = MkPair a b - - f :: Pair a b -> Pair b a - f ~(MkPair x y) = MkPair y x - - Desugars to this (roughly) when match-flattened: - - f :: Pair a b -> Pair b a - f p = - let tuple = case p of - MkPair x y -> (x, y) - - x = case tuple of - (x, _) -> x - - y = case tuple of - (_, y) -> x - - in MkPair y x - - One could imagine using an unboxed tuple here instead, but since the - intermediate `tuple` value would have an unboxed tuple this, this would - require users of match flattening to enable UnboxedTuples. Fortunately, - using unboxed tuples here isn't necessary, as GHC doesn't support binding - variables with unlifted types in lazy patterns anyway. +import Language.Haskell.TH hiding (Extension(..), match, clause, cxt) +import Language.Haskell.TH.Datatype.TyVarBndr +import Language.Haskell.TH.Syntax hiding (Extension(..), lift) + +import Control.Monad hiding (forM_, mapM) +import qualified Control.Monad.Fail as Fail +import Control.Monad.Trans (MonadTrans(..)) +import Control.Monad.Writer (MonadWriter(..), WriterT(..)) +import Control.Monad.Zip +import Data.Data (Data) +import Data.Either (lefts) +import Data.Foldable as F hiding (concat, notElem) +import Data.Function (on) +import qualified Data.List as L +import qualified Data.Map as M +import Data.Map (Map) +import Data.Maybe (catMaybes, isJust, mapMaybe) +import Data.Monoid (All(..)) +import qualified Data.Set as S +import Data.Set (Set) +import Data.Traversable + +#if __GLASGOW_HASKELL__ >= 803 +import GHC.OverloadedLabels ( fromLabel ) +#endif + +#if __GLASGOW_HASKELL__ >= 807 +import GHC.Classes (IP(..)) +#else +import qualified Language.Haskell.TH as LangExt (Extension(..)) +#endif + +#if __GLASGOW_HASKELL__ >= 902 +import Data.List.NonEmpty (NonEmpty(..)) +import GHC.Records (HasField(..)) +#endif + +import GHC.Exts +import GHC.Generics (Generic) + +import Language.Haskell.TH.Desugar.AST +import Language.Haskell.TH.Desugar.FV +import qualified Language.Haskell.TH.Desugar.OSet as OS +import Language.Haskell.TH.Desugar.OSet (OSet) +import Language.Haskell.TH.Desugar.Util +import Language.Haskell.TH.Desugar.Reify +import Language.Haskell.TH.Desugar.Subst (DSubst, IgnoreKinds(..), matchTy) +import qualified Language.Haskell.TH.Desugar.Subst.Capturing as SC + +-- | Desugar an expression +dsExp :: DsMonad q => Exp -> q DExp +dsExp (VarE n) = return $ DVarE n +dsExp (ConE n) = return $ DConE n +dsExp (LitE lit) = return $ DLitE lit +dsExp (AppE e1 e2) = DAppE <$> dsExp e1 <*> dsExp e2 +dsExp (InfixE Nothing op Nothing) = dsExp op +dsExp (InfixE (Just lhs) op Nothing) = DAppE <$> (dsExp op) <*> (dsExp lhs) +dsExp (InfixE Nothing op (Just rhs)) = do + lhsName <- newUniqueName "lhs" + op' <- dsExp op + rhs' <- dsExp rhs + return $ dLamE [DVarP lhsName] (foldl DAppE op' [DVarE lhsName, rhs']) +dsExp (InfixE (Just lhs) op (Just rhs)) = + DAppE <$> (DAppE <$> dsExp op <*> dsExp lhs) <*> dsExp rhs +dsExp (UInfixE _ _ _) = + fail "Cannot desugar unresolved infix operators." +dsExp (ParensE exp) = dsExp exp +dsExp (LamE pats exp) = do + exp' <- dsExp exp + (pats', exp'') <- dsPatsOverExp pats exp' + return $ dLamE pats' exp'' +dsExp (LamCaseE matches) = do + matches' <- dsMatches (LamCaseAlt LamCase) matches + return $ dLamCaseE matches' +dsExp (TupE exps) = dsTup tupleDataName exps +dsExp (UnboxedTupE exps) = dsTup unboxedTupleDataName exps +dsExp (CondE e1 e2 e3) = + dsExp (CaseE e1 [mkBoolMatch 'True e2, mkBoolMatch 'False e3]) + where + mkBoolMatch :: Name -> Exp -> Match + mkBoolMatch boolDataCon rhs = + Match (ConP boolDataCon +#if __GLASGOW_HASKELL__ >= 901 + [] +#endif + []) (NormalB rhs) [] +dsExp (MultiIfE guarded_exps) = + let failure = mkErrorMatchExpr MultiWayIfAlt in + dsGuards guarded_exps failure +dsExp (LetE decs exp) = do + (decs', ip_binder) <- dsLetDecs decs + exp' <- dsExp exp + return $ DLetE decs' $ ip_binder exp' +dsExp (CaseE exp matches) = do + exp' <- dsExp exp + matches' <- dsMatches CaseAlt matches + return $ dCaseE exp' matches' +#if __GLASGOW_HASKELL__ >= 900 +dsExp (DoE mb_mod stmts) = dsDoStmts mb_mod stmts +#else +dsExp (DoE stmts) = dsDoStmts Nothing stmts +#endif +dsExp (CompE stmts) = dsComp stmts +dsExp (ArithSeqE (FromR exp)) = DAppE (DVarE 'enumFrom) <$> dsExp exp +dsExp (ArithSeqE (FromThenR exp1 exp2)) = + DAppE <$> (DAppE (DVarE 'enumFromThen) <$> dsExp exp1) <*> dsExp exp2 +dsExp (ArithSeqE (FromToR exp1 exp2)) = + DAppE <$> (DAppE (DVarE 'enumFromTo) <$> dsExp exp1) <*> dsExp exp2 +dsExp (ArithSeqE (FromThenToR e1 e2 e3)) = + DAppE <$> (DAppE <$> (DAppE (DVarE 'enumFromThenTo) <$> dsExp e1) <*> + dsExp e2) <*> + dsExp e3 +dsExp (ListE exps) = go exps + where go [] = return $ DConE '[] + go (h : t) = DAppE <$> (DAppE (DConE '(:)) <$> dsExp h) <*> go t +dsExp (SigE exp ty) = DSigE <$> dsExp exp <*> dsType ty +dsExp (RecConE con_name field_exps) = do + con <- dataConNameToCon con_name + reordered <- reorder con + return $ foldl DAppE (DConE con_name) reordered + where + reorder con = case con of + NormalC _name fields -> non_record fields + InfixC field1 _name field2 -> non_record [field1, field2] + RecC _name fields -> reorder_fields fields + ForallC _ _ c -> reorder c + GadtC _names fields _ret_ty -> non_record fields + RecGadtC _names fields _ret_ty -> reorder_fields fields + + reorder_fields fields = reorderFields con_name fields field_exps + (repeat $ DVarE 'undefined) + + non_record fields | null field_exps + -- Special case: record construction is allowed for any + -- constructor, regardless of whether the constructor + -- actually was declared with records, provided that no + -- records are given in the expression itself. (See #59). + -- + -- Con{} desugars down to Con undefined ... undefined. + = return $ replicate (length fields) $ DVarE 'undefined + + | otherwise = + impossible $ "Record syntax used with non-record constructor " + ++ (show con_name) ++ "." + +dsExp (RecUpdE exp field_exps) = do + -- here, we need to use one of the field names to find the tycon, somewhat dodgily + first_name <- case field_exps of + ((name, _) : _) -> return name + _ -> impossible "Record update with no fields listed." + info <- reifyWithLocals first_name + applied_type <- case info of + VarI _name ty _m_dec -> extract_first_arg ty + _ -> impossible "Record update with an invalid field name." + type_name <- extract_type_name applied_type + (_, _, cons) <- getDataD "This seems to be an error in GHC." type_name + let filtered_cons = filter_cons_with_names cons (map fst field_exps) + exp' <- dsExp exp + matches <- mapM con_to_dmatch filtered_cons + let all_matches + | length filtered_cons == length cons = matches + | otherwise = matches ++ [error_match] + return $ dCaseE exp' all_matches + where + extract_first_arg :: DsMonad q => Type -> q Type + extract_first_arg (AppT (AppT ArrowT arg) _) = return arg + extract_first_arg (ForallT _ _ t) = extract_first_arg t + extract_first_arg (SigT t _) = extract_first_arg t + extract_first_arg _ = impossible "Record selector not a function." + + extract_type_name :: DsMonad q => Type -> q Name + extract_type_name (AppT t1 _) = extract_type_name t1 + extract_type_name (SigT t _) = extract_type_name t + extract_type_name (ConT n) = return n + extract_type_name _ = impossible "Record selector domain not a datatype." + + filter_cons_with_names cons field_names = + filter has_names cons + where + args_contain_names args = + let con_field_names = map fst_of_3 args in + all (`elem` con_field_names) field_names + + has_names (RecC _con_name args) = + args_contain_names args + has_names (RecGadtC _con_name args _ret_ty) = + args_contain_names args + has_names (ForallC _ _ c) = has_names c + has_names _ = False + + rec_con_to_dmatch con_name args = do + let con_field_names = map fst_of_3 args + field_var_names <- mapM (newUniqueName . nameBase) con_field_names + DMatch (DConP con_name [] (map DVarP field_var_names)) <$> + (foldl DAppE (DConE con_name) <$> + (reorderFields con_name args field_exps (map DVarE field_var_names))) + + con_to_dmatch :: DsMonad q => Con -> q DMatch + con_to_dmatch (RecC con_name args) = rec_con_to_dmatch con_name args + -- We're assuming the GADT constructor has only one Name here, but since + -- this constructor was reified, this assumption should always hold true. + con_to_dmatch (RecGadtC [con_name] args _ret_ty) = rec_con_to_dmatch con_name args + con_to_dmatch (ForallC _ _ c) = con_to_dmatch c + con_to_dmatch _ = impossible "Internal error within th-desugar." + + error_match = DMatch DWildP (mkErrorMatchExpr RecUpd) + + fst_of_3 (x, _, _) = x +dsExp (StaticE exp) = DStaticE <$> dsExp exp +dsExp (UnboundVarE n) = return (DVarE n) +#if __GLASGOW_HASKELL__ >= 801 +dsExp (AppTypeE exp ty) = DAppTypeE <$> dsExp exp <*> dsType ty +dsExp (UnboxedSumE exp alt arity) = + DAppE (DConE $ unboxedSumDataName alt arity) <$> dsExp exp +#endif +#if __GLASGOW_HASKELL__ >= 803 +dsExp (LabelE str) = return $ DVarE 'fromLabel `DAppTypeE` DLitT (StrTyLit str) +#endif +#if __GLASGOW_HASKELL__ >= 807 +dsExp (ImplicitParamVarE n) = return $ DVarE 'ip `DAppTypeE` DLitT (StrTyLit n) +dsExp (MDoE {}) = fail "th-desugar currently does not support RecursiveDo" +#endif +#if __GLASGOW_HASKELL__ >= 902 +dsExp (GetFieldE arg field) = DAppE (mkGetFieldProj field) <$> dsExp arg +dsExp (ProjectionE fields) = + case fields of + f :| fs -> return $ foldl' comp (mkGetFieldProj f) fs + where + comp :: DExp -> String -> DExp + comp acc f = DVarE '(.) `DAppE` mkGetFieldProj f `DAppE` acc +#endif +#if __GLASGOW_HASKELL__ >= 903 +dsExp (LamCasesE clauses) = DLamCasesE <$> dsClauses (LamCaseAlt LamCases) clauses +#endif +#if __GLASGOW_HASKELL__ >= 907 +dsExp (TypedBracketE exp) = DTypedBracketE <$> dsExp exp +dsExp (TypedSpliceE exp) = DTypedSpliceE <$> dsExp exp +#endif +#if __GLASGOW_HASKELL__ >= 909 +dsExp (TypeE ty) = DTypeE <$> dsType ty +#endif +#if __GLASGOW_HASKELL__ >= 911 +dsExp (ForallE tvbs exp) = + DForallE <$> (DForallInvis <$> mapM dsTvbSpec tvbs) <*> dsExp exp +dsExp (ForallVisE tvbs exp) = + DForallE <$> (DForallVis <$> mapM dsTvbUnit tvbs) <*> dsExp exp +dsExp (ConstrainedE preds exp) = + DConstrainedE <$> mapM dsExp preds <*> dsExp exp +#endif + +#if __GLASGOW_HASKELL__ >= 809 +dsTup :: DsMonad q => (Int -> Name) -> [Maybe Exp] -> q DExp +dsTup = ds_tup +#else +dsTup :: DsMonad q => (Int -> Name) -> [Exp] -> q DExp +dsTup tuple_data_name = ds_tup tuple_data_name . map Just +#endif + +-- | Desugar a tuple (or tuple section) expression. +ds_tup :: forall q. DsMonad q + => (Int -> Name) -- ^ Compute the 'Name' of a tuple (boxed or unboxed) + -- data constructor from its arity. + -> [Maybe Exp] -- ^ The tuple's subexpressions. 'Nothing' entries + -- denote empty fields in a tuple section. + -> q DExp +ds_tup tuple_data_name mb_exps = do + section_exps <- mapM ds_section_exp mb_exps + let section_vars = lefts section_exps + tup_body = mk_tup_body section_exps + pure $ + if null section_vars + then tup_body -- If this isn't a tuple section, don't create a lambda. + else dLamE (map DVarP section_vars) tup_body + where + -- If dealing with an empty field in a tuple section (Nothing), create a + -- unique name and return Left. These names will be used to construct the + -- lambda expression that it desugars to. + -- (For example, `(,5)` desugars to `\ts -> (,) ts 5`.) + -- + -- If dealing with a tuple subexpression (Just), desugar it and return + -- Right. + ds_section_exp :: Maybe Exp -> q (Either Name DExp) + ds_section_exp = maybe (Left <$> qNewName "ts") (fmap Right . dsExp) + + mk_tup_body :: [Either Name DExp] -> DExp + mk_tup_body section_exps = + foldl' apply_tup_body (DConE $ tuple_data_name (length section_exps)) + section_exps + + apply_tup_body :: DExp -> Either Name DExp -> DExp + apply_tup_body f (Left n) = f `DAppE` DVarE n + apply_tup_body f (Right e) = f `DAppE` e + +-- | Construct a 'DExp' value that is equivalent to writing a lambda expression. +-- Under the hood, this uses @\\cases@ ('DLamCasesE'). +-- +-- @'mkDLamEFromDPats' pats exp@ is equivalent to writing +-- @pure ('dLamE' pats exp)@. As such, 'mkDLamEFromDPats' is deprecated in favor +-- of 'dLamE', and 'mkDLamEFromDPats' will be removed in a future @th-desugar@ +-- release. +mkDLamEFromDPats :: Quasi q => [DPat] -> DExp -> q DExp +mkDLamEFromDPats pats exp = pure $ dLamE pats exp +{-# DEPRECATED mkDLamEFromDPats "Use `dLamE` or `DLamCasesE` instead." #-} + +#if __GLASGOW_HASKELL__ >= 902 +mkGetFieldProj :: String -> DExp +mkGetFieldProj field = DVarE 'getField `DAppTypeE` DLitT (StrTyLit field) +#endif + +-- | Desugar a list of matches for a @case@ or @\\case@ expression. +dsMatches :: DsMonad q + => MatchContext -- ^ The context in which the matches arise + -> [Match] -- ^ Matches of the @case@ or @\\case@ expression + -> q [DMatch] +dsMatches _ [] = pure [] +-- Include a special case for guard-less matches to make the desugared output +-- a little nicer. See Note [Desugaring clauses compactly (when possible)]. +dsMatches mc (Match pat (NormalB exp) where_decs : rest) = do + rest' <- dsMatches mc rest + exp' <- dsExp exp + (where_decs', ip_binder) <- dsLetDecs where_decs + let exp_with_wheres = maybeDLetE where_decs' (ip_binder exp') + (pats', exp'') <- dsPatOverExp pat exp_with_wheres + pure $ DMatch pats' exp'' : rest' +dsMatches mc matches@(Match _ _ _ : _) = do + scrutinee_name <- newUniqueName "scrutinee" + let scrutinee = DVarE scrutinee_name + matches' <- foldrM (ds_match scrutinee) [] matches + pure [DMatch (DVarP scrutinee_name) (dCaseE scrutinee matches')] + where + ds_match :: DsMonad q => DExp -> Match -> [DMatch] -> q [DMatch] + ds_match scrutinee (Match pat body where_decs) failure_matches = do + let failure_exp = maybeDCaseE mc scrutinee failure_matches + exp <- dsBody body where_decs failure_exp + (pat', exp') <- dsPatOverExp pat exp + uni_pattern <- isUniversalPattern pat' -- incomplete attempt at #6 + let match = DMatch pat' exp' + if uni_pattern + then return [match] + else return (match : failure_matches) + +-- | Desugar a @Body@ +dsBody :: DsMonad q + => Body -- ^ body to desugar + -> [Dec] -- ^ "where" declarations + -> DExp -- ^ what to do if the guards don't match + -> q DExp +dsBody (NormalB exp) decs _ = do + (decs', ip_binder) <- dsLetDecs decs + exp' <- dsExp exp + return $ maybeDLetE decs' $ ip_binder exp' +dsBody (GuardedB guarded_exps) decs failure = do + (decs', ip_binder) <- dsLetDecs decs + guarded_exp' <- dsGuards guarded_exps failure + return $ maybeDLetE decs' $ ip_binder guarded_exp' + +-- | Construct a 'DExp' value that is equivalent to writing a @case@ expression +-- that scrutinizes multiple values at once. Under the hood, this uses +-- @\\cases@ ('DLamCasesE'). For instance, given this code: +-- +-- @ +-- case (scrut_1, ..., scrut_n) of +-- (pat_1_1, ..., pat_1_n) -> rhs_1 +-- ... +-- (pat_m_1, ..., pat_m_n) -> rhs_n +-- @ +-- +-- The following @\\cases@ expression will be created under the hood: +-- +-- @ +-- (\\cases +-- pat_1_1 ... pat_1_n -> rhs_1 +-- ... +-- pat_m_1 ... pat_m_n -> rhs_n) scrut_1 ... scrut_n +-- @ +-- +-- In other words, this creates a 'DLamCasesE' value and then applies it to +-- argument values. +-- +-- Preconditions: +-- +-- * If the list of 'DClause's is non-empty, then the number of patterns in each +-- 'DClause' must be equal to the number of 'DExp' arguments. +-- +-- * If the list of 'DClause's is empty, then there must be exactly one 'DExp' +-- argument. +dCasesE :: [DExp] -> [DClause] -> DExp +dCasesE scruts clauses = applyDExp (DLamCasesE clauses) scruts + +-- | If decs is non-empty, delcare them in a let: +maybeDLetE :: [DLetDec] -> DExp -> DExp +maybeDLetE [] exp = exp +maybeDLetE decs exp = DLetE decs exp + +-- | If matches is non-empty, make a case statement; otherwise make an error statement +maybeDCaseE :: MatchContext -> DExp -> [DMatch] -> DExp +maybeDCaseE mc _ [] = mkErrorMatchExpr mc +maybeDCaseE _ scrut matches = dCaseE scrut matches + +-- | If the list of clauses is non-empty, make a @\\cases@ expression and apply +-- it using the expressions as arguments. Otherwise, make an error statement. +-- +-- Precondition: if the list of 'DClause's is non-empty, then the number of +-- patterns in each 'DClause' must be equal to the number of 'DExp' arguments. +maybeDCasesE :: MatchContext -> [DExp] -> [DClause] -> DExp +maybeDCasesE mc _ [] = mkErrorMatchExpr mc +maybeDCasesE _ scruts clauses = dCasesE scruts clauses + +-- | Desugar guarded expressions +dsGuards :: DsMonad q + => [(Guard, Exp)] -- ^ Guarded expressions + -> DExp -- ^ What to do if none of the guards match + -> q DExp +dsGuards [] thing_inside = return thing_inside +dsGuards ((NormalG gd, exp) : rest) thing_inside = + dsGuards ((PatG [NoBindS gd], exp) : rest) thing_inside +dsGuards ((PatG stmts, exp) : rest) thing_inside = do + success <- dsExp exp + failure <- dsGuards rest thing_inside + dsGuardStmts stmts success failure + +-- | Desugar the @Stmt@s in a guard +dsGuardStmts :: DsMonad q + => [Stmt] -- ^ The @Stmt@s to desugar + -> DExp -- ^ What to do if the @Stmt@s yield success + -> DExp -- ^ What to do if the @Stmt@s yield failure + -> q DExp +dsGuardStmts [] success _failure = return success +dsGuardStmts (BindS pat exp : rest) success failure = do + success' <- dsGuardStmts rest success failure + (pat', success'') <- dsPatOverExp pat success' + exp' <- dsExp exp + return $ dCaseE exp' [DMatch pat' success'', DMatch DWildP failure] +dsGuardStmts (LetS decs : rest) success failure = do + (decs', ip_binder) <- dsLetDecs decs + success' <- dsGuardStmts rest success failure + return $ DLetE decs' $ ip_binder success' + -- special-case a final pattern containing "otherwise" or "True" + -- note that GHC does this special-casing, too, in DsGRHSs.isTrueLHsExpr +dsGuardStmts [NoBindS exp] success _failure + | VarE name <- exp + , name == 'otherwise + = return success + + | ConE name <- exp + , name == 'True + = return success +dsGuardStmts (NoBindS exp : rest) success failure = do + exp' <- dsExp exp + success' <- dsGuardStmts rest success failure + return $ dCaseE exp' [ DMatch (DConP 'True [] []) success' + , DMatch (DConP 'False [] []) failure ] +dsGuardStmts (ParS _ : _) _ _ = impossible "Parallel comprehension in a pattern guard." +#if __GLASGOW_HASKELL__ >= 807 +dsGuardStmts (RecS {} : _) _ _ = fail "th-desugar currently does not support RecursiveDo" +#endif + +-- | Desugar the @Stmt@s in a @do@ expression +dsDoStmts :: forall q. DsMonad q => Maybe ModName -> [Stmt] -> q DExp +dsDoStmts mb_mod = go + where + go :: [Stmt] -> q DExp + go [] = impossible "do-expression ended with something other than bare statement." + go [NoBindS exp] = dsExp exp + go (BindS pat exp : rest) = do + rest' <- go rest + dsBindS mb_mod exp pat rest' "do expression" + go (LetS decs : rest) = do + (decs', ip_binder) <- dsLetDecs decs + rest' <- go rest + return $ DLetE decs' $ ip_binder rest' + go (NoBindS exp : rest) = do + exp' <- dsExp exp + rest' <- go rest + let sequence_name = mk_qual_do_name mb_mod '(>>) + return $ DAppE (DAppE (DVarE sequence_name) exp') rest' + go (ParS _ : _) = impossible "Parallel comprehension in a do-statement." +#if __GLASGOW_HASKELL__ >= 807 + go (RecS {} : _) = fail "th-desugar currently does not support RecursiveDo" +#endif + +-- | Desugar the @Stmt@s in a list or monad comprehension +dsComp :: DsMonad q => [Stmt] -> q DExp +dsComp [] = impossible "List/monad comprehension ended with something other than a bare statement." +dsComp [NoBindS exp] = DAppE (DVarE 'return) <$> dsExp exp +dsComp (BindS pat exp : rest) = do + rest' <- dsComp rest + dsBindS Nothing exp pat rest' "monad comprehension" +dsComp (LetS decs : rest) = do + (decs', ip_binder) <- dsLetDecs decs + rest' <- dsComp rest + return $ DLetE decs' $ ip_binder rest' +dsComp (NoBindS exp : rest) = do + exp' <- dsExp exp + rest' <- dsComp rest + return $ DAppE (DAppE (DVarE '(>>)) (DAppE (DVarE 'guard) exp')) rest' +dsComp (ParS stmtss : rest) = do + (pat, exp) <- dsParComp stmtss + rest' <- dsComp rest + return $ DAppE (DAppE (DVarE '(>>=)) exp) (dLamE [pat] rest') +#if __GLASGOW_HASKELL__ >= 807 +dsComp (RecS {} : _) = fail "th-desugar currently does not support RecursiveDo" +#endif + +-- Desugar a binding statement in a do- or list comprehension. +-- +-- In the event that the pattern in the statement is partial, the desugared +-- case expression will contain a catch-all case that calls 'fail' from either +-- 'MonadFail' or 'Monad', depending on whether the @MonadFailDesugaring@ +-- language extension is enabled or not. (On GHCs older than 8.0, 'fail' from +-- 'Monad' is always used.) +dsBindS :: forall q. DsMonad q + => Maybe ModName -> Exp -> Pat -> DExp -> String -> q DExp +dsBindS mb_mod bind_arg_exp success_pat success_exp ctxt = do + bind_arg_exp' <- dsExp bind_arg_exp + (success_pat', success_exp') <- dsPatOverExp success_pat success_exp + is_univ_pat <- isUniversalPattern success_pat' -- incomplete attempt at #6 + let bind_into = DAppE (DAppE (DVarE bind_name) bind_arg_exp') + if is_univ_pat + then return $ bind_into $ dLamE [success_pat'] success_exp' + else do fail_name <- mk_fail_name + return $ bind_into $ DLamCasesE + [ DClause [success_pat'] success_exp' + , DClause [DWildP] $ + DVarE fail_name `DAppE` + DLitE (StringL $ "Pattern match failure in " ++ ctxt) + ] + where + bind_name = mk_qual_do_name mb_mod '(>>=) + + mk_fail_name :: q Name +#if __GLASGOW_HASKELL__ >= 807 + -- GHC 8.8 deprecates the MonadFailDesugaring extension since its effects + -- are always enabled. Furthermore, MonadFailDesugaring is no longer + -- enabled by default, so simply use MonadFail.fail. (That happens to + -- be the same as Prelude.fail in 8.8+.) + mk_fail_name = return fail_MonadFail_name +#else + mk_fail_name = do + mfd <- qIsExtEnabled LangExt.MonadFailDesugaring + return $ if mfd then fail_MonadFail_name else fail_Prelude_name +#endif + + fail_MonadFail_name = mk_qual_do_name mb_mod 'Fail.fail + +#if __GLASGOW_HASKELL__ < 807 + fail_Prelude_name = mk_qual_do_name mb_mod 'Prelude.fail +#endif + +-- | Desugar the contents of a parallel comprehension (enabled via the +-- @ParallelListComp@ language extension). For example, this expression: +-- +-- @ +-- [ x + y | x <- [1,2,3] | y <- [4,5,6] ] +-- @ +-- +-- Will be desugared to code that looks roughly like: +-- +-- @ +-- 'mzip' [1, 2, 3] [4, 5, 6] '>>=' \\cases (x, y) -> 'return' (x + y) +-- @ +-- +-- This function returns a 'DPat' containing a tuple of all bound variables and +-- a 'DExp' to produce the values for those variables. +dsParComp :: DsMonad q => [[Stmt]] -> q (DPat, DExp) +dsParComp [] = impossible "Empty list of parallel comprehension statements." +dsParComp [r] = do + let rv = foldMap extractBoundNamesStmt r + dsR <- dsComp (r ++ [mk_tuple_stmt rv]) + return (mk_tuple_dpat rv, dsR) +dsParComp (q : rest) = do + let qv = foldMap extractBoundNamesStmt q + (rest_pat, rest_exp) <- dsParComp rest + dsQ <- dsComp (q ++ [mk_tuple_stmt qv]) + let zipped = DAppE (DAppE (DVarE 'mzip) dsQ) rest_exp + return (DConP (tupleDataName 2) [] [mk_tuple_dpat qv, rest_pat], zipped) + +-- helper function for dsParComp +mk_tuple_stmt :: OSet Name -> Stmt +mk_tuple_stmt name_set = + NoBindS (mkTupleExp (F.foldr ((:) . VarE) [] name_set)) + +-- helper function for dsParComp +mk_tuple_dpat :: OSet Name -> DPat +mk_tuple_dpat name_set = + mkTupleDPat (F.foldr ((:) . DVarP) [] name_set) + +-- | Desugar a pattern, along with processing a (desugared) expression that +-- is the entire scope of the variables bound in the pattern. +dsPatOverExp :: DsMonad q => Pat -> DExp -> q (DPat, DExp) +dsPatOverExp pat exp = do + (pat', vars) <- runWriterT $ dsPat pat + let name_decs = map (uncurry (DValD . DVarP)) vars + return (pat', maybeDLetE name_decs exp) + +-- | Desugar multiple patterns. Like 'dsPatOverExp'. +dsPatsOverExp :: DsMonad q => [Pat] -> DExp -> q ([DPat], DExp) +dsPatsOverExp pats exp = do + (pats', vars) <- runWriterT $ mapM dsPat pats + let name_decs = map (uncurry (DValD . DVarP)) vars + return (pats', maybeDLetE name_decs exp) + +-- | Desugar a pattern, returning a list of (Name, DExp) pairs of extra +-- variables that must be bound within the scope of the pattern +dsPatX :: DsMonad q => Pat -> q (DPat, [(Name, DExp)]) +dsPatX = runWriterT . dsPat + +-- | Desugaring a pattern also returns the list of variables bound in as-patterns +-- and the values they should be bound to. This variables must be brought into +-- scope in the "body" of the pattern. +type PatM q = WriterT [(Name, DExp)] q + +-- | Desugar a pattern. +dsPat :: DsMonad q => Pat -> PatM q DPat +dsPat (LitP lit) = return $ DLitP lit +dsPat (VarP n) = return $ DVarP n +dsPat (TupP pats) = DConP (tupleDataName (length pats)) [] <$> mapM dsPat pats +dsPat (UnboxedTupP pats) = DConP (unboxedTupleDataName (length pats)) [] <$> + mapM dsPat pats +#if __GLASGOW_HASKELL__ >= 901 +dsPat (ConP name tys pats) = DConP name <$> mapM dsType tys <*> mapM dsPat pats +#else +dsPat (ConP name pats) = DConP name [] <$> mapM dsPat pats +#endif +dsPat (InfixP p1 name p2) = DConP name [] <$> mapM dsPat [p1, p2] +dsPat (UInfixP _ _ _) = + fail "Cannot desugar unresolved infix operators." +dsPat (ParensP pat) = dsPat pat +dsPat (TildeP pat) = DTildeP <$> dsPat pat +dsPat (BangP pat) = DBangP <$> dsPat pat +dsPat (AsP name pat) = do + pat' <- dsPat pat + pat'' <- lift $ removeWilds pat' + tell [(name, dPatToDExp pat'')] + return pat'' +dsPat WildP = return DWildP +dsPat (RecP con_name field_pats) = do + con <- lift $ dataConNameToCon con_name + reordered <- reorder con + return $ DConP con_name [] reordered + where + reorder con = case con of + NormalC _name fields -> non_record fields + InfixC field1 _name field2 -> non_record [field1, field2] + RecC _name fields -> reorder_fields_pat fields + ForallC _ _ c -> reorder c + GadtC _names fields _ret_ty -> non_record fields + RecGadtC _names fields _ret_ty -> reorder_fields_pat fields + + reorder_fields_pat fields = reorderFieldsPat con_name fields field_pats + + non_record fields | null field_pats + -- Special case: record patterns are allowed for any + -- constructor, regardless of whether the constructor + -- actually was declared with records, provided that + -- no records are given in the pattern itself. (See #59). + -- + -- Con{} desugars down to Con _ ... _. + = return $ replicate (length fields) DWildP + | otherwise = lift $ impossible + $ "Record syntax used with non-record constructor " + ++ (show con_name) ++ "." + +dsPat (ListP pats) = go pats + where go [] = return $ DConP '[] [] [] + go (h : t) = do + h' <- dsPat h + t' <- go t + return $ DConP '(:) [] [h', t'] +dsPat (SigP pat ty) = DSigP <$> dsPat pat <*> dsType ty +#if __GLASGOW_HASKELL__ >= 801 +dsPat (UnboxedSumP pat alt arity) = + DConP (unboxedSumDataName alt arity) [] <$> ((:[]) <$> dsPat pat) +#endif +#if __GLASGOW_HASKELL__ >= 909 +dsPat (TypeP ty) = DTypeP <$> dsType ty +dsPat (InvisP ty) = DInvisP <$> dsType ty +#endif +dsPat (ViewP _ _) = + fail "View patterns are not supported in th-desugar. Use pattern guards instead." +#if __GLASGOW_HASKELL__ >= 911 +dsPat (OrP _) = + fail "Or-patterns are not supported in th-desugar." +#endif + +-- | Convert a 'DPat' to a 'DExp'. Fails on 'DWildP' and 'DInvisP'. +dPatToDExp :: DPat -> DExp +dPatToDExp (DLitP lit) = DLitE lit +dPatToDExp (DVarP name) = DVarE name +dPatToDExp (DConP name tys pats) = foldl DAppE (foldl DAppTypeE (DConE name) tys) (map dPatToDExp pats) +dPatToDExp (DTildeP pat) = dPatToDExp pat +dPatToDExp (DBangP pat) = dPatToDExp pat +dPatToDExp (DSigP pat ty) = DSigE (dPatToDExp pat) ty +dPatToDExp (DTypeP ty) = DTypeE ty +dPatToDExp DWildP = error "Internal error in th-desugar: wildcard in rhs of as-pattern" +dPatToDExp (DInvisP {}) = error "Internal error in th-desugar: invisible type pattern in rhs of as-pattern" + +-- | Remove all wildcards from a pattern, replacing any wildcard with a fresh +-- variable +removeWilds :: DsMonad q => DPat -> q DPat +removeWilds p@(DLitP _) = return p +removeWilds p@(DVarP _) = return p +removeWilds (DConP con_name tys pats) = DConP con_name tys <$> mapM removeWilds pats +removeWilds (DTildeP pat) = DTildeP <$> removeWilds pat +removeWilds (DBangP pat) = DBangP <$> removeWilds pat +removeWilds (DSigP pat ty) = DSigP <$> removeWilds pat <*> pure ty +removeWilds (DTypeP ty) = pure $ DTypeP ty +removeWilds (DInvisP ty) = pure $ DInvisP ty +removeWilds DWildP = DVarP <$> newUniqueName "wild" + +-- | Desugar @Info@ +dsInfo :: DsMonad q => Info -> q DInfo +dsInfo (ClassI dec instances) = do + [ddec] <- dsDec dec + dinstances <- dsDecs instances + return $ DTyConI ddec (Just dinstances) +dsInfo (ClassOpI name ty parent) = + DVarI name <$> dsType ty <*> pure (Just parent) +dsInfo (TyConI dec) = do + [ddec] <- dsDec dec + return $ DTyConI ddec Nothing +dsInfo (FamilyI dec instances) = do + [ddec] <- dsDec dec + dinstances <- dsDecs instances + return $ DTyConI ddec (Just dinstances) +dsInfo (PrimTyConI name arity unlifted) = + return $ DPrimTyConI name arity unlifted +dsInfo (DataConI name ty parent) = + DVarI name <$> dsType ty <*> pure (Just parent) +dsInfo (VarI name ty Nothing) = + DVarI name <$> dsType ty <*> pure Nothing +dsInfo (VarI name _ (Just _)) = + impossible $ "Declaration supplied with variable: " ++ show name +dsInfo (TyVarI name ty) = DTyVarI name <$> dsType ty +#if __GLASGOW_HASKELL__ >= 801 +dsInfo (PatSynI name ty) = DPatSynI name <$> dsType ty +#endif + +-- | Desugar arbitrary @Dec@s +dsDecs :: DsMonad q => [Dec] -> q [DDec] +dsDecs = concatMapM dsDec + +-- | Desugar a single @Dec@, perhaps producing multiple 'DDec's +dsDec :: DsMonad q => Dec -> q [DDec] +dsDec d@(FunD {}) = dsTopLevelLetDec d +dsDec d@(ValD {}) = dsTopLevelLetDec d +dsDec (DataD cxt n tvbs mk cons derivings) = + dsDataDec Data cxt n tvbs mk cons derivings +dsDec (NewtypeD cxt n tvbs mk con derivings) = + dsDataDec Newtype cxt n tvbs mk [con] derivings +dsDec (TySynD n tvbs ty) = + (:[]) <$> (DTySynD n <$> mapM dsTvbVis tvbs <*> dsType ty) +dsDec (ClassD cxt n tvbs fds decs) = + (:[]) <$> (DClassD <$> dsCxt cxt <*> pure n <*> mapM dsTvbVis tvbs + <*> pure fds <*> dsDecs decs) +dsDec (InstanceD over cxt ty decs) = + (:[]) <$> (DInstanceD over Nothing <$> dsCxt cxt <*> dsType ty <*> dsDecs decs) +dsDec d@(SigD {}) = dsTopLevelLetDec d +dsDec (ForeignD f) = (:[]) <$> (DForeignD <$> dsForeign f) +dsDec d@(InfixD {}) = dsTopLevelLetDec d +dsDec d@(PragmaD {}) = dsTopLevelLetDec d +dsDec (OpenTypeFamilyD tfHead) = + (:[]) <$> (DOpenTypeFamilyD <$> dsTypeFamilyHead tfHead) +dsDec (DataFamilyD n tvbs m_k) = + (:[]) <$> (DDataFamilyD n <$> mapM dsTvbVis tvbs <*> mapM dsType m_k) +#if __GLASGOW_HASKELL__ >= 807 +dsDec (DataInstD cxt mtvbs lhs mk cons derivings) = + case unfoldType lhs of + (ConT n, tys) -> dsDataInstDec Data cxt n mtvbs tys mk cons derivings + (_, _) -> fail $ "Unexpected data instance LHS: " ++ pprint lhs +dsDec (NewtypeInstD cxt mtvbs lhs mk con derivings) = + case unfoldType lhs of + (ConT n, tys) -> dsDataInstDec Newtype cxt n mtvbs tys mk [con] derivings + (_, _) -> fail $ "Unexpected newtype instance LHS: " ++ pprint lhs +#else +dsDec (DataInstD cxt n tys mk cons derivings) = + dsDataInstDec Data cxt n Nothing (map TANormal tys) mk cons derivings +dsDec (NewtypeInstD cxt n tys mk con derivings) = + dsDataInstDec Newtype cxt n Nothing (map TANormal tys) mk [con] derivings +#endif +#if __GLASGOW_HASKELL__ >= 807 +dsDec (TySynInstD eqn) = (:[]) <$> (DTySynInstD <$> dsTySynEqn unusedArgument eqn) +#else +dsDec (TySynInstD n eqn) = (:[]) <$> (DTySynInstD <$> dsTySynEqn n eqn) +#endif +dsDec (ClosedTypeFamilyD tfHead eqns) = + (:[]) <$> (DClosedTypeFamilyD <$> dsTypeFamilyHead tfHead + <*> mapM (dsTySynEqn (typeFamilyHeadName tfHead)) eqns) +dsDec (RoleAnnotD n roles) = return [DRoleAnnotD n roles] +#if __GLASGOW_HASKELL__ >= 801 +dsDec (PatSynD n args dir pat) = do + dir' <- dsPatSynDir n dir + (pat', vars) <- dsPatX pat + unless (null vars) $ + fail $ "Pattern synonym definition cannot contain as-patterns (@)." + return [DPatSynD n args dir' pat'] +dsDec (PatSynSigD n ty) = (:[]) <$> (DPatSynSigD n <$> dsType ty) +dsDec (StandaloneDerivD mds cxt ty) = + (:[]) <$> (DStandaloneDerivD <$> mapM dsDerivStrategy mds + <*> pure Nothing <*> dsCxt cxt <*> dsType ty) +#else +dsDec (StandaloneDerivD cxt ty) = + (:[]) <$> (DStandaloneDerivD Nothing Nothing <$> dsCxt cxt <*> dsType ty) +#endif +dsDec (DefaultSigD n ty) = (:[]) <$> (DDefaultSigD n <$> dsType ty) +#if __GLASGOW_HASKELL__ >= 807 +dsDec (ImplicitParamBindD {}) = impossible "Non-`let`-bound implicit param binding" +#endif +#if __GLASGOW_HASKELL__ >= 809 +dsDec (KiSigD n ki) = (:[]) <$> (DKiSigD n <$> dsType ki) +#endif +#if __GLASGOW_HASKELL__ >= 903 +dsDec (DefaultD tys) = (:[]) <$> (DDefaultD <$> mapM dsType tys) +#endif +#if __GLASGOW_HASKELL__ >= 906 +dsDec (TypeDataD n tys mk cons) = + dsDataDec TypeData [] n tys mk cons [] +#endif + +-- | Desugar a 'DataD', 'NewtypeD', or 'TypeDataD'. +dsDataDec :: DsMonad q + => DataFlavor -> Cxt -> Name -> [TyVarBndrVis] + -> Maybe Kind -> [Con] -> [DerivingClause] -> q [DDec] +dsDataDec nd cxt n tvbs mk cons derivings = do + tvbs' <- mapM dsTvbVis tvbs + h98_tvbs <- + case mk of + -- If there's an explicit return kind, we're dealing with a + -- GADT, so this argument goes unused in dsCon. + Just {} -> pure unusedArgument + -- If there is no explicit return kind, we're dealing with a + -- Haskell98-style data type, so we must compute the type variable + -- binders to use in the types of the data constructors. + -- + -- Rather than just returning `tvbs'` here, we propagate kind information + -- from the data type's standalone kind signature (if one exists) to make + -- the kinds more precise. + Nothing -> do + mb_sak <- dsReifyType n + let tvbSpecs = changeDTVFlags SpecifiedSpec tvbs' + pure $ maybe tvbSpecs dtvbForAllTyFlagsToSpecs $ do + sak <- mb_sak + dMatchUpSAKWithDecl sak tvbs' + let h98_return_type = nonFamilyDataReturnType n tvbs' + (:[]) <$> (DDataD nd <$> dsCxt cxt <*> pure n + <*> pure tvbs' <*> mapM dsType mk + <*> concatMapM (dsCon h98_tvbs h98_return_type) cons + <*> mapM dsDerivClause derivings) + +-- | Desugar a 'DataInstD' or a 'NewtypeInstD'. +dsDataInstDec :: DsMonad q + => DataFlavor -> Cxt -> Name -> Maybe [TyVarBndrUnit] -> [TypeArg] + -> Maybe Kind -> [Con] -> [DerivingClause] -> q [DDec] +dsDataInstDec nd cxt n mtvbs tys mk cons derivings = do + mtvbs' <- mapM (mapM dsTvbUnit) mtvbs + tys' <- mapM dsTypeArg tys + let lhs' = applyDType (DConT n) tys' + h98_tvbs = + changeDTVFlags SpecifiedSpec $ + case (mk, mtvbs') of + -- If there's an explicit return kind, we're dealing with a + -- GADT, so this argument goes unused in dsCon. + (Just {}, _) -> unusedArgument + -- H98, and there is an explicit `forall` in front. Just reuse the + -- type variable binders from the `forall`. + (Nothing, Just tvbs') -> tvbs' + -- H98, and no explicit `forall`. Compute the bound variables + -- manually. + (Nothing, Nothing) -> dataFamInstTvbs tys' + h98_fam_inst_type = dataFamInstReturnType n tys' + (:[]) <$> (DDataInstD nd <$> dsCxt cxt <*> pure mtvbs' + <*> pure lhs' <*> mapM dsType mk + <*> concatMapM (dsCon h98_tvbs h98_fam_inst_type) cons + <*> mapM dsDerivClause derivings) + +-- | Desugar a @FamilyResultSig@ +dsFamilyResultSig :: DsMonad q => FamilyResultSig -> q DFamilyResultSig +dsFamilyResultSig NoSig = return DNoSig +dsFamilyResultSig (KindSig k) = DKindSig <$> dsType k +dsFamilyResultSig (TyVarSig tvb) = DTyVarSig <$> dsTvbUnit tvb + +-- | Desugar a @TypeFamilyHead@ +dsTypeFamilyHead :: DsMonad q => TypeFamilyHead -> q DTypeFamilyHead +dsTypeFamilyHead (TypeFamilyHead n tvbs result inj) + = DTypeFamilyHead n <$> mapM dsTvbVis tvbs + <*> dsFamilyResultSig result + <*> pure inj + +typeFamilyHeadName :: TypeFamilyHead -> Name +typeFamilyHeadName (TypeFamilyHead n _ _ _) = n + +-- | Desugar @Dec@s that can appear in a @let@ expression. See the +-- documentation for 'dsLetDec' for an explanation of what the return type +-- represents. +dsLetDecs :: DsMonad q => [Dec] -> q ([DLetDec], DExp -> DExp) +dsLetDecs decs = do + (let_decss, ip_binders) <- mapAndUnzipM dsLetDec decs + let let_decs :: [DLetDec] + let_decs = concat let_decss + + ip_binder :: DExp -> DExp + ip_binder = foldr (.) id ip_binders + return (let_decs, ip_binder) + +-- | Desugar a single 'Dec' that can appear in a @let@ expression. +-- This produces the following output: +-- +-- * One or more 'DLetDec's (a single 'Dec' can produce multiple 'DLetDec's +-- in the event of a value declaration that binds multiple things by way +-- of pattern matching. +-- +-- * A function of type @'DExp' -> 'DExp'@, which should be applied to the +-- expression immediately following the 'DLetDec's. This function prepends +-- binding forms for any implicit params that were bound in the argument +-- 'Dec'. (If no implicit params are bound, this is simply the 'id' +-- function.) +-- +-- For instance, if the argument to 'dsLetDec' is the @?x = 42@ part of this +-- expression: +-- +-- @ +-- let { ?x = 42 } in ?x +-- @ +-- +-- Then the output is: +-- +-- * @let new_x_val = 42@ +-- +-- * @\\z -> 'bindIP' \@\"x\" new_x_val z@ +-- +-- This way, the expression +-- @let { new_x_val = 42 } in 'bindIP' \@"x" new_x_val ('ip' \@\"x\")@ can be +-- formed. The implicit param binders always come after all the other +-- 'DLetDec's to support parallel assignment of implicit params. +dsLetDec :: DsMonad q => Dec -> q ([DLetDec], DExp -> DExp) +dsLetDec (FunD name clauses) = do + clauses' <- dsClauses (FunRhs name) clauses + return ([DFunD name clauses'], id) +dsLetDec (ValD pat body where_decs) = do + (pat', vars) <- dsPatX pat + body' <- dsBody body where_decs error_exp + let extras = uncurry (zipWith (DValD . DVarP)) $ unzip vars + return (DValD pat' body' : extras, id) + where + error_exp = mkErrorMatchExpr (LetDecRhs pat) +dsLetDec (SigD name ty) = do + ty' <- dsType ty + return ([DSigD name ty'], id) +#if __GLASGOW_HASKELL__ >= 909 +dsLetDec (InfixD fixity ns_spec name) = + return ([DInfixD fixity ns_spec name], id) +#else +dsLetDec (InfixD fixity name) = + return ([DInfixD fixity NoNamespaceSpecifier name], id) +#endif +dsLetDec (PragmaD prag) = do + prag' <- dsPragma prag + return ([DPragmaD prag'], id) +#if __GLASGOW_HASKELL__ >= 807 +dsLetDec (ImplicitParamBindD n e) = do + new_n_name <- qNewName $ "new_" ++ n ++ "_val" + e' <- dsExp e + let let_dec :: DLetDec + let_dec = DValD (DVarP new_n_name) e' + + ip_binder :: DExp -> DExp + ip_binder = (DVarE 'bindIP `DAppTypeE` + DLitT (StrTyLit n) `DAppE` + DVarE new_n_name `DAppE`) + return ([let_dec], ip_binder) +#endif +dsLetDec _dec = impossible "Illegal declaration in let expression." + +-- | Desugar a single 'Dec' corresponding to something that could appear after +-- the @let@ in a @let@ expression, but occurring at the top level. Because the +-- 'Dec' occurs at the top level, there is nothing that would correspond to the +-- @in ...@ part of the @let@ expression. As a consequence, this function does +-- not return a @'DExp' -> 'DExp'@ function corresonding to implicit param +-- binders (these cannot occur at the top level). +dsTopLevelLetDec :: DsMonad q => Dec -> q [DDec] +dsTopLevelLetDec = fmap (map DLetDec . fst) . dsLetDec + -- Note the use of fst above: we're silently throwing away any implicit param + -- binders that dsLetDec returns, since there is invariant that there will be + -- no implicit params in the first place. + +-- | Desugar a single @Con@. +-- +-- Because we always desugar @Con@s to GADT syntax (see the documentation for +-- 'DCon'), it is not always possible to desugar with just a 'Con' alone. +-- For instance, we must desugar: +-- +-- @ +-- data Foo a = forall b. MkFoo b +-- @ +-- +-- To this: +-- +-- @ +-- data Foo a :: Type where +-- MkFoo :: forall a b. b -> Foo a +-- @ +-- +-- If our only argument was @forall b. MkFoo b@, it would be somewhat awkward +-- to figure out (1) what the set of universally quantified type variables +-- (@[a]@) was, and (2) what the return type (@Foo a@) was. For this reason, +-- we require passing these as arguments. (If we desugar an actual GADT +-- constructor, these arguments are ignored.) +dsCon :: DsMonad q + => [DTyVarBndrSpec] -- ^ The universally quantified type variables + -- (used if desugaring a non-GADT constructor). + -> DType -- ^ The original data declaration's type + -- (used if desugaring a non-GADT constructor). + -> Con -> q [DCon] +dsCon univ_dtvbs data_type con = do + dcons' <- dsCon' con + return $ flip map dcons' $ \(n, dtvbs, dcxt, fields, m_gadt_type) -> + case m_gadt_type of + Nothing -> + let ex_dtvbs = dtvbs + expl_dtvbs = univ_dtvbs ++ ex_dtvbs + impl_dtvbs = changeDTVFlags SpecifiedSpec $ + toposortKindVarsOfTvbs expl_dtvbs in + DCon (impl_dtvbs ++ expl_dtvbs) dcxt n fields data_type + Just gadt_type -> + let univ_ex_dtvbs = dtvbs in + DCon univ_ex_dtvbs dcxt n fields gadt_type + +-- Desugar a Con in isolation. The meaning of the returned DTyVarBndrs changes +-- depending on what the returned Maybe DType value is: +-- +-- * If returning Just gadt_ty, then we've encountered a GadtC or RecGadtC, +-- so the returned DTyVarBndrs are both the universally and existentially +-- quantified tyvars. +-- * If returning Nothing, we're dealing with a non-GADT constructor, so +-- the returned DTyVarBndrs are the existentials only. +dsCon' :: DsMonad q + => Con -> q [(Name, [DTyVarBndrSpec], DCxt, DConFields, Maybe DType)] +dsCon' (NormalC n stys) = do + dtys <- mapM dsBangType stys + return [(n, [], [], DNormalC False dtys, Nothing)] +dsCon' (RecC n vstys) = do + vdtys <- mapM dsVarBangType vstys + return [(n, [], [], DRecC vdtys, Nothing)] +dsCon' (InfixC sty1 n sty2) = do + dty1 <- dsBangType sty1 + dty2 <- dsBangType sty2 + return [(n, [], [], DNormalC True [dty1, dty2], Nothing)] +dsCon' (ForallC tvbs cxt con) = do + dtvbs <- mapM dsTvbSpec tvbs + dcxt <- dsCxt cxt + dcons' <- dsCon' con + return $ flip map dcons' $ \(n, dtvbs', dcxt', fields, m_gadt_type) -> + (n, dtvbs ++ dtvbs', dcxt ++ dcxt', fields, m_gadt_type) +dsCon' (GadtC nms btys rty) = do + dbtys <- mapM dsBangType btys + drty <- dsType rty + sequence $ flip map nms $ \nm -> do + mbFi <- reifyFixityWithLocals nm + -- A GADT data constructor is declared infix when these three + -- properties hold: + let decInfix = isInfixDataCon (nameBase nm) -- 1. Its name uses operator syntax + -- (e.g., (:*:)) + && length dbtys == 2 -- 2. It has exactly two fields + && isJust mbFi -- 3. It has a programmer-specified + -- fixity declaration + return (nm, [], [], DNormalC decInfix dbtys, Just drty) +dsCon' (RecGadtC nms vbtys rty) = do + dvbtys <- mapM dsVarBangType vbtys + drty <- dsType rty + return $ flip map nms $ \nm -> + (nm, [], [], DRecC dvbtys, Just drty) + +-- | Desugar a @BangType@. +dsBangType :: DsMonad q => BangType -> q DBangType +dsBangType (b, ty) = (b, ) <$> dsType ty + +-- | Desugar a @VarBangType@. +dsVarBangType :: DsMonad q => VarBangType -> q DVarBangType +dsVarBangType (n, b, ty) = (n, b, ) <$> dsType ty + +-- | Desugar a @Foreign@. +dsForeign :: DsMonad q => Foreign -> q DForeign +dsForeign (ImportF cc safety str n ty) = DImportF cc safety str n <$> dsType ty +dsForeign (ExportF cc str n ty) = DExportF cc str n <$> dsType ty + +-- | Desugar a @Pragma@. +dsPragma :: DsMonad q => Pragma -> q DPragma +dsPragma (InlineP n inl rm phases) = return $ DInlineP n inl rm phases +dsPragma (SpecialiseP n ty m_inl phases) = DSpecialiseP n <$> dsType ty + <*> pure m_inl + <*> pure phases +dsPragma (SpecialiseInstP ty) = DSpecialiseInstP <$> dsType ty +#if __GLASGOW_HASKELL__ >= 807 +dsPragma (RuleP str mtvbs rbs lhs rhs phases) + = DRuleP str <$> mapM (mapM dsTvbUnit) mtvbs + <*> mapM dsRuleBndr rbs + <*> dsExp lhs + <*> dsExp rhs + <*> pure phases +#else +dsPragma (RuleP str rbs lhs rhs phases) = DRuleP str Nothing + <$> mapM dsRuleBndr rbs + <*> dsExp lhs + <*> dsExp rhs + <*> pure phases +#endif +dsPragma (AnnP target exp) = DAnnP target <$> dsExp exp +dsPragma (LineP n str) = return $ DLineP n str +#if __GLASGOW_HASKELL__ >= 801 +dsPragma (CompleteP cls mty) = return $ DCompleteP cls mty +#endif +#if __GLASGOW_HASKELL__ >= 903 +dsPragma (OpaqueP n) = return $ DOpaqueP n +#endif +#if __GLASGOW_HASKELL__ >= 909 +dsPragma (SCCP nm mstr) = return $ DSCCP nm mstr +#endif +#if __GLASGOW_HASKELL__ >= 913 +dsPragma (SpecialiseEP mTyBndrs tmBndrs specE mInline phases) = + DSpecialiseEP + <$> mapM (mapM dsTvbUnit) mTyBndrs + <*> mapM dsRuleBndr tmBndrs + <*> dsExp specE + <*> pure mInline + <*> pure phases +#endif + +-- | Desugar a @RuleBndr@. +dsRuleBndr :: DsMonad q => RuleBndr -> q DRuleBndr +dsRuleBndr (RuleVar n) = return $ DRuleVar n +dsRuleBndr (TypedRuleVar n ty) = DTypedRuleVar n <$> dsType ty + +#if __GLASGOW_HASKELL__ >= 807 +-- | Desugar a @TySynEqn@. (Available only with GHC 7.8+) +-- +-- This requires a 'Name' as an argument since 'TySynEqn's did not have +-- this information prior to GHC 8.8. +dsTySynEqn :: DsMonad q => Name -> TySynEqn -> q DTySynEqn +dsTySynEqn _ (TySynEqn mtvbs lhs rhs) = + DTySynEqn <$> mapM (mapM dsTvbUnit) mtvbs <*> dsType lhs <*> dsType rhs +#else +-- | Desugar a @TySynEqn@. (Available only with GHC 7.8+) +dsTySynEqn :: DsMonad q => Name -> TySynEqn -> q DTySynEqn +dsTySynEqn n (TySynEqn lhss rhs) = do + lhss' <- mapM dsType lhss + let lhs' = applyDType (DConT n) $ map DTANormal lhss' + DTySynEqn Nothing lhs' <$> dsType rhs +#endif + +-- | Desugar clauses to a function definition +dsClauses :: DsMonad q + => MatchContext -- ^ The context in which the clauses arise + -> [Clause] -- ^ Clauses to desugar + -> q [DClause] +dsClauses _ [] = return [] +-- Include a special case for guard-less clauses to make the desugared output +-- a little nicer. See Note [Desugaring clauses compactly (when possible)]. +dsClauses mc (Clause pats (NormalB exp) where_decs : rest) = do + rest' <- dsClauses mc rest + exp' <- dsExp exp + (where_decs', ip_binder) <- dsLetDecs where_decs + let exp_with_wheres = maybeDLetE where_decs' (ip_binder exp') + (pats', exp'') <- dsPatsOverExp pats exp_with_wheres + return $ DClause pats' exp'' : rest' +dsClauses mc clauses@(Clause outer_pats _ _ : _) = do + arg_names <- replicateM (length outer_pats) (newUniqueName "arg") + let scrutinees = map DVarE arg_names + clauses' <- foldrM (ds_clause scrutinees) [] clauses + pure [DClause (map DVarP arg_names) (dCasesE scrutinees clauses')] + where + ds_clause :: DsMonad q => [DExp] -> Clause -> [DClause] -> q [DClause] + ds_clause scrutinees (Clause pats body where_decs) failure_clauses = do + let failure_exp = maybeDCasesE mc scrutinees failure_clauses + exp <- dsBody body where_decs failure_exp + (pats', exp') <- dsPatsOverExp pats exp + -- incomplete attempt at #6 + uni_pats <- fmap getAll $ concatMapM (fmap All . isUniversalPattern) pats' + let clause = DClause pats' exp' + if uni_pats + then return [clause] + else return (clause : failure_clauses) + +-- | The context of a pattern match. This is used to produce +-- @Non-exhaustive patterns in...@ messages that are tailored to specific +-- situations. Compare this to GHC's @HsMatchContext@ data type +-- (https://gitlab.haskell.org/ghc/ghc/-/blob/81cf52bb301592ff3d043d03eb9a0d547891a3e1/compiler/Language/Haskell/Syntax/Expr.hs#L1662-1695), +-- from which the @MatchContext@ data type takes inspiration. +data MatchContext + = FunRhs Name + -- ^ A pattern matching on an argument of a function binding + | LetDecRhs Pat + -- ^ A pattern in a @let@ declaration + | RecUpd + -- ^ A record update + | MultiWayIfAlt + -- ^ Guards in a multi-way if alternative + | CaseAlt + -- ^ Patterns and guards in a case alternative + | LamCaseAlt LamCaseVariant + -- ^ Patterns and guards in @\\case@ and @\\cases@ + +-- | Which kind of lambda case are we dealing with? Compare this to GHC's +-- @LamCaseVariant@ data type +-- (https://gitlab.haskell.org/ghc/ghc/-/blob/81cf52bb301592ff3d043d03eb9a0d547891a3e1/compiler/Language/Haskell/Syntax/Expr.hs#L686-690) +-- from which we take inspiration. +data LamCaseVariant + = LamCase -- ^ @\\case@ + | LamCases -- ^ @\\cases@ + +-- | Construct an expression that throws an error when encountering a pattern +-- at runtime that is not covered by pattern matching. +mkErrorMatchExpr :: MatchContext -> DExp +mkErrorMatchExpr mc = + DAppE (DVarE 'error) (DLitE (StringL ("Non-exhaustive patterns in " ++ pp_context))) + where + pp_context = + case mc of + FunRhs n -> show n + LetDecRhs pat -> pprint pat + RecUpd -> "record update" + MultiWayIfAlt -> "multi-way if" + CaseAlt -> "case" + LamCaseAlt lv -> pp_lam_case_variant lv + + pp_lam_case_variant LamCase = "\\case" + pp_lam_case_variant LamCases = "\\cases" + +{- +Note [Desugaring clauses compactly (when possible)] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the general case, th-desugar's approach to desugaring clauses with guards +requires binding an extra variable. For example, consider this code: + + \case + A x | x == "hello" -> x + B y -> y + _ -> "" + +As part of desugaring, th-desugar will get rid of the guards by rewriting the +code to something that looks closer to this: + + \scrutinee -> + case scrutinee of + A x -> + if x == "hello" + then x + else case scrutinee of + B y -> y + _ -> "" + B y -> y + _ -> "" + +(The fully desugared output would then translate the lambda and `case` +expressions to `\cases` expressions, but let's put that aside for now. We'll +come back to this in a bit.) + +Note the `scrutinee` argument, which is now explicitly named. Binding the +argument to a name is important because we need to further match on it when the +`x == "hello"` guard fails to match. + +This approach gets the job done, but it does add a some amount of extra +clutter. We take steps to avoid this clutter where possible. Consider this +simpler example: + + \case + A x -> x + B y -> y + _ -> "" + +If we were to desugar this example using the same approach as above, we'd end +up with something like this: + + \scrutinee -> + case scrutinee of + A x -> x + B y -> y + _ -> "" + +Recall that th-desugar will desugar lambda and `case` expressions to `\cases` +exprressions. As such, the fully desugared output would be: + + \cases + scrutinee -> + (\cases + A x -> x + B y -> y + _ -> "") scrutinee + +This would technically work, but we would lose something along the way. By +using this approach, we would transform something with a single `\case` +expression to something with multiple `\cases` expressions. Moreover, the +original expression never needed to give a name to the `scrutinee` variable, so +it would be strange for the desugared output to require this extra clutter. + +Luckily, we can avoid the clutter by observing that the `scrutinee` variable +can be eta-contracted away. More generally, if a set of clauses does not use +any guards, then we don't bother explicitly binding a variable like +`scrutinee`, as we never need to use it outside of the initial matching. This +means that we can desugar the simpler example above to: + + \cases + (A x) -> x + (B y) -> y + _ -> "" + +Ahh. Much nicer. + +Of course, the flip side is that we /do/ need the extra `scrutinee` clutter +when desugaring clauses involving guards. Personally, I'm not too bothered by +this, as th-desugar's approach to desugaring guards already has various +limitations (see the "Known limitations" section of the th-desugar README). As +such, I'm not inclined to invest more effort into fixing this unless someone +explicitly asks for it. +-} + +-- | Desugar a type +dsType :: DsMonad q => Type -> q DType +#if __GLASGOW_HASKELL__ >= 900 +-- See Note [Gracefully handling linear types] +dsType (MulArrowT `AppT` _) = return DArrowT +dsType MulArrowT = fail "Cannot desugar exotic uses of linear types." +#endif +dsType (ForallT tvbs preds ty) = + mkDForallConstrainedT <$> (DForallInvis <$> mapM dsTvbSpec tvbs) + <*> dsCxt preds <*> dsType ty +dsType (AppT t1 t2) = DAppT <$> dsType t1 <*> dsType t2 +dsType (SigT ty ki) = DSigT <$> dsType ty <*> dsType ki +dsType (VarT name) = return $ DVarT name +dsType (ConT name) = return $ DConT name +-- The PromotedT case is identical to the ConT case above. +-- See Note [Desugaring promoted types]. +dsType (PromotedT name) = return $ DConT name +dsType (TupleT n) = return $ DConT (tupleTypeName n) +dsType (UnboxedTupleT n) = return $ DConT (unboxedTupleTypeName n) +dsType ArrowT = return DArrowT +dsType ListT = return $ DConT ''[] +dsType (PromotedTupleT n) = return $ DConT (tupleDataName n) +dsType PromotedNilT = return $ DConT '[] +dsType PromotedConsT = return $ DConT '(:) +dsType StarT = return $ DConT typeKindName +dsType ConstraintT = return $ DConT ''Constraint +dsType (LitT lit) = return $ DLitT lit +dsType EqualityT = return $ DConT ''(~) +dsType (InfixT t1 n t2) = dsInfixT t1 n t2 +dsType (UInfixT{}) = dsUInfixT +dsType (ParensT t) = dsType t +dsType WildCardT = return DWildCardT +#if __GLASGOW_HASKELL__ >= 801 +dsType (UnboxedSumT arity) = return $ DConT (unboxedSumTypeName arity) +#endif +#if __GLASGOW_HASKELL__ >= 807 +dsType (AppKindT t k) = DAppKindT <$> dsType t <*> dsType k +dsType (ImplicitParamT n t) = do + t' <- dsType t + return $ DConT ''IP `DAppT` DLitT (StrTyLit n) `DAppT` t' +#endif +#if __GLASGOW_HASKELL__ >= 809 +dsType (ForallVisT tvbs ty) = + DForallT <$> (DForallVis <$> mapM dsTvbUnit tvbs) <*> dsType ty +#endif +#if __GLASGOW_HASKELL__ >= 903 +-- The PromotedInfixT case is identical to the InfixT case above. +-- See Note [Desugaring promoted types]. +dsType (PromotedInfixT t1 n t2) = dsInfixT t1 n t2 +dsType PromotedUInfixT{} = dsUInfixT +#endif + +#if __GLASGOW_HASKELL__ >= 900 +-- | Desugar a 'TyVarBndr'. +dsTvb :: DsMonad q => TyVarBndr_ flag -> q (DTyVarBndr flag) +dsTvb (PlainTV n flag) = return $ DPlainTV n flag +dsTvb (KindedTV n flag k) = DKindedTV n flag <$> dsType k +#else +-- | Desugar a 'TyVarBndr' with a particular @flag@. +dsTvb :: DsMonad q => flag -> TyVarBndr -> q (DTyVarBndr flag) +dsTvb flag (PlainTV n) = return $ DPlainTV n flag +dsTvb flag (KindedTV n k) = DKindedTV n flag <$> dsType k +#endif + +{- +Note [Gracefully handling linear types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Per the README, th-desugar does not currently support linear types. +Unfortunately, we cannot simply reject all occurrences of +multiplicity-polymorphic function arrows (i.e., MulArrowT), as it is possible +for "non-linear" code to contain them when reified. For example, the type of a +Haskell98 data constructor such as `Just` will be reified as + + a #-> Maybe a + +In terms of the TH AST, that is: + + MulArrowT `AppT` PromotedConT 'One `AppT` VarT a `AppT` (ConT ''Maybe `AppT` VarT a) + +Therefore, in order to desugar these sorts of types, we have to do *something* +with MulArrowT. The approach that th-desugar takes is to pretend that all +multiplicity-polymorphic function arrows are actually ordinary function arrows +(->) when desugaring types. In other words, whenever th-desugar sees +(MulArrowT `AppT` m), for any particular value of `m`, it will turn it into +DArrowT. + +This approach is enough to gracefully handle most uses of MulArrowT, as TH +reification always generates MulArrowT applied to some particular multiplicity +(as of GHC 9.0, at least). It's conceivable that some wily user could manually +construct a TH AST containing MulArrowT in a different position, but since this +situation is rare, we simply throw an error in such cases. + +We adopt a similar stance in L.H.TH.Desugar.Reify when locally reifying the +types of data constructors: since th-desugar doesn't currently support linear +types, we pretend as if MulArrowT does not exist. As a result, the type of +`Just` would be locally reified as `a -> Maybe a`, not `a #-> Maybe a`. + +Note [Desugaring promoted types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +ConT and PromotedT both contain Names as a payload, the only difference being +that PromotedT is intended to refer exclusively to promoted data constructor +Names, while ConT can refer to both type and data constructor Names alike. + +When desugaring a PromotedT, we make the assumption that the TH quoting +mechanism produced the correct Name and wrap the name in a DConT. In other +words, we desugar ConT and PromotedT identically. This assumption about +PromotedT may not always be correct, however. Consider this example: + + data a :+: b = Inl a | Inr b + data Exp a = ... | Exp :+: Exp + +How should `PromotedT (mkName ":+:")` be desugared? Morally, it ought to be +desugared to a DConT that contains (:+:) the data constructor, not (:+:) the +type constructor. Deciding between the two is not always straightforward, +however. We could use the `lookupDataName` function to try and distinguish +between the two Names, but this may not necessarily work. This is because the +Name passed to `lookupDataName` could have its original module attached, which +may not be in scope. + +Long story short: we make things simple (albeit slightly wrong) by desugaring +ConT and PromotedT identically. We'll wait for someone to complain about the +wrongness of this approach before researching a more accurate solution. + +Note that the same considerations also apply to InfixT and PromotedInfixT, +which are also desugared identically. +-} + +-- | Desugar an infix 'Type'. +dsInfixT :: DsMonad q => Type -> Name -> Type -> q DType +dsInfixT t1 n t2 = DAppT <$> (DAppT (DConT n) <$> dsType t1) <*> dsType t2 + +-- | We cannot desugar unresolved infix operators, so fail if we encounter one. +dsUInfixT :: Fail.MonadFail m => m a +dsUInfixT = fail "Cannot desugar unresolved infix operators." + +-- | Desugar a 'TyVarBndrSpec'. +dsTvbSpec :: DsMonad q => TyVarBndrSpec -> q DTyVarBndrSpec +#if __GLASGOW_HASKELL__ >= 900 +dsTvbSpec = dsTvb +#else +dsTvbSpec = dsTvb SpecifiedSpec +#endif + +-- | Desugar a 'TyVarBndrUnit'. +dsTvbUnit :: DsMonad q => TyVarBndrUnit -> q DTyVarBndrUnit +#if __GLASGOW_HASKELL__ >= 900 +dsTvbUnit = dsTvb +#else +dsTvbUnit = dsTvb () +#endif + +-- | Desugar a 'TyVarBndrVis'. +dsTvbVis :: DsMonad q => TyVarBndrVis -> q DTyVarBndrVis +#if __GLASGOW_HASKELL__ >= 900 +dsTvbVis = dsTvb +#else +dsTvbVis = dsTvb BndrReq +#endif + +-- | Desugar a @Cxt@ +dsCxt :: DsMonad q => Cxt -> q DCxt +dsCxt = concatMapM dsPred + +#if __GLASGOW_HASKELL__ >= 801 +-- | A backwards-compatible type synonym for the thing representing a single +-- derived class in a @deriving@ clause. (This is a @DerivClause@, @Pred@, or +-- @Name@ depending on the GHC version.) +type DerivingClause = DerivClause + +-- | Desugar a @DerivingClause@. +dsDerivClause :: DsMonad q => DerivingClause -> q DDerivClause +dsDerivClause (DerivClause mds cxt) = + DDerivClause <$> mapM dsDerivStrategy mds <*> dsCxt cxt +#else +type DerivingClause = Pred + +dsDerivClause :: DsMonad q => DerivingClause -> q DDerivClause +dsDerivClause p = DDerivClause Nothing <$> dsPred p +#endif + +#if __GLASGOW_HASKELL__ >= 801 +-- | Desugar a @DerivStrategy@. +dsDerivStrategy :: DsMonad q => DerivStrategy -> q DDerivStrategy +dsDerivStrategy StockStrategy = pure DStockStrategy +dsDerivStrategy AnyclassStrategy = pure DAnyclassStrategy +dsDerivStrategy NewtypeStrategy = pure DNewtypeStrategy +#if __GLASGOW_HASKELL__ >= 805 +dsDerivStrategy (ViaStrategy ty) = DViaStrategy <$> dsType ty +#endif +#endif + +#if __GLASGOW_HASKELL__ >= 801 +-- | Desugar a @PatSynDir@. (Available only with GHC 8.2+) +dsPatSynDir :: DsMonad q => Name -> PatSynDir -> q DPatSynDir +dsPatSynDir _ Unidir = pure DUnidir +dsPatSynDir _ ImplBidir = pure DImplBidir +dsPatSynDir n (ExplBidir clauses) = DExplBidir <$> dsClauses (FunRhs n) clauses +#endif + +-- | Desugar a @Pred@, flattening any internal tuples +dsPred :: DsMonad q => Pred -> q DCxt +dsPred t + | Just ts <- splitTuple_maybe t + = concatMapM dsPred ts +dsPred (ForallT tvbs cxt p) = dsForallPred tvbs cxt p +dsPred (AppT t1 t2) = do + [p1] <- dsPred t1 -- tuples can't be applied! + (:[]) <$> DAppT p1 <$> dsType t2 +dsPred (SigT ty ki) = do + preds <- dsPred ty + case preds of + [p] -> (:[]) <$> DSigT p <$> dsType ki + other -> return other -- just drop the kind signature on a tuple. +dsPred (VarT n) = return [DVarT n] +dsPred (ConT n) = return [DConT n] +dsPred t@(PromotedT _) = + impossible $ "Promoted type seen as head of constraint: " ++ show t +dsPred (TupleT 0) = return [DConT (tupleTypeName 0)] +dsPred (TupleT _) = + impossible "Internal error in th-desugar in detecting tuple constraints." +dsPred t@(UnboxedTupleT _) = + impossible $ "Unboxed tuple seen as head of constraint: " ++ show t +dsPred ArrowT = impossible "Arrow seen as head of constraint." +dsPred ListT = impossible "List seen as head of constraint." +dsPred (PromotedTupleT _) = + impossible "Promoted tuple seen as head of constraint." +dsPred PromotedNilT = impossible "Promoted nil seen as head of constraint." +dsPred PromotedConsT = impossible "Promoted cons seen as head of constraint." +dsPred StarT = impossible "* seen as head of constraint." +dsPred ConstraintT = + impossible "The kind `Constraint' seen as head of constraint." +dsPred t@(LitT _) = + impossible $ "Type literal seen as head of constraint: " ++ show t +dsPred EqualityT = return [DConT ''(~)] +dsPred (InfixT t1 n t2) = (:[]) <$> dsInfixT t1 n t2 +dsPred (UInfixT{}) = dsUInfixT +dsPred (ParensT t) = dsPred t +dsPred WildCardT = return [DWildCardT] +#if __GLASGOW_HASKELL__ >= 801 +dsPred t@(UnboxedSumT {}) = + impossible $ "Unboxed sum seen as head of constraint: " ++ show t +#endif +#if __GLASGOW_HASKELL__ >= 807 +dsPred (AppKindT t k) = do + [p] <- dsPred t + (:[]) <$> (DAppKindT p <$> dsType k) +dsPred (ImplicitParamT n t) = do + t' <- dsType t + return [DConT ''IP `DAppT` DLitT (StrTyLit n) `DAppT` t'] +#endif +#if __GLASGOW_HASKELL__ >= 809 +dsPred t@(ForallVisT {}) = + impossible $ "Visible dependent quantifier seen as head of constraint: " ++ show t +#endif +#if __GLASGOW_HASKELL__ >= 900 +dsPred MulArrowT = impossible "Linear arrow seen as head of constraint." +#endif +#if __GLASGOW_HASKELL__ >= 903 +dsPred t@PromotedInfixT{} = + impossible $ "Promoted infix type seen as head of constraint: " ++ show t +dsPred PromotedUInfixT{} = dsUInfixT +#endif + +-- | Desugar a quantified constraint. +dsForallPred :: DsMonad q => [TyVarBndrSpec] -> Cxt -> Pred -> q DCxt +dsForallPred tvbs cxt p = do + ps' <- dsPred p + case ps' of + [p'] -> (:[]) <$> (mkDForallConstrainedT <$> + (DForallInvis <$> mapM dsTvbSpec tvbs) <*> dsCxt cxt <*> pure p') + _ -> fail "Cannot desugar constraint tuples in the body of a quantified constraint" + -- See GHC #15334. + +-- | Like 'reify', but safer and desugared. Uses local declarations where +-- available. +dsReify :: DsMonad q => Name -> q (Maybe DInfo) +dsReify = traverse dsInfo <=< reifyWithLocals_maybe + +-- | Like 'reifyType', but safer and desugared. Uses local declarations where +-- available. +dsReifyType :: DsMonad q => Name -> q (Maybe DType) +dsReifyType = traverse dsType <=< reifyTypeWithLocals_maybe + +-- Given a list of `forall`ed type variable binders and a context, construct +-- a DType using DForallT and DConstrainedT as appropriate. The phrase +-- "as appropriate" is used because DConstrainedT will not be used if the +-- context is empty, per Note [Desugaring and sweetening ForallT]. +mkDForallConstrainedT :: DForallTelescope -> DCxt -> DType -> DType +mkDForallConstrainedT tele ctxt ty = + DForallT tele $ if null ctxt then ty else DConstrainedT ctxt ty + +-- create a list of expressions in the same order as the fields in the first argument +-- but with the values as given in the second argument +-- if a field is missing from the second argument, use the corresponding expression +-- from the third argument +reorderFields :: DsMonad q => Name -> [VarStrictType] -> [FieldExp] -> [DExp] -> q [DExp] +reorderFields = reorderFields' dsExp + +reorderFieldsPat :: DsMonad q => Name -> [VarStrictType] -> [FieldPat] -> PatM q [DPat] +reorderFieldsPat con_name field_decs field_pats = + reorderFields' dsPat con_name field_decs field_pats (repeat DWildP) + +reorderFields' :: (Applicative m, Fail.MonadFail m) + => (a -> m da) + -> Name -- ^ The name of the constructor (used for error reporting) + -> [VarStrictType] -> [(Name, a)] + -> [da] -> m [da] +reorderFields' ds_thing con_name field_names_types field_things deflts = + check_valid_fields >> reorder field_names deflts + where + field_names = map (\(a, _, _) -> a) field_names_types + + check_valid_fields = + forM_ field_things $ \(thing_name, _) -> + unless (thing_name `elem` field_names) $ + fail $ "Constructor ‘" ++ nameBase con_name ++ "‘ does not have field ‘" + ++ nameBase thing_name ++ "‘" + + reorder [] _ = return [] + reorder (field_name : rest) (deflt : rest_deflt) = do + rest' <- reorder rest rest_deflt + case find (\(thing_name, _) -> thing_name == field_name) field_things of + Just (_, thing) -> (: rest') <$> ds_thing thing + Nothing -> return $ deflt : rest' + reorder (_ : _) [] = error "Internal error in th-desugar." + +-- mkTupleDExp and friends construct tuples, avoiding the use of 1-tuples. These +-- are used to create auxiliary tuple values when desugaring ParallelListComp +-- expressions (see the Haddocks for dsParComp) and when match-flattening lazy +-- patterns (see the Haddocks for mkSelectorDecs in L.H.TH.Desugar.Match). + +-- | Make a tuple 'DExp' from a list of 'DExp's. Avoids using a 1-tuple. +mkTupleDExp :: [DExp] -> DExp +mkTupleDExp [exp] = exp +mkTupleDExp exps = foldl DAppE (DConE $ tupleDataName (length exps)) exps + +-- | Make a tuple 'Exp' from a list of 'Exp's. Avoids using a 1-tuple. +mkTupleExp :: [Exp] -> Exp +mkTupleExp [exp] = exp +mkTupleExp exps = foldl AppE (ConE $ tupleDataName (length exps)) exps + +-- | Make a tuple 'DPat' from a list of 'DPat's. Avoids using a 1-tuple. +mkTupleDPat :: [DPat] -> DPat +mkTupleDPat [pat] = pat +mkTupleDPat pats = DConP (tupleDataName (length pats)) [] pats + +-- | Make a tuple 'DType' from a list of 'DType's. Avoids using a 1-tuple. +mkTupleDType :: [DType] -> DType +mkTupleDType [ty] = ty +mkTupleDType tys = foldl DAppT (DConT $ tupleTypeName (length tys)) tys + +-- | Is this pattern guaranteed to match? +isUniversalPattern :: DsMonad q => DPat -> q Bool +isUniversalPattern (DLitP {}) = return False +isUniversalPattern (DVarP {}) = return True +isUniversalPattern (DConP con_name _ pats) = do + data_name <- dataConNameToDataName con_name + (_df, _tvbs, cons) <- getDataD "Internal error." data_name + if length cons == 1 + then fmap and $ mapM isUniversalPattern pats + else return False +isUniversalPattern (DTildeP {}) = return True +isUniversalPattern (DBangP pat) = isUniversalPattern pat +isUniversalPattern (DSigP pat _) = isUniversalPattern pat +isUniversalPattern DWildP = return True +isUniversalPattern (DTypeP _) = return True +isUniversalPattern (DInvisP _) = return True + +-- | Apply one 'DExp' to a list of arguments +applyDExp :: DExp -> [DExp] -> DExp +applyDExp = foldl DAppE + +-- | Apply one 'DType' to a list of arguments +applyDType :: DType -> [DTypeArg] -> DType +applyDType = foldl apply + where + apply :: DType -> DTypeArg -> DType + apply f (DTANormal x) = f `DAppT` x + apply f (DTyArg x) = f `DAppKindT` x + +-- | An argument to a type, either a normal type ('DTANormal') or a visible +-- kind application ('DTyArg'). +-- +-- 'DTypeArg' does not appear directly in the @th-desugar@ AST, but it is +-- useful when decomposing an application of a 'DType' to its arguments. +data DTypeArg + = DTANormal DType + | DTyArg DKind + deriving (Eq, Show, Data, Generic) + +-- | Desugar a 'TypeArg'. +dsTypeArg :: DsMonad q => TypeArg -> q DTypeArg +dsTypeArg (TANormal t) = DTANormal <$> dsType t +dsTypeArg (TyArg k) = DTyArg <$> dsType k + +-- | Filter the normal type arguments from a list of 'DTypeArg's. +filterDTANormals :: [DTypeArg] -> [DType] +filterDTANormals = mapMaybe getDTANormal + where + getDTANormal :: DTypeArg -> Maybe DType + getDTANormal (DTANormal t) = Just t + getDTANormal (DTyArg {}) = Nothing + +-- | Convert a 'DTyVarBndr' into a 'DType' +dTyVarBndrToDType :: DTyVarBndr flag -> DType +dTyVarBndrToDType (DPlainTV a _) = DVarT a +dTyVarBndrToDType (DKindedTV a _ k) = DVarT a `DSigT` k + +-- | Convert a 'DTyVarBndrVis' to a 'DTypeArg'. That is, convert a binder with a +-- 'BndrReq' visibility to a 'DTANormal' and a binder with 'BndrInvis' +-- visibility to a 'DTyArg'. +-- +-- If given a 'DKindedTV', the resulting 'DTypeArg' will omit the kind +-- signature. Use 'dTyVarBndrVisToDTypeArgWithSig' if you want to preserve the +-- kind signature. +dTyVarBndrVisToDTypeArg :: DTyVarBndrVis -> DTypeArg +dTyVarBndrVisToDTypeArg bndr = + case dtvbFlag bndr of + BndrReq -> DTANormal bndr_ty + BndrInvis -> DTyArg bndr_ty + where + bndr_ty = case bndr of + DPlainTV a _ -> DVarT a + DKindedTV a _ _ -> DVarT a + +-- | Convert a 'DTyVarBndrVis' to a 'DTypeArg'. That is, convert a binder with a +-- 'BndrReq' visibility to a 'DTANormal' and a binder with 'BndrInvis' +-- visibility to a 'DTyArg'. +-- +-- If given a 'DKindedTV', the resulting 'DTypeArg' will preserve the kind +-- signature. Use 'dTyVarBndrVisToDTypeArg' if you want to omit the kind +-- signature. +dTyVarBndrVisToDTypeArgWithSig :: DTyVarBndrVis -> DTypeArg +dTyVarBndrVisToDTypeArgWithSig bndr = + case dtvbFlag bndr of + BndrReq -> DTANormal bndr_ty + BndrInvis -> DTyArg bndr_ty + where + bndr_ty = dTyVarBndrToDType bndr + +-- | Extract the underlying 'DType' or 'DKind' from a 'DTypeArg'. This forgets +-- information about whether a type is a normal argument or not, so use with +-- caution. +probablyWrongUnDTypeArg :: DTypeArg -> DType +probablyWrongUnDTypeArg (DTANormal t) = t +probablyWrongUnDTypeArg (DTyArg k) = k + +-- Take a data type name (which does not belong to a data family) and +-- apply it to its type variable binders to form a DType. +nonFamilyDataReturnType :: Name -> [DTyVarBndrVis] -> DType +nonFamilyDataReturnType con_name = + applyDType (DConT con_name) . map dTyVarBndrVisToDTypeArg + +-- Take a data family name and apply it to its argument types to form a +-- data family instance DType. +dataFamInstReturnType :: Name -> [DTypeArg] -> DType +dataFamInstReturnType fam_name = applyDType (DConT fam_name) + +-- Data family instance declarations did not come equipped with a list of bound +-- type variables until GHC 8.8 (and even then, it's optional whether the user +-- provides them or not). This means that there are situations where we must +-- reverse engineer this information ourselves from the list of type +-- arguments. We accomplish this by taking the free variables of the types +-- and performing a reverse topological sort on them to ensure that the +-- returned list is well scoped. +dataFamInstTvbs :: [DTypeArg] -> [DTyVarBndrUnit] +dataFamInstTvbs = toposortTyVarsOf . map probablyWrongUnDTypeArg + +-- | Take a list of 'DType's, find their free variables, and sort them in +-- reverse topological order to ensure that they are well scoped. In other +-- words, the free variables are ordered such that: +-- +-- 1. Whenever an explicit kind signature of the form @(A :: K)@ is +-- encountered, the free variables of @K@ will always appear to the left of +-- the free variables of @A@ in the returned result. +-- +-- 2. The constraint in (1) notwithstanding, free variables will appear in +-- left-to-right order of their original appearance. +-- +-- On older GHCs, this takes measures to avoid returning explicitly bound +-- kind variables, which was not possible before @TypeInType@. +toposortTyVarsOf :: [DType] -> [DTyVarBndrUnit] +toposortTyVarsOf tys = + let freeVars :: [Name] + freeVars = F.toList $ foldMap fvDType tys + + varKindSigs :: Map Name DKind + varKindSigs = foldMap go_ty tys + where + go_ty :: DType -> Map Name DKind + go_ty (DForallT tele t) = go_tele tele (go_ty t) + go_ty (DConstrainedT ctxt t) = foldMap go_ty ctxt `mappend` go_ty t + go_ty (DAppT t1 t2) = go_ty t1 `mappend` go_ty t2 + go_ty (DAppKindT t k) = go_ty t `mappend` go_ty k + go_ty (DSigT t k) = + let kSigs = go_ty k + in case t of + DVarT n -> M.insert n k kSigs + _ -> go_ty t `mappend` kSigs + go_ty (DVarT {}) = mempty + go_ty (DConT {}) = mempty + go_ty DArrowT = mempty + go_ty (DLitT {}) = mempty + go_ty DWildCardT = mempty + + go_tele :: DForallTelescope -> Map Name DKind -> Map Name DKind + go_tele (DForallVis tvbs) = go_tvbs tvbs + go_tele (DForallInvis tvbs) = go_tvbs tvbs + + go_tvbs :: [DTyVarBndr flag] -> Map Name DKind -> Map Name DKind + go_tvbs tvbs m = foldr go_tvb m tvbs + + go_tvb :: DTyVarBndr flag -> Map Name DKind -> Map Name DKind + go_tvb (DPlainTV n _) m = M.delete n m + go_tvb (DKindedTV n _ k) m = M.delete n m `mappend` go_ty k + + -- | Do a topological sort on a list of tyvars, + -- so that binders occur before occurrences + -- E.g. given [ a::k, k::*, b::k ] + -- it'll return a well-scoped list [ k::*, a::k, b::k ] + -- + -- This is a deterministic sorting operation + -- (that is, doesn't depend on Uniques). + -- + -- It is also meant to be stable: that is, variables should not + -- be reordered unnecessarily. + scopedSort :: [Name] -> [Name] + scopedSort = go [] [] + + go :: [Name] -- already sorted, in reverse order + -> [Set Name] -- each set contains all the variables which must be placed + -- before the tv corresponding to the set; they are accumulations + -- of the fvs in the sorted tvs' kinds + + -- This list is in 1-to-1 correspondence with the sorted tyvars + -- INVARIANT: + -- all (\tl -> all (`isSubsetOf` head tl) (tail tl)) (tails fv_list) + -- That is, each set in the list is a superset of all later sets. + -> [Name] -- yet to be sorted + -> [Name] + go acc _fv_list [] = reverse acc + go acc fv_list (tv:tvs) + = go acc' fv_list' tvs + where + (acc', fv_list') = insert tv acc fv_list + + insert :: Name -- var to insert + -> [Name] -- sorted list, in reverse order + -> [Set Name] -- list of fvs, as above + -> ([Name], [Set Name]) -- augmented lists + insert tv [] [] = ([tv], [kindFVSet tv]) + insert tv (a:as) (fvs:fvss) + | tv `S.member` fvs + , (as', fvss') <- insert tv as fvss + = (a:as', fvs `S.union` fv_tv : fvss') + + | otherwise + = (tv:a:as, fvs `S.union` fv_tv : fvs : fvss) + where + fv_tv = kindFVSet tv + + -- lists not in correspondence + insert _ _ _ = error "scopedSort" + + kindFVSet n = + maybe S.empty (OS.toSet . fvDType) + (M.lookup n varKindSigs) + ascribeWithKind n = + maybe (DPlainTV n ()) (DKindedTV n ()) (M.lookup n varKindSigs) + + in map ascribeWithKind $ + scopedSort freeVars + +-- | Take a telescope of 'DTyVarBndr's, find the free variables in their kinds, +-- and sort them in reverse topological order to ensure that they are well +-- scoped. Because the argument list is assumed to be telescoping, kind +-- variables that are bound earlier in the list are not returned. For example, +-- this: +-- +-- @ +-- 'toposortKindVarsOfTvbs' [a :: k, b :: Proxy a] +-- @ +-- +-- Will return @[k]@, not @[k, a]@, since @a@ is bound earlier by @a :: k@. +toposortKindVarsOfTvbs :: [DTyVarBndr flag] -> [DTyVarBndrUnit] +toposortKindVarsOfTvbs tvbs = + foldr (\tvb kvs -> + foldMap (\t -> toposortTyVarsOf [t]) (extractTvbKind tvb) `L.union` + L.deleteBy ((==) `on` dtvbName) tvb kvs) + [] + (changeDTVFlags () tvbs) + +dtvbName :: DTyVarBndr flag -> Name +dtvbName (DPlainTV n _) = n +dtvbName (DKindedTV n _ _) = n + +dtvbFlag :: DTyVarBndr flag -> flag +dtvbFlag (DPlainTV _ flag) = flag +dtvbFlag (DKindedTV _ flag _) = flag + +-- | Map over the 'Name' of a 'DTyVarBndr'. +mapDTVName :: (Name -> Name) -> DTyVarBndr flag -> DTyVarBndr flag +mapDTVName f (DPlainTV name flag) = DPlainTV (f name) flag +mapDTVName f (DKindedTV name flag kind) = DKindedTV (f name) flag kind + +-- | Map over the 'DKind' of a 'DTyVarBndr'. +mapDTVKind :: (DKind -> DKind) -> DTyVarBndr flag -> DTyVarBndr flag +mapDTVKind _ tvb@(DPlainTV{}) = tvb +mapDTVKind f (DKindedTV name flag kind) = DKindedTV name flag (f kind) + +-- @mk_qual_do_name mb_mod orig_name@ will simply return @orig_name@ if +-- @mb_mod@ is Nothing. If @mb_mod@ is @Just mod_@, then a new 'Name' will be +-- returned that uses @mod_@ as the new module prefix. This is useful for +-- emulating the behavior of the @QualifiedDo@ extension, which adds module +-- prefixes to functions such as ('>>=') and ('>>'). +mk_qual_do_name :: Maybe ModName -> Name -> Name +mk_qual_do_name mb_mod orig_name = case mb_mod of + Nothing -> orig_name + Just mod_ -> Name (OccName (nameBase orig_name)) (NameQ mod_) + +-- | Reconstruct an arrow 'DType' from its argument and result types. +ravelDType :: DFunArgs -> DType -> DType +ravelDType DFANil res = res +ravelDType (DFAForalls tele args) res = DForallT tele (ravelDType args res) +ravelDType (DFACxt cxt args) res = DConstrainedT cxt (ravelDType args res) +ravelDType (DFAAnon t args) res = DAppT (DAppT DArrowT t) (ravelDType args res) + +-- | Decompose a function 'DType' into its arguments (the 'DFunArgs') and its +-- result type (the 'DType). +unravelDType :: DType -> (DFunArgs, DType) +unravelDType (DForallT tele ty) = + let (args, res) = unravelDType ty in + (DFAForalls tele args, res) +unravelDType (DConstrainedT cxt ty) = + let (args, res) = unravelDType ty in + (DFACxt cxt args, res) +unravelDType (DAppT (DAppT DArrowT t1) t2) = + let (args, res) = unravelDType t2 in + (DFAAnon t1 args, res) +unravelDType t = (DFANil, t) + +-- | The list of arguments in a function 'DType'. +data DFunArgs + = DFANil + -- ^ No more arguments. + | DFAForalls DForallTelescope DFunArgs + -- ^ A series of @forall@ed type variables followed by a dot (if + -- 'ForallInvis') or an arrow (if 'ForallVis'). For example, + -- the type variables @a1 ... an@ in @forall a1 ... an. r@. + | DFACxt DCxt DFunArgs + -- ^ A series of constraint arguments followed by @=>@. For example, + -- the @(c1, ..., cn)@ in @(c1, ..., cn) => r@. + | DFAAnon DType DFunArgs + -- ^ An anonymous argument followed by an arrow. For example, the @a@ + -- in @a -> r@. + deriving (Eq, Show, Data, Generic) + +-- | A /visible/ function argument type (i.e., one that must be supplied +-- explicitly in the source code). This is in contrast to /invisible/ +-- arguments (e.g., the @c@ in @c => r@), which are instantiated without +-- the need for explicit user input. +data DVisFunArg + = DVisFADep DTyVarBndrUnit + -- ^ A visible @forall@ (e.g., @forall a -> a@). + | DVisFAAnon DType + -- ^ An anonymous argument followed by an arrow (e.g., @a -> r@). + deriving (Eq, Show, Data, Generic) + +-- | Filter the visible function arguments from a list of 'DFunArgs'. +filterDVisFunArgs :: DFunArgs -> [DVisFunArg] +filterDVisFunArgs DFANil = [] +filterDVisFunArgs (DFAForalls tele args) = + case tele of + DForallVis tvbs -> map DVisFADep tvbs ++ args' + DForallInvis _ -> args' + where + args' = filterDVisFunArgs args +filterDVisFunArgs (DFACxt _ args) = + filterDVisFunArgs args +filterDVisFunArgs (DFAAnon t args) = + DVisFAAnon t:filterDVisFunArgs args + +-- | Decompose an applied type into its individual components. For example, this: +-- +-- @ +-- Proxy \@Type Char +-- @ +-- +-- would be unfolded to this: +-- +-- @ +-- ('DConT' ''Proxy, ['DTyArg' ('DConT' ''Type), 'DTANormal' ('DConT' ''Char)]) +-- @ +unfoldDType :: DType -> (DType, [DTypeArg]) +unfoldDType = go [] + where + go :: [DTypeArg] -> DType -> (DType, [DTypeArg]) + go acc (DForallT _ ty) = go acc ty + go acc (DAppT ty1 ty2) = go (DTANormal ty2:acc) ty1 + go acc (DAppKindT ty ki) = go (DTyArg ki:acc) ty + go acc (DSigT ty _) = go acc ty + go acc ty = (ty, acc) + +-- | Extract the kind from a 'DTyVarBndr', if one is present. +extractTvbKind :: DTyVarBndr flag -> Maybe DKind +extractTvbKind (DPlainTV _ _) = Nothing +extractTvbKind (DKindedTV _ _ k) = Just k + +-- | Set the flag in a list of 'DTyVarBndr's. This is often useful in contexts +-- where one needs to re-use a list of 'DTyVarBndr's from one flag setting to +-- another flag setting. For example, in order to re-use the 'DTyVarBndr's bound +-- by a 'DDataD' in a 'DForallT', one can do the following: +-- +-- @ +-- case x of +-- 'DDataD' _ _ _ tvbs _ _ _ -> +-- 'DForallT' ('DForallInvis' ('changeDTVFlags' 'SpecifiedSpec' tvbs)) ... +-- @ +changeDTVFlags :: newFlag -> [DTyVarBndr oldFlag] -> [DTyVarBndr newFlag] +changeDTVFlags new_flag = map (new_flag <$) + +-- @'dMatchUpSAKWithDecl' decl_sak decl_bndrs@ produces @'DTyVarBndr' +-- 'ForAllTyFlag'@s for a declaration, using the original declaration's +-- standalone kind signature (@decl_sak@) and its user-written binders +-- (@decl_bndrs@) as a template. For this example: +-- +-- @ +-- type D :: forall j k. k -> j -> Type +-- data D \@j \@l (a :: l) b = ... +-- @ +-- +-- We would produce the following @'DTyVarBndr' 'ForAllTyFlag'@s: +-- +-- @ +-- \@j \@l (a :: l) (b :: j) +-- @ +-- +-- From here, these @'DTyVarBndr' 'ForAllTyFlag'@s can be converted into other +-- forms of 'DTyVarBndr's: +-- +-- * They can be converted to 'DTyVarBndrSpec's using 'dtvbForAllTyFlagsToSpecs'. +-- +-- * They can be converted to 'DTyVarBndrVis'es using 'tvbForAllTyFlagsToVis'. +-- +-- Note that: +-- +-- * This function has a precondition that the length of @decl_bndrs@ must +-- always be equal to the number of visible quantifiers (i.e., the number of +-- function arrows plus the number of visible @forall@–bound variables) in +-- @decl_sak@. +-- +-- * Whenever possible, this function reuses type variable names from the +-- declaration's user-written binders. This is why the @'DTyVarBndr' +-- 'ForAllTyFlag'@ use @\@j \@l@ instead of @\@j \@k@, since the @(a :: l)@ +-- binder uses @l@ instead of @k@. We could have just as well chose the other +-- way around, but we chose to pick variable names from the user-written +-- binders since they scope over other parts of the declaration. (For example, +-- the user-written binders of a @data@ declaration scope over the type +-- variables mentioned in a @deriving@ clause.) As such, keeping these names +-- avoids having to perform some alpha-renaming. +-- +-- This function's implementation was heavily inspired by parts of GHC's +-- kcCheckDeclHeader_sig function: +-- https://gitlab.haskell.org/ghc/ghc/-/blob/1464a2a8de082f66ae250d63ab9d94dbe2ef8620/compiler/GHC/Tc/Gen/HsType.hs#L2524-2643 +dMatchUpSAKWithDecl :: + forall q. + Fail.MonadFail q + => DKind + -- ^ The declaration's standalone kind signature + -> [DTyVarBndrVis] + -- ^ The user-written binders in the declaration + -> q [DTyVarBndr ForAllTyFlag] +dMatchUpSAKWithDecl decl_sak decl_bndrs = do + -- (1) First, explicitly quantify any free kind variables in `decl_sak` using + -- an invisible @forall@. This is done to ensure that precondition (2) in + -- `dMatchUpSigWithDecl` is upheld. (See the Haddocks for that function). + let decl_sak_free_tvbs = + changeDTVFlags SpecifiedSpec $ toposortTyVarsOf [decl_sak] + decl_sak' = DForallT (DForallInvis decl_sak_free_tvbs) decl_sak + + -- (2) Next, compute type variable binders using `dMatchUpSigWithDecl`. Note + -- that these can be biased towards type variable names mention in `decl_sak` + -- over names mentioned in `decl_bndrs`, but we will fix that up in the next + -- step. + let (decl_sak_args, _) = unravelDType decl_sak' + sing_sak_tvbs <- dMatchUpSigWithDecl decl_sak_args decl_bndrs + + -- (3) Finally, swizzle the type variable names so that names in `decl_bndrs` + -- are preferred over names in `decl_sak`. + -- + -- This is heavily inspired by similar code in GHC: + -- https://gitlab.haskell.org/ghc/ghc/-/blob/cec903899234bf9e25ea404477ba846ac1e963bb/compiler/GHC/Tc/Gen/HsType.hs#L2607-2616 + let invis_decl_sak_args = filterInvisTvbArgs decl_sak_args + invis_decl_sak_arg_nms = map dtvbName invis_decl_sak_args + + invis_decl_bndrs = toposortKindVarsOfTvbs decl_bndrs + invis_decl_bndr_nms = map dtvbName invis_decl_bndrs + + swizzle_env = + M.fromList $ zip invis_decl_sak_arg_nms invis_decl_bndr_nms + (_, swizzled_sing_sak_tvbs) = + mapAccumL (swizzleTvb swizzle_env) M.empty sing_sak_tvbs + pure swizzled_sing_sak_tvbs + +-- Match the quantifiers in a type-level declaration's standalone kind signature +-- with the user-written binders in the declaration. This function assumes the +-- following preconditions: +-- +-- 1. The number of required binders in the declaration's user-written binders +-- is equal to the number of visible quantifiers (i.e., the number of +-- function arrows plus the number of visible @forall@–bound variables) in +-- the standalone kind signature. +-- +-- 2. The number of invisible \@-binders in the declaration's user-written +-- binders is less than or equal to the number of invisible quantifiers +-- (i.e., the number of invisible @forall@–bound variables) in the +-- standalone kind signature. +-- +-- The implementation of this function is heavily based on a GHC function of +-- the same name: +-- https://gitlab.haskell.org/ghc/ghc/-/blob/1464a2a8de082f66ae250d63ab9d94dbe2ef8620/compiler/GHC/Tc/Gen/HsType.hs#L2645-2715 +dMatchUpSigWithDecl :: + forall q. + Fail.MonadFail q + => DFunArgs + -- ^ The quantifiers in the declaration's standalone kind signature + -> [DTyVarBndrVis] + -- ^ The user-written binders in the declaration + -> q [DTyVarBndr ForAllTyFlag] +dMatchUpSigWithDecl = go_fun_args M.empty + where + go_fun_args :: + DSubst + -- ^ A substitution from the names of @forall@-bound variables in the + -- standalone kind signature to corresponding binder names in the + -- user-written binders. This is because we want to reuse type variable + -- names from the user-written binders whenever possible. For example: + -- + -- @ + -- type T :: forall a. forall b -> Maybe (a, b) -> Type + -- data T @x y z + -- @ + -- + -- After matching up the @a@ in @forall a.@ with @x@ and + -- the @b@ in @forall b ->@ with @y@, this substitution will be + -- extended with @[a :-> x, b :-> y]@. This ensures that we will + -- produce @Maybe (x, y)@ instead of @Maybe (a, b)@ in + -- the kind for @z@. + -> DFunArgs -> [DTyVarBndrVis] -> q [DTyVarBndr ForAllTyFlag] + go_fun_args _ DFANil [] = + pure [] + -- This should not happen, per precondition (1). + go_fun_args _ DFANil decl_bndrs = + fail $ "dMatchUpSigWithDecl.go_fun_args: Too many binders: " ++ show decl_bndrs + -- GHC now disallows kind-level constraints, per this GHC proposal: + -- https://github.com/ghc-proposals/ghc-proposals/blob/b0687d96ce8007294173b7f628042ac4260cc738/proposals/0547-no-kind-equalities.rst + -- As such, we reject non-empty kind contexts. Empty contexts (which are + -- benign) can sometimes arise due to @ForallT@, so we add a special case + -- to allow them. + go_fun_args subst (DFACxt [] args) decl_bndrs = + go_fun_args subst args decl_bndrs + go_fun_args _ (DFACxt{}) _ = + fail "dMatchUpSigWithDecl.go_fun_args: Unexpected kind-level constraint" + go_fun_args subst (DFAForalls (DForallInvis tvbs) sig_args) decl_bndrs = + go_invis_tvbs subst tvbs sig_args decl_bndrs + go_fun_args subst (DFAForalls (DForallVis tvbs) sig_args) decl_bndrs = + go_vis_tvbs subst tvbs sig_args decl_bndrs + go_fun_args subst (DFAAnon anon sig_args) (decl_bndr:decl_bndrs) = + case dtvbFlag decl_bndr of + -- If the next decl_bndr is required, then we must match its kind (if + -- one is provided) against the anonymous kind argument. + BndrReq -> do + let decl_bndr_name = dtvbName decl_bndr + mb_decl_bndr_kind = extractTvbKind decl_bndr + anon' = SC.substTy subst anon + + anon'' = + case mb_decl_bndr_kind of + Nothing -> anon' + Just decl_bndr_kind -> + let mb_match_subst = matchTy NoIgnore decl_bndr_kind anon' in + maybe decl_bndr_kind (`SC.substTy` decl_bndr_kind) mb_match_subst + sig_args' <- go_fun_args subst sig_args decl_bndrs + pure $ DKindedTV decl_bndr_name Required anon'' : sig_args' + -- We have a visible, anonymous argument in the kind, but an invisible + -- @-binder as the next decl_bndr. This is ill kinded, so throw an + -- error. + -- + -- This should not happen, per precondition (2). + BndrInvis -> + fail $ "dMatchUpSigWithDecl.go_fun_args: Expected visible binder, encountered invisible binder: " + ++ show decl_bndr + -- This should not happen, per precondition (1). + go_fun_args _ _ [] = + fail "dMatchUpSigWithDecl.go_fun_args: Too few binders" + + go_invis_tvbs :: DSubst -> [DTyVarBndrSpec] -> DFunArgs -> [DTyVarBndrVis] -> q [DTyVarBndr ForAllTyFlag] + go_invis_tvbs subst [] sig_args decl_bndrs = + go_fun_args subst sig_args decl_bndrs + go_invis_tvbs subst (invis_tvb:invis_tvbs) sig_args decl_bndrss = + case decl_bndrss of + [] -> skip_invis_bndr + decl_bndr:decl_bndrs -> + case dtvbFlag decl_bndr of + BndrReq -> skip_invis_bndr + -- If the next decl_bndr is an invisible @-binder, then we must match it + -- against the invisible forall–bound variable in the kind. + BndrInvis -> do + let (subst', sig_tvb) = match_tvbs subst invis_tvb decl_bndr + sig_args' <- go_invis_tvbs subst' invis_tvbs sig_args decl_bndrs + pure (fmap Invisible sig_tvb : sig_args') + where + -- There is an invisible forall in the kind without a corresponding + -- invisible @-binder, which is allowed. In this case, we simply apply + -- the substitution and recurse. + skip_invis_bndr :: q [DTyVarBndr ForAllTyFlag] + skip_invis_bndr = do + let (subst', invis_tvb') = SC.substTyVarBndr subst invis_tvb + sig_args' <- go_invis_tvbs subst' invis_tvbs sig_args decl_bndrss + pure $ fmap Invisible invis_tvb' : sig_args' + + go_vis_tvbs :: DSubst -> [DTyVarBndrUnit] -> DFunArgs -> [DTyVarBndrVis] -> q [DTyVarBndr ForAllTyFlag] + go_vis_tvbs subst [] sig_args decl_bndrs = + go_fun_args subst sig_args decl_bndrs + -- This should not happen, per precondition (1). + go_vis_tvbs _ (_:_) _ [] = + fail "dMatchUpSigWithDecl.go_vis_tvbs: Too few binders" + go_vis_tvbs subst (vis_tvb:vis_tvbs) sig_args (decl_bndr:decl_bndrs) = do + case dtvbFlag decl_bndr of + -- If the next decl_bndr is required, then we must match it against the + -- visible forall–bound variable in the kind. + BndrReq -> do + let (subst', sig_tvb) = match_tvbs subst vis_tvb decl_bndr + sig_args' <- go_vis_tvbs subst' vis_tvbs sig_args decl_bndrs + pure ((Required <$ sig_tvb) : sig_args') + -- We have a visible forall in the kind, but an invisible @-binder as + -- the next decl_bndr. This is ill kinded, so throw an error. + -- + -- This should not happen, per precondition (2). + BndrInvis -> + fail $ "dMatchUpSigWithDecl.go_vis_tvbs: Expected visible binder, encountered invisible binder: " + ++ show decl_bndr + + -- @match_tvbs subst sig_tvb decl_bndr@ will match the kind of @decl_bndr@ + -- against the kind of @sig_tvb@ to produce a new kind. This function + -- produces two values as output: + -- + -- 1. A new @subst@ that has been extended such that the name of @sig_tvb@ + -- maps to the name of @decl_bndr@. (See the Haddocks for the 'DSubst' + -- argument to @go_fun_args@ for an explanation of why we do this.) + -- + -- 2. A 'DTyVarBndrSpec' that has the name of @decl_bndr@, but with the new + -- kind resulting from matching. + match_tvbs :: DSubst -> DTyVarBndr flag -> DTyVarBndrVis -> (DSubst, DTyVarBndr flag) + match_tvbs subst sig_tvb decl_bndr = + let decl_bndr_name = dtvbName decl_bndr + mb_decl_bndr_kind = extractTvbKind decl_bndr + + sig_tvb_name = dtvbName sig_tvb + sig_tvb_flag = dtvbFlag sig_tvb + mb_sig_tvb_kind = SC.substTy subst <$> extractTvbKind sig_tvb + + mb_kind :: Maybe DKind + mb_kind = + case (mb_decl_bndr_kind, mb_sig_tvb_kind) of + (Nothing, Nothing) -> Nothing + (Just decl_bndr_kind, Nothing) -> Just decl_bndr_kind + (Nothing, Just sig_tvb_kind) -> Just sig_tvb_kind + (Just decl_bndr_kind, Just sig_tvb_kind) -> do + match_subst <- matchTy NoIgnore decl_bndr_kind sig_tvb_kind + Just $ SC.substTy match_subst decl_bndr_kind + + subst' = M.insert sig_tvb_name (DVarT decl_bndr_name) subst + sig_tvb' = case mb_kind of + Nothing -> DPlainTV decl_bndr_name sig_tvb_flag + Just kind -> DKindedTV decl_bndr_name sig_tvb_flag kind in + + (subst', sig_tvb') + +-- Collect the invisible type variable binders from a sequence of DFunArgs. +filterInvisTvbArgs :: DFunArgs -> [DTyVarBndrSpec] +filterInvisTvbArgs DFANil = [] +filterInvisTvbArgs (DFACxt _ args) = filterInvisTvbArgs args +filterInvisTvbArgs (DFAAnon _ args) = filterInvisTvbArgs args +filterInvisTvbArgs (DFAForalls tele args) = + let res = filterInvisTvbArgs args in + case tele of + DForallVis _ -> res + DForallInvis tvbs' -> tvbs' ++ res + +-- This is heavily inspired by the `swizzleTcb` function in GHC: +-- https://gitlab.haskell.org/ghc/ghc/-/blob/cec903899234bf9e25ea404477ba846ac1e963bb/compiler/GHC/Tc/Gen/HsType.hs#L2741-2755 +swizzleTvb :: + Map Name Name + -- ^ A \"swizzle environment\" (i.e., a map from binder names in a + -- standalone kind signature to binder names in the corresponding + -- type-level declaration). + -> DSubst + -- ^ Like the swizzle environment, but as a full-blown substitution. + -> DTyVarBndr flag + -> (DSubst, DTyVarBndr flag) +swizzleTvb swizzle_env subst tvb = + (subst', tvb2) + where + subst' = M.insert tvb_name (DVarT (dtvbName tvb2)) subst + tvb_name = dtvbName tvb + tvb1 = mapDTVKind (SC.substTy subst) tvb + tvb2 = + case M.lookup tvb_name swizzle_env of + Just user_name -> mapDTVName (const user_name) tvb1 + Nothing -> tvb1 + +-- | Convert a list of @'DTyVarBndr' 'ForAllTyFlag'@s to a list of +-- 'DTyVarBndrSpec's, which is suitable for use in an invisible @forall@. +-- Specifically: +-- +-- * Variable binders that use @'Invisible' spec@ are converted to @spec@. +-- +-- * Variable binders that are 'Required' are converted to 'SpecifiedSpec', +-- as all of the 'DTyVarBndrSpec's are invisible. As an example of how this +-- is used, consider what would happen when singling this data type: +-- +-- @ +-- type T :: forall k -> k -> Type +-- data T k (a :: k) where ... +-- @ +-- +-- Here, the @k@ binder is 'Required'. When we produce the standalone kind +-- signature for the singled data type, we use 'dtvbForAllTyFlagsToSpecs' to +-- produce the type variable binders in the outermost @forall@: +-- +-- @ +-- type ST :: forall k (a :: k). T k a -> Type +-- data ST z where ... +-- @ +-- +-- Note that the @k@ is bound visibily (i.e., using 'SpecifiedSpec') in the +-- outermost, invisible @forall@. +dtvbForAllTyFlagsToSpecs :: [DTyVarBndr ForAllTyFlag] -> [DTyVarBndrSpec] +dtvbForAllTyFlagsToSpecs = map (fmap to_spec) + where + to_spec :: ForAllTyFlag -> Specificity + to_spec (Invisible spec) = spec + to_spec Required = SpecifiedSpec + +-- | Convert a list of @'DTyVarBndr' 'ForAllTyFlag'@s to a list of +-- 'DTyVarBndrVis'es, which is suitable for use in a type-level declaration +-- (e.g., the @var_1 ... var_n@ in @class C var_1 ... var_n@). Specifically: +-- +-- * Variable binders that use @'Invisible' 'InferredSpec'@ are dropped +-- entirely. Such binders cannot be represented in source Haskell. +-- +-- * Variable binders that use @'Invisible' 'SpecifiedSpec'@ are converted to +-- 'BndrInvis'. +-- +-- * Variable binders that are 'Required' are converted to 'BndrReq'. +dtvbForAllTyFlagsToBndrVis :: [DTyVarBndr ForAllTyFlag] -> [DTyVarBndrVis] +dtvbForAllTyFlagsToBndrVis = catMaybes . map (traverse to_spec_maybe) + where + to_spec_maybe :: ForAllTyFlag -> Maybe BndrVis + to_spec_maybe (Invisible InferredSpec) = Nothing + to_spec_maybe (Invisible SpecifiedSpec) = Just bndrInvis + to_spec_maybe Required = Just BndrReq + +-- | Some functions in this module only use certain arguments on particular +-- versions of GHC. Other versions of GHC (that don't make use of those +-- arguments) might need to conjure up those arguments out of thin air at the +-- functions' call sites, so this function serves as a placeholder to use in +-- those situations. (In other words, this is a slightly more informative +-- version of 'undefined'.) +unusedArgument :: a +unusedArgument = error "Unused" + +{- +Note [Desugaring and sweetening ForallT] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The ForallT constructor from template-haskell is tremendously awkward. Because +ForallT contains both a list of type variable binders and constraint arguments, +ForallT expressions can be ambiguous when one of these lists is empty. For +example, consider this expression with no constraints: + + ForallT [PlainTV a] [] (VarT a) + +What should this desugar to in th-desugar, which must maintain a clear +separation between type variable binders and constraints? There are two +possibilities: + +1. DForallT DForallInvis [DPlainTV a] (DVarT a) + (i.e., forall a. a) +2. DForallT DForallInvis [DPlainTV a] (DConstrainedT [] (DVarT a)) + (i.e., forall a. () => a) + +Template Haskell generally drops these empty lists when splicing Template +Haskell expressions, so we would like to do the same in th-desugar to mimic +TH's behavior as closely as possible. However, there are some situations where +dropping empty lists of `forall`ed type variable binders can change the +semantics of a program. For instance, contrast `foo :: forall. a -> a` (which +is an error) with `foo :: a -> a` (which is fine). Therefore, we try to +preserve empty `forall`s to the best of our ability. + +Here is an informal specification of how th-desugar should handle different sorts +of ambiguity. First, a specification for desugaring. +Let `tvbs` and `ctxt` be non-empty: + +* `ForallT tvbs [] ty` should desugar to `DForallT DForallInvis tvbs ty`. +* `ForallT [] ctxt ty` should desguar to `DForallT DForallInvis [] (DConstrainedT ctxt ty)`. +* `ForallT [] [] ty` should desugar to `DForallT DForallInvis [] ty`. +* For all other cases, just straightforwardly desugar + `ForallT tvbs ctxt ty` to `DForallT DForallInvis tvbs (DConstraintedT ctxt ty)`. + +For sweetening: + +* `DForallT DForallInvis tvbs (DConstrainedT ctxt ty)` should sweeten to `ForallT tvbs ctxt ty`. +* `DForallT DForallInvis [] (DConstrainedT ctxt ty)` should sweeten to `ForallT [] ctxt ty`. +* `DForallT DForallInvis tvbs (DConstrainedT [] ty)` should sweeten to `ForallT tvbs [] ty`. +* `DForallT DForallInvis [] (DConstrainedT [] ty)` should sweeten to `ForallT [] [] ty`. +* For all other cases, just straightforwardly sweeten + `DForallT DForallInvis tvbs ty` to `ForallT tvbs [] ty` and + `DConstrainedT ctxt ty` to `ForallT [] ctxt ty`. -} diff --git a/Language/Haskell/TH/Desugar/FV.hs b/Language/Haskell/TH/Desugar/FV.hs --- a/Language/Haskell/TH/Desugar/FV.hs +++ b/Language/Haskell/TH/Desugar/FV.hs @@ -41,18 +41,21 @@ -- | Extract the term variables bound by a 'DPat'. -- --- This does /not/ extract any type variables bound by pattern signatures. +-- This does /not/ extract any type variables bound by pattern signatures, +-- constructor patterns, or type patterns. extractBoundNamesDPat :: DPat -> OSet Name extractBoundNamesDPat = go where go :: DPat -> OSet Name - go (DLitP _) = OS.empty - go (DVarP n) = OS.singleton n - go (DConP _ tys pats) = foldMap fvDType tys <> foldMap go pats - go (DTildeP p) = go p - go (DBangP p) = go p - go (DSigP p _) = go p - go DWildP = OS.empty + go (DLitP _) = OS.empty + go (DVarP n) = OS.singleton n + go (DConP _ _ pats) = foldMap go pats + go (DTildeP p) = go p + go (DBangP p) = go p + go (DSigP p _) = go p + go DWildP = OS.empty + go (DTypeP _) = OS.empty + go (DInvisP _) = OS.empty ----- -- Binding forms 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 @@ -7,36 +7,12 @@ -- Stability : experimental -- Portability : non-portable -- --- Defines @Lift@ instances for the desugared language. This is defined --- in a separate module because it also must define @Lift@ instances for --- several TH types, which are orphans and may want another definition --- downstream. +-- Historically, this module defined orphan @Lift@ instances for the data types +-- in @th-desugar@. Nowadays, these instances are defined alongside the data +-- types themselves, so this module simply re-exports the instances. -- ---------------------------------------------------------------------------- -{-# LANGUAGE CPP, TemplateHaskell #-} -{-# OPTIONS_GHC -Wno-orphans #-} - module Language.Haskell.TH.Desugar.Lift () where -import Language.Haskell.TH.Desugar -import Language.Haskell.TH.Instances () -import Language.Haskell.TH.Lift - -$(deriveLiftMany [ ''DExp, ''DPat, ''DType, ''DForallTelescope, ''DTyVarBndr - , ''DMatch, ''DClause, ''DLetDec, ''DDec, ''DDerivClause, ''DCon - , ''DConFields, ''DForeign, ''DPragma, ''DRuleBndr, ''DTySynEqn - , ''DPatSynDir , ''NewOrData, ''DDerivStrategy - , ''DTypeFamilyHead, ''DFamilyResultSig -#if __GLASGOW_HASKELL__ < 801 - , ''PatSynArgs -#endif -#if __GLASGOW_HASKELL__ < 900 - , ''Specificity -#endif - - , ''TypeArg, ''DTypeArg - , ''FunArgs, ''DFunArgs - , ''VisFunArg, ''DVisFunArg - , ''ForallTelescope - ]) +import Language.Haskell.TH.Desugar () diff --git a/Language/Haskell/TH/Desugar/Match.hs b/Language/Haskell/TH/Desugar/Match.hs --- a/Language/Haskell/TH/Desugar/Match.hs +++ b/Language/Haskell/TH/Desugar/Match.hs @@ -20,6 +20,8 @@ import Data.Data import qualified Data.Foldable as F import Data.Generics +import qualified Data.List.NonEmpty as NE +import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.Set as S import qualified Data.Map as Map import Language.Haskell.TH.Instances () @@ -38,41 +40,62 @@ -- a 'DLitPa', or a 'DWildPa'. scExp :: DsMonad q => DExp -> q DExp scExp (DAppE e1 e2) = DAppE <$> scExp e1 <*> scExp e2 -scExp (DLamE names exp) = DLamE names <$> scExp exp -scExp (DCaseE scrut matches) - | DVarE name <- scrut - = simplCaseExp [name] clauses - | otherwise - = do scrut_name <- newUniqueName "scrut" - case_exp <- simplCaseExp [scrut_name] clauses - return $ DLetE [DValD (DVarP scrut_name) scrut] case_exp - where - clauses = map match_to_clause matches - match_to_clause (DMatch pat exp) = DClause [pat] exp - +scExp (DLamCasesE clauses) = do + -- Per the Haddocks for DLamCasesE, an empty list of clauses indicates that + -- the overall `\cases` expression takes one argument. Otherwise, we look at + -- the first clause to see how many arguments the expression takes, as each + -- clause is required to have the same number of patterns. + let num_args = + case clauses of + [] -> 1 + DClause pats _ : _ -> length pats + clause' <- scClauses num_args clauses + pure $ DLamCasesE [clause'] scExp (DLetE decs body) = DLetE <$> mapM scLetDec decs <*> scExp body scExp (DSigE exp ty) = DSigE <$> scExp exp <*> pure ty scExp (DAppTypeE exp ty) = DAppTypeE <$> scExp exp <*> pure ty +scExp (DTypedBracketE exp) = DTypedBracketE <$> scExp exp +scExp (DTypedSpliceE exp) = DTypedSpliceE <$> scExp exp +scExp (DForallE tele exp) = DForallE tele <$> scExp exp +scExp (DConstrainedE cxt exp) = DConstrainedE <$> mapM scExp cxt <*> scExp exp scExp e@(DVarE {}) = return e scExp e@(DConE {}) = return e scExp e@(DLitE {}) = return e scExp e@(DStaticE {}) = return e +scExp e@(DTypeE {}) = return e -- | Like 'scExp', but for a 'DLetDec'. scLetDec :: DsMonad q => DLetDec -> q DLetDec -scLetDec (DFunD name clauses@(DClause pats1 _ : _)) = do - arg_names <- mapM (const (newUniqueName "_arg")) pats1 - clauses' <- mapM sc_clause_rhs clauses - case_exp <- simplCaseExp arg_names clauses' - return $ DFunD name [DClause (map DVarP arg_names) case_exp] - where - sc_clause_rhs (DClause pats exp) = DClause pats <$> scExp exp +scLetDec (DFunD name clauses) = do + -- `DFunD`s are expected to have a non-empty list of clauses where each clause + -- has a number of patterns equal to the number of arguments. + let num_args = + case clauses of + [] -> error $ "The `" ++ nameBase name ++ + "` function has no clauses -- should never happen" + DClause pats _ : _ -> length pats + clause' <- scClauses num_args clauses + pure $ DFunD name [clause'] scLetDec (DValD pat exp) = DValD pat <$> scExp exp scLetDec (DPragmaD prag) = DPragmaD <$> scLetPragma prag scLetDec dec@(DSigD {}) = return dec scLetDec dec@(DInfixD {}) = return dec -scLetDec dec@(DFunD _ []) = return dec +-- | Convert a list of 'DClause's into a single 'DClause', where the right-hand +-- side of the output 'DClause' matches on all of the patterns of the input +-- 'DClause's without using nested pattern matching. +scClauses :: + DsMonad q + => Int -- ^ The number of arguments in each 'DClause'. + -> [DClause] -> q DClause +scClauses num_args clauses = do + arg_names <- replicateM num_args (newUniqueName "_arg") + clauses' <- mapM sc_clause_rhs clauses + case_exp <- simplCaseExp arg_names clauses' + pure $ DClause (map DVarP arg_names) case_exp + where + sc_clause_rhs (DClause pats exp) = DClause pats <$> scExp exp + scLetPragma :: DsMonad q => DPragma -> q DPragma scLetPragma = topEverywhereM scExp -- Only topEverywhereM because scExp already recurses on its own @@ -89,11 +112,17 @@ -> [DClause] -> q DExp simplCaseExp vars clauses = - do let eis = [ EquationInfo pats (\_ -> rhs) | + do let eis = [ EquationInfo (to_ne_pats pats) (\_ -> rhs) | DClause pats rhs <- clauses ] matchResultToDExp `liftM` simplCase vars eis + where + to_ne_pats :: [DPat] -> NonEmpty DPat + to_ne_pats pats = + case pats of + p:ps -> p:|ps + [] -> error "Clause encountered with no patterns -- should never happen" -data EquationInfo = EquationInfo [DPat] MatchResult -- like DClause, but with a hole +data EquationInfo = EquationInfo (NonEmpty DPat) MatchResult -- like DClause, but with a hole -- analogous to GHC's match (in deSugar/Match.lhs) simplCase :: DsMonad q @@ -103,35 +132,35 @@ simplCase [] clauses = return (foldr1 (.) match_results) where match_results = [ mr | EquationInfo _ mr <- clauses ] -simplCase vars@(v:_) clauses = do +simplCase (v:vs) clauses = do (aux_binds, tidy_clauses) <- mapAndUnzipM (tidyClause v) clauses let grouped = groupClauses tidy_clauses match_results <- match_groups grouped return (adjustMatchResult (foldr (.) id aux_binds) $ foldr1 (.) match_results) where - match_groups :: DsMonad q => [[(PatGroup, EquationInfo)]] -> q [MatchResult] + match_groups :: DsMonad q => [NonEmpty (PatGroup, EquationInfo)] -> q [MatchResult] match_groups [] = matchEmpty v match_groups gs = mapM match_group gs - match_group :: DsMonad q => [(PatGroup, EquationInfo)] -> q MatchResult - match_group [] = error "Internal error in th-desugar (match_group)" - match_group eqns@((group,_) : _) = + match_group :: DsMonad q => NonEmpty (PatGroup, EquationInfo) -> q MatchResult + match_group eqns@((group,_) :| _) = case group of - PgCon _ -> matchConFamily vars (subGroup [(c,e) | (PgCon c, e) <- eqns]) - PgLit _ -> matchLiterals vars (subGroup [(l,e) | (PgLit l, e) <- eqns]) - PgBang -> matchBangs vars (drop_group eqns) - PgAny -> matchVariables vars (drop_group eqns) + PgCon _ -> matchConFamily vars $ subGroup [(c,e) | (PgCon c, e) <- NE.toList eqns] + PgLit _ -> matchLiterals vars $ subGroup [(l,e) | (PgLit l, e) <- NE.toList eqns] + PgBang -> matchBangs vars $ drop_group eqns + PgAny -> matchVariables vars $ drop_group eqns - drop_group = map snd + drop_group :: NonEmpty (PatGroup, EquationInfo) -> NonEmpty EquationInfo + drop_group = fmap snd + vars = v:|vs + -- analogous to GHC's tidyEqnInfo tidyClause :: DsMonad q => Name -> EquationInfo -> q (DExp -> DExp, EquationInfo) -tidyClause _ (EquationInfo [] _) = - error "Internal error in th-desugar: no patterns in tidyClause." -tidyClause v (EquationInfo (pat : pats) body) = do +tidyClause v (EquationInfo (pat :| pats) body) = do (wrap, pat') <- tidy1 v pat - return (wrap, EquationInfo (pat' : pats) body) + return (wrap, EquationInfo (pat' :| pats) body) tidy1 :: DsMonad q => Name -- the name of the variable that ... @@ -152,6 +181,8 @@ DBangP p -> tidy1 v (DBangP p) -- discard ! under ! DSigP p _ -> tidy1 v (DBangP p) -- discard sig under ! DWildP -> return (id, DBangP pat) -- no change + DTypeP _ -> return (id, DBangP pat) -- no change + DInvisP _ -> return (id, DBangP pat) -- no change tidy1 v (DSigP pat ty) | no_tyvars_ty ty = tidy1 v pat -- The match-flattener doesn't know how to deal with patterns that mention @@ -168,13 +199,42 @@ no_tyvar_ty (DVarT{}) = False no_tyvar_ty t = gmapQl (&&) True no_tyvars_ty t tidy1 _ DWildP = return (id, DWildP) +tidy1 _ (DTypeP ty) = return (id, DTypeP ty) +tidy1 _ (DInvisP ty) = return (id, DInvisP ty) wrapBind :: Name -> Name -> DExp -> DExp wrapBind new old | new == old = id | otherwise = DLetE [DValD (DVarP new) (DVarE old)] --- like GHC's mkSelectorBinds +-- | Desugar a lazy pattern that bind multiple variables to code that extracts +-- fields from tuples. For instance, this: +-- +-- @ +-- data Pair a b = MkPair a b +-- +-- f :: Pair a b -> Pair b a +-- f ~(MkPair x y) = MkPair y x +-- @ +-- +-- Desugars to this (roughly) when match-flattened: +-- +-- @ +-- f :: Pair a b -> Pair b a +-- f p = +-- let tuple = case p of +-- MkPair x y -> (x, y) +-- +-- x = case tuple of +-- (x, _) -> x +-- +-- y = case tuple of +-- (_, y) -> x +-- +-- in MkPair y x +-- @ +-- +-- This takes heavy inspiration from GHC's own @mkSelectorBinds@ function. mkSelectorDecs :: DsMonad q => DPat -- pattern to deconstruct -> Name -- variable being matched against @@ -184,10 +244,10 @@ | OS.null binders = return [] - | OS.size binders == 1 + | [binder] <- F.toList binders = do val_var <- newUniqueName "var" err_var <- newUniqueName "err" - bind <- mk_bind val_var err_var (head $ F.toList binders) + bind <- mk_bind val_var err_var binder return [DValD (DVarP val_var) (DVarE name), DValD (DVarP err_var) (DVarE 'error `DAppE` (DLitE $ StringL "Irrefutable match failed")), @@ -212,7 +272,7 @@ -> q DExp mk_projection tup_name i = do var_name <- newUniqueName "proj" - return $ DCaseE (DVarE tup_name) [DMatch (DConP (tupleDataName tuple_size) [] (mk_tuple_pats var_name i)) + return $ dCaseE (DVarE tup_name) [DMatch (DConP (tupleDataName tuple_size) [] (mk_tuple_pats var_name i)) (DVarE var_name)] mk_tuple_pats :: Name -- of the projected element @@ -221,7 +281,7 @@ mk_tuple_pats elt_name i = replicate i DWildP ++ DVarP elt_name : replicate (tuple_size - i - 1) DWildP mk_bind scrut_var err_var bndr_var = do - rhs_mr <- simplCase [scrut_var] [EquationInfo [pat] (\_ -> DVarE bndr_var)] + rhs_mr <- simplCase [scrut_var] [EquationInfo (pat:|[]) (\_ -> DVarE bndr_var)] return (DValD (DVarP bndr_var) (rhs_mr (DVarE err_var))) data PatGroup @@ -231,9 +291,9 @@ | PgBang -- like GHC's groupEquations -groupClauses :: [EquationInfo] -> [[(PatGroup, EquationInfo)]] +groupClauses :: [EquationInfo] -> [NonEmpty (PatGroup, EquationInfo)] groupClauses clauses - = runs same_gp [(patGroup (firstPat clause), clause) | clause <- clauses] + = NE.groupBy same_gp [(patGroup (firstPat clause), clause) | clause <- clauses] where same_gp :: (PatGroup, EquationInfo) -> (PatGroup, EquationInfo) -> Bool (pg1,_) `same_gp` (pg2,_) = pg1 `sameGroup` pg2 @@ -246,6 +306,8 @@ patGroup (DBangP {}) = PgBang patGroup (DSigP{}) = error "Internal error in th-desugar (patGroup DSigP)" patGroup DWildP = PgAny +patGroup (DTypeP {}) = PgAny +patGroup (DInvisP {}) = PgAny sameGroup :: PatGroup -> PatGroup -> Bool sameGroup PgAny PgAny = True @@ -254,18 +316,20 @@ sameGroup (PgLit _) (PgLit _) = True sameGroup _ _ = False -subGroup :: Ord a => [(a, EquationInfo)] -> [[EquationInfo]] +-- Precondition: the input list contains at least one element. +subGroup :: Ord a => [(a, EquationInfo)] -> NonEmpty (NonEmpty EquationInfo) subGroup group - = map reverse $ Map.elems $ foldl accumulate Map.empty group + = case map NE.reverse $ Map.elems $ foldl accumulate Map.empty group of + e:es -> e:|es + [] -> error "Internal error in th-desugar (subGroup)" where accumulate pg_map (pg, eqn) = case Map.lookup pg pg_map of - Just eqns -> Map.insert pg (eqn:eqns) pg_map - Nothing -> Map.insert pg [eqn] pg_map + Just eqns -> Map.insert pg (NE.cons eqn eqns) pg_map + Nothing -> Map.insert pg (eqn :| []) pg_map firstPat :: EquationInfo -> DPat -firstPat (EquationInfo (pat : _) _) = pat -firstPat _ = error "Clause encountered with no patterns -- should never happen" +firstPat (EquationInfo (pat :| _) _) = pat data CaseAlt = CaseAlt { alt_con :: Name -- con name , _alt_args :: [Name] -- bound var names @@ -273,15 +337,14 @@ } -- from GHC's MatchCon.lhs -matchConFamily :: DsMonad q => [Name] -> [[EquationInfo]] -> q MatchResult -matchConFamily (var:vars) groups +matchConFamily :: DsMonad q => NonEmpty Name -> NonEmpty (NonEmpty EquationInfo) -> q MatchResult +matchConFamily (var:|vars) groups = do alts <- mapM (matchOneCon vars) groups mkDataConCase var alts -matchConFamily [] _ = error "Internal error in th-desugar (matchConFamily)" -- like matchOneConLike from MatchCon -matchOneCon :: DsMonad q => [Name] -> [EquationInfo] -> q CaseAlt -matchOneCon vars eqns@(eqn1 : _) +matchOneCon :: DsMonad q => [Name] -> NonEmpty EquationInfo -> q CaseAlt +matchOneCon vars eqns@(eqn1 :| _) = do arg_vars <- selectMatchVars (pat_args pat1) match_result <- match_group arg_vars @@ -297,19 +360,27 @@ match_group :: DsMonad q => [Name] -> q MatchResult match_group arg_vars - = simplCase (arg_vars ++ vars) (map shift eqns) + = simplCase (arg_vars ++ vars) $ NE.toList $ fmap shift eqns - shift (EquationInfo (DConP _ _ args : pats) exp) = EquationInfo (args ++ pats) exp + shift (EquationInfo (DConP _ _ args :| pats) exp) + = EquationInfo (to_ne_pats (args ++ pats)) exp shift _ = error "Internal error in th-desugar (shift)" -matchOneCon _ _ = error "Internal error in th-desugar (matchOneCon)" -mkDataConCase :: DsMonad q => Name -> [CaseAlt] -> q MatchResult + to_ne_pats :: [DPat] -> NonEmpty DPat + to_ne_pats pats = + case pats of + p:ps -> p:|ps + [] -> error "Internal error in th-desugar (matchOneCon.to_ne_pats)" + +mkDataConCase :: DsMonad q => Name -> NonEmpty CaseAlt -> q MatchResult mkDataConCase var case_alts = do - all_ctors <- get_all_ctors (alt_con $ head case_alts) + all_ctors <- get_all_ctors (alt_con $ NE.head case_alts) return $ \fail -> - let matches = map (mk_alt fail) case_alts in - DCaseE (DVarE var) (matches ++ mk_default all_ctors fail) + let matches = fmap (mk_alt fail) case_alt_list in + dCaseE (DVarE var) (matches ++ mk_default all_ctors fail) where + case_alt_list = NE.toList case_alts + mk_alt fail (CaseAlt con args body_fn) = let body = body_fn fail in DMatch (DConP con [] (map DVarP args)) body @@ -317,7 +388,7 @@ mk_default all_ctors fail | exhaustive_case all_ctors = [] | otherwise = [DMatch DWildP fail] - mentioned_ctors = S.fromList $ map alt_con case_alts + mentioned_ctors = S.fromList $ map alt_con case_alt_list exhaustive_case all_ctors = all_ctors `S.isSubsetOf` mentioned_ctors get_all_ctors :: DsMonad q => Name -> q (S.Set Name) @@ -335,44 +406,41 @@ matchEmpty :: DsMonad q => Name -> q [MatchResult] matchEmpty var = return [mk_seq] where - mk_seq fail = DCaseE (DVarE var) [DMatch DWildP fail] + mk_seq fail = dCaseE (DVarE var) [DMatch DWildP fail] -matchLiterals :: DsMonad q => [Name] -> [[EquationInfo]] -> q MatchResult -matchLiterals (var:vars) sub_groups +matchLiterals :: DsMonad q => NonEmpty Name -> NonEmpty (NonEmpty EquationInfo) -> q MatchResult +matchLiterals (var:|vars) sub_groups = do alts <- mapM match_group sub_groups return (mkCoPrimCaseMatchResult var alts) where - match_group :: DsMonad q => [EquationInfo] -> q (Lit, MatchResult) + match_group :: DsMonad q => NonEmpty EquationInfo -> q (Lit, MatchResult) match_group eqns - = do let lit = case firstPat (head eqns) of + = do let lit = case firstPat (NE.head eqns) of DLitP lit' -> lit' _ -> error $ "Internal error in th-desugar " ++ "(matchLiterals.match_group)" - match_result <- simplCase vars (shiftEqns eqns) + match_result <- simplCase vars $ NE.toList $ shiftEqns eqns return (lit, match_result) -matchLiterals [] _ = error "Internal error in th-desugar (matchLiterals)" mkCoPrimCaseMatchResult :: Name -- Scrutinee - -> [(Lit, MatchResult)] + -> NonEmpty (Lit, MatchResult) -> MatchResult mkCoPrimCaseMatchResult var match_alts = mk_case where - mk_case fail = let alts = map (mk_alt fail) match_alts in - DCaseE (DVarE var) (alts ++ [DMatch DWildP fail]) + mk_case fail = let alts = NE.toList $ fmap (mk_alt fail) match_alts in + dCaseE (DVarE var) (alts ++ [DMatch DWildP fail]) mk_alt fail (lit, body_fn) = DMatch (DLitP lit) (body_fn fail) -matchBangs :: DsMonad q => [Name] -> [EquationInfo] -> q MatchResult -matchBangs (var:vars) eqns - = do match_result <- simplCase (var:vars) $ - map (decomposeFirstPat getBangPat) eqns +matchBangs :: DsMonad q => NonEmpty Name -> NonEmpty EquationInfo -> q MatchResult +matchBangs (var:|vars) eqns + = do match_result <- simplCase (var:vars) $ NE.toList $ + fmap (decomposeFirstPat getBangPat) eqns return (mkEvalMatchResult var match_result) -matchBangs [] _ = error "Internal error in th-desugar (matchBangs)" decomposeFirstPat :: (DPat -> DPat) -> EquationInfo -> EquationInfo -decomposeFirstPat extractpat (EquationInfo (pat:pats) body) - = EquationInfo (extractpat pat : pats) body -decomposeFirstPat _ _ = error "Internal error in th-desugar (decomposeFirstPat)" +decomposeFirstPat extractpat (EquationInfo (pat:|pats) body) + = EquationInfo (extractpat pat :| pats) body getBangPat :: DPat -> DPat getBangPat (DBangP p) = p @@ -382,15 +450,19 @@ mkEvalMatchResult var body_fn fail = foldl DAppE (DVarE 'seq) [DVarE var, body_fn fail] -matchVariables :: DsMonad q => [Name] -> [EquationInfo] -> q MatchResult -matchVariables (_:vars) eqns = simplCase vars (shiftEqns eqns) -matchVariables _ _ = error "Internal error in th-desugar (matchVariables)" +matchVariables :: DsMonad q => NonEmpty Name -> NonEmpty EquationInfo -> q MatchResult +matchVariables (_:|vars) eqns = simplCase vars $ NE.toList $ shiftEqns eqns -shiftEqns :: [EquationInfo] -> [EquationInfo] -shiftEqns = map shift +shiftEqns :: NonEmpty EquationInfo -> NonEmpty EquationInfo +shiftEqns = fmap shift where - shift (EquationInfo pats rhs) = EquationInfo (tail pats) rhs + shift (EquationInfo pats rhs) = EquationInfo (to_ne_pats (NE.tail pats)) rhs + to_ne_pats :: [DPat] -> NonEmpty DPat + to_ne_pats pats = + case pats of + p:ps -> p:|ps + [] -> error "Internal error in th-desugar (shiftEqns.to_ne_pats)" adjustMatchResult :: (DExp -> DExp) -> MatchResult -> MatchResult adjustMatchResult wrap mr fail = wrap $ mr fail @@ -405,9 +477,3 @@ selectMatchVar (DTildeP pat) = selectMatchVar pat selectMatchVar (DVarP var) = newUniqueName ('_' : nameBase var) selectMatchVar _ = newUniqueName "_pat" - --- like GHC's runs -runs :: (a -> a -> Bool) -> [a] -> [[a]] -runs _ [] = [] -runs p (x:xs) = case span (p x) xs of - (first, rest) -> (x:first) : (runs p rest) 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 @@ -48,13 +48,19 @@ import qualified Data.Set as Set import Data.Set (Set) -import Language.Haskell.TH.Datatype +import Language.Haskell.TH.Datatype ( freeVariables, freeVariablesWellScoped + , quantifyType, resolveTypeSynonyms ) import Language.Haskell.TH.Datatype.TyVarBndr import Language.Haskell.TH.Instances () import Language.Haskell.TH.Syntax hiding ( lift ) +import qualified Language.Haskell.TH.Syntax.Compat as Compat ( Quote ) -import Language.Haskell.TH.Desugar.Util +import Language.Haskell.TH.Desugar.Util as Util +#if __GLASGOW_HASKELL__ >= 907 +import qualified Language.Haskell.TH as LangExt (Extension(..)) +#endif + -- | Like @reify@ from Template Haskell, but looks also in any not-yet-typechecked -- declarations. To establish this list of not-yet-typechecked declarations, -- use 'withLocalDeclarations'. Returns 'Nothing' if reification fails. @@ -93,26 +99,30 @@ -- Utilities --------------------------------- --- | Extract the @TyVarBndr@s and constructors given the @Name@ of a type +-- | Extract the 'DataFlavor', 'TyVarBndr's and constructors given the 'Name' +-- of a type. getDataD :: DsMonad q => String -- ^ Print this out on failure -> Name -- ^ Name of the datatype (@data@ or @newtype@) of interest - -> q ([TyVarBndrUnit], [Con]) + -> q (DataFlavor, [TyVarBndrVis], [Con]) getDataD err name = do info <- reifyWithLocals name dec <- case info of TyConI dec -> return dec _ -> badDeclaration case dec of - DataD _cxt _name tvbs mk cons _derivings -> go tvbs mk cons - NewtypeD _cxt _name tvbs mk con _derivings -> go tvbs mk [con] + DataD _cxt _name tvbs mk cons _derivings -> go Data tvbs mk cons + NewtypeD _cxt _name tvbs mk con _derivings -> go Newtype tvbs mk [con] +#if __GLASGOW_HASKELL__ >= 906 + TypeDataD _name tvbs mk cons -> go Util.TypeData tvbs mk cons +#endif _ -> badDeclaration where - go tvbs mk cons = do + go df tvbs mk cons = do let k = fromMaybe (ConT typeKindName) mk extra_tvbs <- mkExtraKindBinders k let all_tvbs = tvbs ++ extra_tvbs - return (all_tvbs, cons) + return (df, all_tvbs, cons) badDeclaration = fail $ "The name (" ++ (show name) ++ ") refers to something " ++ @@ -132,16 +142,18 @@ -- are fresh type variable names. -- -- This expands kind synonyms if necessary. -mkExtraKindBinders :: forall q. Quasi q => Kind -> q [TyVarBndrUnit] +mkExtraKindBinders :: forall q. Quasi q => Kind -> q [TyVarBndrVis] mkExtraKindBinders k = do k' <- runQ $ resolveTypeSynonyms k let (fun_args, _) = unravelType k' vis_fun_args = filterVisFunArgs fun_args mapM mk_tvb vis_fun_args where - mk_tvb :: VisFunArg -> q TyVarBndrUnit - mk_tvb (VisFADep tvb) = return tvb - mk_tvb (VisFAAnon ki) = kindedTV <$> qNewName "a" <*> return ki + mk_tvb :: VisFunArg -> q TyVarBndrVis + mk_tvb (VisFADep tvb) = return $ mapTVFlag (const BndrReq) tvb + mk_tvb (VisFAAnon ki) = do + name <- qNewName "a" + pure $ kindedTVFlag name BndrReq ki -- | From the name of a data constructor, retrive the datatype definition it -- is a part of. @@ -159,7 +171,7 @@ -- we need to get the field ordering from the constructor. We must reify -- the constructor to get the tycon, and then reify the tycon to get the `Con`s type_name <- dataConNameToDataName con_name - (_, cons) <- getDataD "This seems to be an error in GHC." type_name + (_, _, cons) <- getDataD "This seems to be an error in GHC." type_name let m_con = List.find (any (con_name ==) . get_con_name) cons case m_con of Just con -> return con @@ -191,7 +203,8 @@ -- | A convenient implementation of the 'DsMonad' class. Use by calling -- 'withLocalDeclarations'. newtype DsM q a = DsM (ReaderT [Dec] q a) - deriving ( Functor, Applicative, Monad, MonadTrans, Quasi, Fail.MonadFail + deriving ( Functor, Applicative, Monad, MonadTrans, Fail.MonadFail + , Quasi, Compat.Quote #if __GLASGOW_HASKELL__ >= 803 , MonadIO #endif @@ -231,7 +244,11 @@ reifyFixityInDecs :: Name -> [Dec] -> Maybe Fixity reifyFixityInDecs n = firstMatch match_fixity where - match_fixity (InfixD fixity n') | n `nameMatches` n' + match_fixity (InfixD fixity +#if __GLASGOW_HASKELL__ >= 909 + _ +#endif + n') | n `nameMatches` n' = Just fixity match_fixity (ClassD _ _ _ _ sub_decs) = firstMatch match_fixity sub_decs match_fixity _ = Nothing @@ -263,16 +280,30 @@ reifyInDec n decs (PatSynD n' _ _ _) | n `nameMatches` n' = Just (n', mkPatSynI n decs) #endif +#if __GLASGOW_HASKELL__ >= 906 +reifyInDec n _ dec@(TypeDataD n' _ _ _) | n `nameMatches` n' = Just (n', TyConI dec) +#endif reifyInDec n decs (DataD _ ty_name tvbs _mk cons _) - | Just info <- maybeReifyCon n decs ty_name (map tvbToTANormalWithSig tvbs) cons + | Just info <- maybeReifyCon n decs ty_name + (matchUpSAKWithTvbsSpec decs ty_name tvbs) + (applyType (ConT ty_name) (map tyVarBndrVisToTypeArg tvbs)) + cons = Just info reifyInDec n decs (NewtypeD _ ty_name tvbs _mk con _) - | Just info <- maybeReifyCon n decs ty_name (map tvbToTANormalWithSig tvbs) [con] + | Just info <- maybeReifyCon n decs ty_name + (matchUpSAKWithTvbsSpec decs ty_name tvbs) + (applyType (ConT ty_name) (map tyVarBndrVisToTypeArg tvbs)) + [con] = Just info -reifyInDec n _decs (ClassD _ ty_name tvbs _ sub_decs) +reifyInDec n decs (ClassD _ cls_name cls_tvbs _ sub_decs) | Just (n', ty) <- findType n sub_decs - = Just (n', ClassOpI n (quantifyClassMethodType ty_name tvbs True ty) ty_name) + = Just (n', ClassOpI n + (quantifyClassMethodType + (matchUpSAKWithTvbsSpec decs cls_name cls_tvbs) + (applyType (ConT cls_name) (map tyVarBndrVisToTypeArg cls_tvbs)) + True ty) + cls_name) reifyInDec n decs (ClassD _ _ _ _ sub_decs) | Just info <- firstMatch (reifyInDec n decs) sub_decs -- Important: don't pass (sub_decs ++ decs) to reifyInDec @@ -286,28 +317,72 @@ reify_in_instance dec@(DataInstD {}) = reifyInDec n (sub_decs ++ decs) dec reify_in_instance dec@(NewtypeInstD {}) = reifyInDec n (sub_decs ++ decs) dec reify_in_instance _ = Nothing +#if __GLASGOW_HASKELL__ >= 801 +reifyInDec n decs (PatSynD pat_syn_name args _ _) + | Just (n', full_sel_ty) <- maybeReifyPatSynRecSelector n decs pat_syn_name args + = Just (n', VarI n full_sel_ty Nothing) +#endif #if __GLASGOW_HASKELL__ >= 807 -reifyInDec n decs (DataInstD _ _ lhs _ cons _) +reifyInDec n decs (DataInstD _ mtvbs lhs _ cons _) | (ConT ty_name, tys) <- unfoldType lhs - , Just info <- maybeReifyCon n decs ty_name tys cons + , Just info <- maybeReifyCon n decs ty_name + (dataFamInstH98ConTvbs mtvbs tys) + -- Why do we reapply `ty_name` to `tys` here instead of just + -- reusing `lhs`? See Note [Apply data family type + -- constructors in prefix form in local reification]. + (applyType (ConT ty_name) tys) + cons = Just info -reifyInDec n decs (NewtypeInstD _ _ lhs _ con _) +reifyInDec n decs (NewtypeInstD _ mtvbs lhs _ con _) | (ConT ty_name, tys) <- unfoldType lhs - , Just info <- maybeReifyCon n decs ty_name tys [con] + , Just info <- maybeReifyCon n decs ty_name + (dataFamInstH98ConTvbs mtvbs tys) + -- Why do we reapply `ty_name` to `tys` here instead of just + -- reusing `lhs`? See Note [Apply data family type + -- constructors in prefix form in local reification]. + (applyType (ConT ty_name) tys) + [con] = Just info #else reifyInDec n decs (DataInstD _ ty_name tys _ cons _) - | Just info <- maybeReifyCon n decs ty_name (map TANormal tys) cons + | Just info <- maybeReifyCon n decs ty_name + (dataFamInstH98ConTvbsNoInstTvbs tys) + (applyType (ConT ty_name) (map TANormal tys)) + cons = Just info reifyInDec n decs (NewtypeInstD _ ty_name tys _ con _) - | Just info <- maybeReifyCon n decs ty_name (map TANormal tys) [con] + | Just info <- maybeReifyCon n decs ty_name + (dataFamInstH98ConTvbsNoInstTvbs tys) + (applyType (ConT ty_name) (map TANormal tys)) + [con] = Just info #endif +#if __GLASGOW_HASKELL__ >= 906 +reifyInDec n decs (TypeDataD ty_name tvbs _mk cons) + | Just info <- maybeReifyCon n decs ty_name + (matchUpSAKWithTvbsSpec decs ty_name tvbs) + (applyType (ConT ty_name) (map tyVarBndrVisToTypeArg tvbs)) + cons + = Just info +#endif reifyInDec _ _ _ = Nothing -maybeReifyCon :: Name -> [Dec] -> Name -> [TypeArg] -> [Con] -> Maybe (Named Info) -maybeReifyCon n _decs ty_name ty_args cons +maybeReifyCon :: + Name + -> [Dec] + -> Name + -> [TyVarBndrSpec] + -- ^ The universally quantified type variables, derived from the parent + -- data declaration. This is only used if reifying a Haskell98-style data + -- constructor. + -> Type + -- ^ The data constructor's return type, derived from the parent data + -- declaration. This is only used if reifying a Haskell98-style data + -- constructor. + -> [Con] + -> Maybe (Named Info) +maybeReifyCon n _decs ty_name h98_tvbs h98_res_ty cons | Just (n', con) <- findCon n cons -- See Note [Use unSigType in maybeReifyCon] , let full_con_ty = unSigType $ con_to_type h98_tvbs h98_res_ty con @@ -320,22 +395,180 @@ -- we don't try to ferret out naughty record selectors. = Just (n', VarI n full_sel_ty Nothing) where - extract_rec_sel_info :: RecSelInfo -> ([TyVarBndrUnit], Type, Type) + extract_rec_sel_info :: RecSelInfo -> ([TyVarBndrSpec], Type, Type) -- Returns ( Selector type variable binders -- , Record field type -- , constructor result type ) extract_rec_sel_info rec_sel_info = case rec_sel_info of - RecSelH98 sel_ty -> (h98_tvbs, sel_ty, h98_res_ty) - RecSelGADT sel_ty con_res_ty -> - ( freeVariablesWellScoped [con_res_ty, sel_ty] - , sel_ty, con_res_ty) + RecSelH98 sel_ty -> + let -- All of the type variables bound by the data type, with any + -- implicitly quantified kind variables made explicit. + all_h98_tvbs = quantifyAllTvbsSpec h98_tvbs in + ( all_h98_tvbs + , sel_ty + , h98_res_ty + ) + RecSelGADT mb_con_tvbs sel_ty con_res_ty -> + let -- If the GADT constructor type signature explicitly quantifies + -- its type variables, make sure to use that same order in the + -- record selector's type. + con_tvbs' = + case mb_con_tvbs of + Just con_tvbs -> con_tvbs + Nothing -> + changeTVFlags SpecifiedSpec $ + freeVariablesWellScoped [con_res_ty, sel_ty] in + ( con_tvbs' + , sel_ty + , con_res_ty + ) - h98_tvbs = freeVariablesWellScoped $ map probablyWrongUnTypeArg ty_args - h98_res_ty = applyType (ConT ty_name) ty_args +maybeReifyCon _ _ _ _ _ _ = Nothing -maybeReifyCon _ _ _ _ _ = Nothing +#if __GLASGOW_HASKELL__ >= 801 +-- | Attempt to reify the type of a pattern synonym record selector @n@. +-- The algorithm for computing this type works as follows: +-- +-- 1. Reify the type of the parent pattern synonym. Broadly speaking, this +-- will look something like: +-- +-- @ +-- pattern P :: forall . req_cxt => +-- forall . prov_cxt => +-- arg_ty_1 -> ... -> arg_ty_k -> res +-- @ +-- +-- 2. Check if @P@ is a record pattern synonym. If it isn't a record pattern +-- synonym, return 'Nothing'. If it is a record pattern synonym, it will +-- have @k@ record selectors @sel_1@, ..., @sel_k@. +-- +-- 3. Check if @n@ is equal to some @sel_i@. If it isn't equal to any of them, +-- return @Nothing@. If it is equal to some @sel_i@, then return 'Just' +-- @sel_i@ paired with the following type: +-- +-- @ +-- sel_i :: forall . req_cxt => res -> arg_ty_i +-- @ +maybeReifyPatSynRecSelector :: + Name -> [Dec] -> Name -> PatSynArgs -> Maybe (Named Type) +maybeReifyPatSynRecSelector n decs pat_syn_name pat_syn_args = + case pat_syn_args of + -- Part (2) in the Haddocks + RecordPatSyn fld_names + -> firstMatch match_pat_syn_rec_sel $ + zip fld_names pat_syn_ty_vis_args + _ -> Nothing + where + -- Part (3) in the Haddocks + match_pat_syn_rec_sel :: (Name, Type) -> Maybe (Named Type) + match_pat_syn_rec_sel (n', field_ty) + | n `nameMatches` n' + = Just ( n' + , -- See Note [Use unSigType in maybeReifyCon] + unSigType $ + maybeForallT pat_syn_ty_tvbs pat_syn_ty_req_cxt $ + ArrowT `AppT` pat_syn_ty_res `AppT` field_ty + ) + match_pat_syn_rec_sel _ + = Nothing + -- The type of the pattern synonym to which this record selector belongs, + -- as described in part (1) in the Haddocks. + pat_syn_ty :: Type + pat_syn_ty = + case findPatSynType pat_syn_name decs of + Just ty -> ty + Nothing -> no_type n + + pat_syn_ty_args :: FunArgs + pat_syn_ty_res :: Type + (pat_syn_ty_args, pat_syn_ty_res) = + unravelType pat_syn_ty + + -- Decompose a pattern synonym type into the constituent parts described in + -- part (1) in the Haddocks. The Haddocks present an idealized form of + -- pattern synonym type signature where the required and provided foralls + -- and contexts are made explicit. In reality, some of these parts may be + -- omitted, so we have to be careful to handle every combination of + -- explicit and implicit parts. + pat_syn_ty_tvbs :: [TyVarBndrSpec] + pat_syn_ty_req_cxt :: Cxt + pat_syn_ty_vis_args :: [Type] + (pat_syn_ty_tvbs, pat_syn_ty_req_cxt, pat_syn_ty_vis_args) = + case pat_syn_ty_args of + -- Both the required foralls and context are explicit. + -- + -- The provided foralls and context may be explicit or implicit, but it + -- doesn't really matter, as the type of a pattern synonym record + -- selector only cares about the required foralls and context. + -- Similarly for all cases below this one. + FAForalls (ForallInvis req_tvbs) (FACxt req_cxt args) -> + ( req_tvbs + , req_cxt + , mapMaybe vis_arg_anon_maybe $ filterVisFunArgs args + ) + + -- Only the required foralls are explicit. We can assume that there is + -- no required context due to the case above not matching. + FAForalls (ForallInvis req_tvbs) args -> + ( req_tvbs + , [] + , mapMaybe vis_arg_anon_maybe $ filterVisFunArgs args + ) + + -- The required context is explicit, but the required foralls are + -- implicit. As a result, the order of type variables in the outer + -- forall in the type of the pattern synonym is determined by the usual + -- left-to-right scoped sort. + -- + -- Note that there may be explicit, provided foralls in this case. For + -- example, consider this example: + -- + -- @ + -- data T a where + -- MkT :: b -> T (Maybe b) + -- + -- pattern X :: Show a => forall b. (a ~ Maybe b) => b -> T a + -- pattern X{unX} = MkT unX + -- @ + -- + -- You might worry that the type of @unX@ would need to mention @b@. + -- But actually, you can't use @unX@ as a top-level record selector in + -- the first place! If you try to do so, GHC will throw the following + -- error: + -- + -- @ + -- Cannot use record selector `unX' as a function due to escaped type variables + -- @ + -- + -- As a result, we choose not to care about this corner case. We could + -- imagine trying to detect this sort of thing here and throwing a + -- similar error message, but detecting which type variables do or do + -- not escape is tricky in general. (See the Haddocks for + -- getRecordSelectors in L.H.TH.Desugar for more on this point.) As a + -- result, we don't even bother trying. Similarly for the case below. + FACxt req_cxt args -> + ( changeTVFlags SpecifiedSpec $ + freeVariablesWellScoped [pat_syn_ty] + , req_cxt + , mapMaybe vis_arg_anon_maybe $ filterVisFunArgs args + ) + + -- The required foralls are implicit. We can assume that there is no + -- required context due to the case above not matching. + args -> + ( changeTVFlags SpecifiedSpec $ + freeVariablesWellScoped [pat_syn_ty] + , [] + , mapMaybe vis_arg_anon_maybe $ filterVisFunArgs args + ) + +vis_arg_anon_maybe :: VisFunArg -> Maybe Type +vis_arg_anon_maybe (VisFAAnon ty) = Just ty +vis_arg_anon_maybe (VisFADep{}) = Nothing +#endif + {- Note [Use unSigType in maybeReifyCon] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -350,10 +583,36 @@ This is contrast to GHC's own reification, which will produce `D a` (without the explicit kind signature) as the type of the first argument. + +Note [Apply data family type constructors in prefix form in local reification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we wish to locally reify the type of `MkD` below: + + data family a :&: b + data instance a :&: b = MkD a b + +You might be tempted to think that the return type should be: + + MkD :: a -> b -> a :&: b + +However, keep in mind that local reification tries its best to mimic GHC's +behavior when reifying global declarations using Template Haskell. As it turns +out, if `MkD` were defined globally, then Template Haskell would reify it as: + + MkD :: a -> b -> (:&:) a b + +Note that `(:&:)` is applied prefix, not infix! This is somewhat surprising, +but nevertheless valid code. We mimic this surprising behavior when locally +reifying data family instances such as (:&:). This means that we cannot just +reuse the type `a :&: b` in the return type of `MkD`. Instead, we must +decompose `a :&: b` into its type arguments and apply (:&:) (in prefix form) to +the type arguments. + +The R40 test case checks for this property. -} -- Reverse-engineer the type of a data constructor. -con_to_type :: [TyVarBndrUnit] -- The type variables bound by a data type head. +con_to_type :: [TyVarBndrSpec] -- The type variables bound by a data type head. -- Only used for Haskell98-style constructors. -> Type -- The constructor result type. -- Only used for Haskell98-style constructors. @@ -361,7 +620,7 @@ con_to_type h98_tvbs h98_result_ty con = case go con of (is_gadt, ty) | is_gadt -> ty - | otherwise -> maybeForallT h98_tvbs [] ty + | otherwise -> maybeForallT all_h98_tvbs [] ty where -- Note that we deliberately ignore linear types and use (->) everywhere. -- See [Gracefully handling linear types] in L.H.TH.Desugar.Core. @@ -373,6 +632,11 @@ go (GadtC _ stys rty) = (True, mkArrows (map snd stys) rty) go (RecGadtC _ vstys rty) = (True, mkArrows (map thdOf3 vstys) rty) + -- All of the type variables bound by the data type, with any implicitly + -- quantified kind variables made explicit. + all_h98_tvbs :: [TyVarBndrSpec] + all_h98_tvbs = quantifyAllTvbsSpec h98_tvbs + mkVarI :: Name -> [Dec] -> Info mkVarI n decs = mkVarITy n (maybe (no_type n) snd $ findType n decs) @@ -521,7 +785,11 @@ sub_decs' = mapMaybe go sub_decs go (SigD n ty) = Just $ SigD n - $ quantifyClassMethodType cls_name cls_tvbs prepend_cls ty + $ quantifyClassMethodType + (changeTVFlags SpecifiedSpec cls_tvbs) + (applyType (ConT cls_name) (map tyVarBndrVisToTypeArg cls_tvbs)) + prepend_cls + ty go d@(TySynInstD {}) = Just d go d@(OpenTypeFamilyD {}) = Just d go d@(DataFamilyD {}) = Just d @@ -542,8 +810,8 @@ -- [d| class C a where -- method :: a -> b -> a |] -- --- If one invokes `quantifyClassMethodType C [a] prepend (a -> b -> a)`, then --- the output will be: +-- If one invokes `quantifyClassMethodType [a] (C a) prepend (a -> b -> a)`, +-- then the output will be: -- -- 1. `forall a. C a => forall b. a -> b -> a` (if `prepend` is True) -- 2. `forall b. a -> b -> a` (if `prepend` is False) @@ -555,22 +823,19 @@ -- a single class method, like `method`, then one needs the class context to -- appear in the reified type, so `True` is appropriate. quantifyClassMethodType - :: Name -- ^ The class name. - -> [TyVarBndrUnit] -- ^ The class's type variable binders. + :: [TyVarBndrSpec] -- ^ The class's type variable binders. + -> Pred -- ^ The class context. -> Bool -- ^ If 'True', prepend a class predicate. -> Type -- ^ The method type. -> Type -quantifyClassMethodType cls_name cls_tvbs prepend meth_ty = +quantifyClassMethodType cls_tvbs cls_pred prepend meth_ty = add_cls_cxt quantified_meth_ty where add_cls_cxt :: Type -> Type add_cls_cxt - | prepend = ForallT (changeTVFlags SpecifiedSpec all_cls_tvbs) cls_cxt + | prepend = ForallT all_cls_tvbs [cls_pred] | otherwise = id - cls_cxt :: Cxt - cls_cxt = [foldl AppT (ConT cls_name) (map tvbToType cls_tvbs)] - quantified_meth_ty :: Type quantified_meth_ty | null meth_tvbs @@ -581,13 +846,15 @@ = ForallT meth_tvbs [] meth_ty meth_tvbs :: [TyVarBndrSpec] - meth_tvbs = changeTVFlags SpecifiedSpec $ - List.deleteFirstsBy ((==) `on` tvName) - (freeVariablesWellScoped [meth_ty]) all_cls_tvbs + meth_tvbs = List.deleteFirstsBy ((==) `on` tvName) + (changeTVFlags SpecifiedSpec + (freeVariablesWellScoped [meth_ty])) + all_cls_tvbs - -- Explicitly quantify any kind variables bound by the class, if any. - all_cls_tvbs :: [TyVarBndrUnit] - all_cls_tvbs = freeVariablesWellScoped $ map tvbToTypeWithSig cls_tvbs + -- All of the type variables bound by the class, with any implicitly + -- quantified kind variables made explicit. + all_cls_tvbs :: [TyVarBndrSpec] + all_cls_tvbs = quantifyAllTvbsSpec cls_tvbs stripInstanceDec :: Dec -> Dec stripInstanceDec (InstanceD over cxt ty _) = InstanceD over cxt ty [] @@ -597,13 +864,11 @@ mkArrows [] res_ty = res_ty mkArrows (t:ts) res_ty = AppT (AppT ArrowT t) $ mkArrows ts res_ty -maybeForallT :: [TyVarBndrUnit] -> Cxt -> Type -> Type +maybeForallT :: [TyVarBndrSpec] -> Cxt -> Type -> Type maybeForallT tvbs cxt ty | null tvbs && null 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 + | ForallT tvbs2 cxt2 ty2 <- ty = ForallT (tvbs ++ tvbs2) (cxt ++ cxt2) ty2 + | otherwise = ForallT tvbs cxt ty findCon :: Name -> [Con] -> Maybe (Named Con) findCon n = firstMatch match_con @@ -628,24 +893,123 @@ data RecSelInfo = RecSelH98 Type -- The record field's type - | RecSelGADT Type -- The record field's type + | RecSelGADT (Maybe [TyVarBndrSpec]) + -- If the data constructor explicitly quantifies its type + -- variables with a forall, this will be Just. Otherwise, + -- this will be Nothing. + Type -- The record field's type Type -- The GADT return type findRecSelector :: Name -> [Con] -> Maybe (Named RecSelInfo) -findRecSelector n = firstMatch match_con +findRecSelector n = firstMatch (match_con Nothing) where - match_con :: Con -> Maybe (Named RecSelInfo) - match_con (RecC _ vstys) = fmap (liftSnd RecSelH98) $ - firstMatch match_rec_sel vstys - match_con (RecGadtC _ vstys ret_ty) = fmap (liftSnd (`RecSelGADT` ret_ty)) $ - firstMatch match_rec_sel vstys - match_con (ForallC _ _ c) = match_con c - match_con _ = Nothing + match_con :: Maybe [TyVarBndrSpec] -> Con -> Maybe (Named RecSelInfo) + match_con mb_tvbs con = + case con of + RecC _ vstys -> + fmap (liftSnd RecSelH98) $ + firstMatch match_rec_sel vstys + RecGadtC _ vstys ret_ty -> + fmap (liftSnd (\field_ty -> + RecSelGADT (fmap (filter_ret_tvs ret_ty) mb_tvbs) field_ty ret_ty)) $ + firstMatch match_rec_sel vstys + ForallC tvbs _ c -> + -- This is the only recursive case, and it is also the place where + -- the type variable binders are determined (hence the use of Just + -- below). Note that GHC forbids nested foralls in GADT constructor + -- type signatures, so it is guaranteed that if a type variable in + -- the rest of the type signature appears free, then its binding site + -- can be found in one of these binders found in this case. + match_con (Just tvbs) c + _ -> Nothing match_rec_sel (n', _, sel_ty) | n `nameMatches` n' = Just (n', sel_ty) match_rec_sel _ = Nothing + -- There may be type variables in the type of a GADT constructor that do + -- not appear in the type of a record selector. For example, consider: + -- + -- data G a where + -- MkG :: forall a b. { x :: a, y :: b } -> G a + -- + -- The type of `x` will only quantify `a` and not `b`: + -- + -- x :: forall a. G a -> a + -- + -- Accordingly, we must filter out any type variables in the GADT + -- constructor type that do not appear free in the return type. Note that + -- this implies that we cannot support reifying the type of `y`, as `b` + -- does not appear free in `G a`. This does not bother us, however, as we + -- make no attempt to support naughty record selectors. (See the Haddocks + -- for getRecordSelectors in L.H.TH.Desugar for more on this point.) + -- + -- This mirrors the implementation of mkOneRecordSelector in GHC: + -- https://gitlab.haskell.org/ghc/ghc/-/blob/37cfe3c0f4fb16189bbe3bb735f758cd6e3d9157/compiler/GHC/Tc/TyCl/Utils.hs#L908-909 + filter_ret_tvs :: Type -> [TyVarBndrSpec] -> [TyVarBndrSpec] + filter_ret_tvs ret_ty = + filter (\tvb -> tvName tvb `Set.member` ret_fvs) + where + ret_fvs = Set.fromList $ freeVariables [ret_ty] + +-- | Match up the type variable binders from a data type or class declaration +-- with its standalone kind signature (if any) to produce a list of +-- 'TyVarBndrSpec's, which can then be used in the types of data constructors or +-- class methods. This makes the kinds more precise. +matchUpSAKWithTvbsSpec :: + [Dec] + -- ^ The local declarations currently in scope. + -> Name + -- ^ The name of the data type or class declaration. + -> [TyVarBndrVis] + -- ^ The data type or class declaration's type variable binders. + -> [TyVarBndrSpec] +matchUpSAKWithTvbsSpec decs ty_name tvbs = + fromMaybe (changeTVFlags SpecifiedSpec tvbs) $ do + sak <- findKind False ty_name decs + tvbForAllTyFlagsToSpecs <$> matchUpSAKWithDecl sak tvbs + +-- | Compute the type variable binders to use in the type of a Haskell98-style +-- data constructor for a data family instance. If the data family instance +-- comes equipped with explicit type variable binders, this is easy. If not, +-- we must compute the type variable binders from the list of type arguments to +-- the data family instance. +dataFamInstH98ConTvbs :: Maybe [TyVarBndrUnit] -> [TypeArg] -> [TyVarBndrSpec] +dataFamInstH98ConTvbs mtvbs tys = + case mtvbs of + Just tvbs -> + changeTVFlags SpecifiedSpec tvbs + Nothing -> + dataFamInstH98ConTvbsNoInstTvbs $ + map probablyWrongUnTypeArg tys + +-- | Compute the type variable binders to use in the type of a Haskell98-style +-- data constructor for a data family instance where the instance lacks explicit +-- type variable binders. To compute these binders, we must reverse engineer +-- them from the list of type arguments to the data family instance. +dataFamInstH98ConTvbsNoInstTvbs :: [Type] -> [TyVarBndrSpec] +dataFamInstH98ConTvbsNoInstTvbs tys = + changeTVFlags SpecifiedSpec $ + freeVariablesWellScoped tys + +-- | Explicitly quantify all type variable binders in the type of a +-- Haskell98-style data constructor or class method. This is sometimes required +-- in order to ensure that kind variables are all explicitly quantified, e.g., +-- +-- @ +-- -- NB: No standalone kind signature for `T` +-- data T (a :: k) = MkT +-- @ +-- +-- We want the type of @MkT@ to be @forall k (a :: k). T a@, but we are only +-- given @(a :: k)@. We must call 'quantifyAllTvbsSpec' on @(a :: k)@ to obtain +-- @[k, a :: k]@. If we don't, we might accidentally end up with +-- @forall (a :: k). T a@ as the type of @MkT@, which is ill-scoped. +quantifyAllTvbsSpec :: [TyVarBndrSpec] -> [TyVarBndrSpec] +quantifyAllTvbsSpec h98_tvbs = + let h98_kvbs = freeKindVariablesWellScoped h98_tvbs in + changeTVFlags SpecifiedSpec h98_kvbs ++ h98_tvbs + --------------------------------- -- Reifying fixities --------------------------------- @@ -757,7 +1121,7 @@ cls_tvb_kind_map = Map.fromList [ (tvName tvb, tvb_kind) | (tvb, mb_vis_arg_ki) <- zip tvbs mb_vis_arg_kis - , Just tvb_kind <- [mb_vis_arg_ki <|> tvb_kind_maybe tvb] + , Just tvb_kind <- [mb_vis_arg_ki <|> extractTvbKind_maybe tvb] ] = firstMatch (find_assoc_type_kind n cls_tvb_kind_map) sub_decs match_kind_sig n _ dec = find_kind_sig n dec @@ -799,9 +1163,14 @@ all tvb_is_kinded tvbs , let cls_tvb_kind_map = Map.fromList [ (tvName tvb, tvb_kind) | tvb <- tvbs - , Just tvb_kind <- [tvb_kind_maybe tvb] + , Just tvb_kind <- [extractTvbKind_maybe tvb] ] = firstMatch (find_assoc_type_kind n cls_tvb_kind_map) sub_decs +#if __GLASGOW_HASKELL__ >= 906 +match_cusk n (TypeDataD n' tvbs m_ki _) + | n `nameMatches` n' + = datatype_kind tvbs m_ki +#endif match_cusk _ _ = Nothing -- Uncover the kind of an associated type family. There is an invariant @@ -821,17 +1190,18 @@ (default_res_ki $ res_sig_to_kind res_sig) _ -> Nothing where - ascribe_tf_tvb_kind :: TyVarBndrUnit -> TyVarBndrUnit + ascribe_tf_tvb_kind :: TyVarBndrVis -> TyVarBndrVis ascribe_tf_tvb_kind tvb = - elimTV (\tvn -> kindedTV tvn $ fromMaybe StarT $ Map.lookup tvn cls_tvb_kind_map) - (\_ _ -> tvb) - tvb + elimTVFlag + (\tvn flag -> kindedTVFlag tvn flag $ fromMaybe StarT $ Map.lookup tvn cls_tvb_kind_map) + (\_ _ _ -> tvb) + tvb -- Data types have CUSKs when: -- -- 1. All of their type variables have explicit kinds. -- 2. All kind variables in the result kind are explicitly quantified. -datatype_kind :: [TyVarBndrUnit] -> Maybe Kind -> Maybe Kind +datatype_kind :: [TyVarBndrVis] -> Maybe Kind -> Maybe Kind datatype_kind tvbs m_ki = whenAlt (all tvb_is_kinded tvbs && ki_fvs_are_bound) $ build_kind tvbs (default_res_ki m_ki) @@ -843,14 +1213,14 @@ in ki_fvs `Set.isSubsetOf` tvb_vars -- Classes have CUSKs when all of their type variables have explicit kinds. -class_kind :: [TyVarBndrUnit] -> Maybe Kind +class_kind :: [TyVarBndrVis] -> Maybe Kind class_kind tvbs = whenAlt (all tvb_is_kinded tvbs) $ build_kind tvbs ConstraintT -- Open type families and data families always have CUSKs. Type variables -- without explicit kinds default to Type, as does the return kind if it -- is not specified. -open_ty_fam_kind :: [TyVarBndrUnit] -> Maybe Kind -> Maybe Kind +open_ty_fam_kind :: [TyVarBndrVis] -> Maybe Kind -> Maybe Kind open_ty_fam_kind tvbs m_ki = build_kind (map default_tvb tvbs) (default_res_ki m_ki) @@ -858,7 +1228,7 @@ -- -- 1. All of their type variables have explicit kinds. -- 2. An explicit return kind is supplied. -closed_ty_fam_kind :: [TyVarBndrUnit] -> Maybe Kind -> Maybe Kind +closed_ty_fam_kind :: [TyVarBndrVis] -> Maybe Kind -> Maybe Kind closed_ty_fam_kind tvbs m_ki = case m_ki of Just ki -> whenAlt (all tvb_is_kinded tvbs) $ @@ -869,7 +1239,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 :: [TyVarBndrUnit] -> Type -> Maybe Kind +ty_syn_kind :: [TyVarBndrVis] -> Type -> Maybe Kind ty_syn_kind tvbs rhs = case rhs of SigT _ ki -> whenAlt (all tvb_is_kinded tvbs) $ @@ -881,16 +1251,16 @@ -- this function is `Maybe Kind` because there are situations where even -- this amount of information is not sufficient to determine the full kind. -- See Note [The limitations of standalone kind signatures]. -build_kind :: [TyVarBndrUnit] -> Kind -> Maybe Kind +build_kind :: [TyVarBndrVis] -> Kind -> Maybe Kind build_kind arg_kinds res_kind = fmap quantifyType $ fst $ foldr go (Just res_kind, Set.fromList (freeVariables res_kind)) arg_kinds where - go :: TyVarBndrUnit -> (Maybe Kind, Set Name) -> (Maybe Kind, Set Name) + go :: TyVarBndrVis -> (Maybe Kind, Set Name) -> (Maybe Kind, Set Name) go tvb (res, res_fvs) = elimTV (\n -> ( if n `Set.member` res_fvs - then forall_vis tvb res + then forall_ tvb res else Nothing -- We have a type variable binder without an -- explicit kind that is not used dependently, so -- we cannot build a kind from it. This is the @@ -899,15 +1269,22 @@ )) (\n k -> ( if n `Set.member` res_fvs - then forall_vis tvb res + then forall_ tvb res else fmap (ArrowT `AppT` k `AppT`) res , Set.fromList (freeVariables k) `Set.union` res_fvs )) tvb - forall_vis :: TyVarBndrUnit -> Maybe Kind -> Maybe Kind + forall_ :: TyVarBndrVis -> Maybe Kind -> Maybe Kind #if __GLASGOW_HASKELL__ >= 809 - forall_vis tvb m_ki = fmap (ForallVisT [tvb]) m_ki + forall_ tvb m_ki = fmap forallT m_ki + where + bndrVis :: BndrVis + bndrVis = elimTVFlag (\_ flag -> flag) (\_ flag _ -> flag) tvb + forallT :: Kind -> Kind + forallT = case bndrVis of + BndrReq -> ForallVisT (changeTVFlags () [tvb]) + BndrInvis -> ForallT (changeTVFlags SpecifiedSpec [tvb]) [] -- One downside of this approach is that we generate kinds like this: -- -- forall a -> forall b -> forall c -> (a, b, c) @@ -918,21 +1295,18 @@ -- -- Thankfully, the difference is only cosmetic. #else - forall_vis _ _ = Nothing + forall_ _ _ = Nothing #endif tvb_is_kinded :: TyVarBndr_ flag -> Bool -tvb_is_kinded = isJust . tvb_kind_maybe - -tvb_kind_maybe :: TyVarBndr_ flag -> Maybe Kind -tvb_kind_maybe = elimTV (\_ -> Nothing) (\_ k -> Just k) +tvb_is_kinded = isJust . extractTvbKind_maybe vis_arg_kind_maybe :: VisFunArg -> Maybe Kind -vis_arg_kind_maybe (VisFADep tvb) = tvb_kind_maybe tvb +vis_arg_kind_maybe (VisFADep tvb) = extractTvbKind_maybe tvb vis_arg_kind_maybe (VisFAAnon k) = Just k -default_tvb :: TyVarBndrUnit -> TyVarBndrUnit -default_tvb tvb = elimTV (\n -> kindedTV n StarT) (\_ _ -> tvb) tvb +default_tvb :: TyVarBndr_ flag -> TyVarBndr_ flag +default_tvb tvb = elimTVFlag (\n flag -> kindedTVFlag n flag StarT) (\_ _ _ -> tvb) tvb default_res_ki :: Maybe Kind -> Kind default_res_ki = fromMaybe StarT @@ -940,7 +1314,7 @@ res_sig_to_kind :: FamilyResultSig -> Maybe Kind res_sig_to_kind NoSig = Nothing res_sig_to_kind (KindSig k) = Just k -res_sig_to_kind (TyVarSig tvb) = tvb_kind_maybe tvb +res_sig_to_kind (TyVarSig tvb) = extractTvbKind_maybe tvb whenAlt :: Alternative f => Bool -> f a -> f a whenAlt b fa = if b then fa else empty @@ -993,7 +1367,7 @@ lookupTypeNameWithLocals :: DsMonad q => String -> q (Maybe Name) lookupTypeNameWithLocals = lookupNameWithLocals True -lookupNameWithLocals :: DsMonad q => Bool -> String -> q (Maybe Name) +lookupNameWithLocals :: forall q. DsMonad q => Bool -> String -> q (Maybe Name) lookupNameWithLocals ns s = do mb_name <- qLookupName ns s case mb_name of @@ -1006,23 +1380,33 @@ decs <- localDeclarations let mb_infos = map (reifyInDec built_name decs) decs infos = catMaybes mb_infos - return $ firstMatch (if ns then find_type_name - else find_value_name) infos + firstMatchM (if ns then find_type_name + else find_value_name) infos -- These functions work over Named Infos so we can avoid performing -- tiresome pattern-matching to retrieve the name associated with each Info. - find_type_name, find_value_name :: Named Info -> Maybe Name - find_type_name (n, info) = - case infoNameSpace info of + find_type_name, find_value_name :: Named Info -> q (Maybe Name) + find_type_name (n, info) = do + name_space <- lookupInfoNameSpace info + pure $ case name_space of TcClsName -> Just n VarName -> Nothing DataName -> Nothing +#if __GLASGOW_HASKELL__ >= 907 + FldName{} -> Nothing +#endif - find_value_name (n, info) = - case infoNameSpace info of - VarName -> Just n - DataName -> Just n - TcClsName -> Nothing + find_value_name (n, info) = do + name_space <- lookupInfoNameSpace info + case name_space of + VarName -> pure $ Just n + DataName -> pure $ Just n + TcClsName -> pure Nothing +#if __GLASGOW_HASKELL__ >= 907 + FldName{} -> do + fieldSels <- qIsExtEnabled LangExt.FieldSelectors + pure $ if fieldSels then Just n else Nothing +#endif -- | Like TH's @lookupValueName@, but if this name is not bound, then we assume -- it is declared in the current module. @@ -1060,22 +1444,62 @@ -- For other names, we must use reification to determine what NameSpace -- it lives in (if any). _ -> do mb_info <- reifyWithLocals_maybe n - pure $ fmap infoNameSpace mb_info + traverse lookupInfoNameSpace mb_info --- | Determine a name's 'NameSpace' from its 'Info'. -infoNameSpace :: Info -> NameSpace -infoNameSpace info = +-- | Look up a name's 'NameSpace' from its 'Info'. +lookupInfoNameSpace :: DsMonad q => Info -> q NameSpace +lookupInfoNameSpace info = case info of - ClassI{} -> TcClsName - TyConI{} -> TcClsName - FamilyI{} -> TcClsName - PrimTyConI{} -> TcClsName - TyVarI{} -> TcClsName + ClassI{} -> pure TcClsName + TyConI{} -> pure TcClsName + FamilyI{} -> pure TcClsName + PrimTyConI{} -> pure TcClsName + TyVarI{} -> pure TcClsName - ClassOpI{} -> VarName - VarI{} -> VarName + ClassOpI{} -> pure VarName +#if __GLASGOW_HASKELL__ >= 907 + -- A VarI might correspond to a top-level value (i.e., a VarName) or a + -- record field (i.e., a FldName). The only way to distinguish them is to + -- check if the VarI's Name and Type correspond to a data type with a + -- corresponding record field Name. + VarI n ty _ -> do + -- First, check to see if `ty` is of the form `D -> T`, where `D` is + -- headed by a data type. We can safely ignore `forall`s here by using + -- `filterVisFunArgs`, as we only care about the first visible argument. + let (ty_args, _ty_res) = unravelType ty + ty_vis_args = filterVisFunArgs ty_args + case ty_vis_args of + [VisFAAnon ty_anon_arg] + | (ConT parent_name, _) <- unfoldType ty_anon_arg + -> -- If we find the data type constructor `parent_name`, then check + -- if one of the data constructors for `parent_name` contains a + -- record field named `n`. + do mb_parent_info <- reifyWithLocals_maybe parent_name + pure $ case mb_parent_info of + Just (TyConI (DataD _cxt _name _tvbs _mk cons _derivings)) + | isJust $ findRecSelector n cons + -> FldName $ nameBase parent_name + Just (TyConI (NewtypeD _cxt _name _tvbs _mk con _derivings)) + | isJust $ findRecSelector n [con] + -> FldName $ nameBase parent_name + _ -> VarName + _ -> pure VarName +#else + VarI{} -> pure VarName +#endif - DataConI{} -> DataName + DataConI _dc_name _dc_ty parent_name -> do + -- DataConI usually refers to a value-level Name, but it could also refer + -- to a type-level 'Name' if the data constructor corresponds to a + -- @type data@ declaration. In order to know for sure, we must perform + -- some additional reification. + mb_parent_info <- reifyWithLocals_maybe parent_name + pure $ case mb_parent_info of +#if __GLASGOW_HASKELL__ >= 906 + Just (TyConI (TypeDataD {})) + -> TcClsName +#endif + _ -> DataName #if __GLASGOW_HASKELL__ >= 801 - PatSynI{} -> DataName + PatSynI{} -> pure DataName #endif 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 @@ -1,5 +1,3 @@ -{-# LANGUAGE CPP #-} - ----------------------------------------------------------------------------- -- | -- Module : Language.Haskell.TH.Desugar.Subst @@ -9,7 +7,9 @@ -- Stability : experimental -- Portability : non-portable -- --- Capture-avoiding substitutions on 'DType's +-- Capture-avoiding substitutions on 'DType's. (For non–capture-avoiding +-- substitution functions, use "Language.Haskell.TH.Desugar.Subst.Capturing" +-- instead.) -- ---------------------------------------------------------------------------- @@ -17,7 +17,7 @@ DSubst, -- * Capture-avoiding substitution - substTy, substForallTelescope, substTyVarBndrs, + substTy, substForallTelescope, substTyVarBndrs, substTyVarBndr, unionSubsts, unionMaybeSubsts, -- * Matching a type template against a type @@ -29,13 +29,15 @@ import qualified Data.Set as S import Language.Haskell.TH.Desugar.AST -import Language.Haskell.TH.Syntax import Language.Haskell.TH.Desugar.Util +import Language.Haskell.TH.Syntax --- | A substitution is just a map from names to types +-- | A substitution is just a map from names to types. type DSubst = M.Map Name DType --- | Capture-avoiding substitution on types +-- | Capture-avoiding substitution on 'DType's. This function requires a 'Quasi' +-- constraint because it may need to create fresh names in order to avoid +-- capture when substituting into a @forall@ type (see 'substTyVarBndr'). substTy :: Quasi q => DSubst -> DType -> q DType substTy vars (DForallT tele ty) = do (vars', tele') <- substForallTelescope vars tele @@ -59,6 +61,10 @@ substTy _ ty@(DLitT _) = return ty substTy _ ty@DWildCardT = return ty +-- | Capture-avoiding substitution on 'DForallTelescope's. This returns a pair +-- containing the new 'DSubst' as well as a new 'DForallTelescope' value, where +-- the names have been renamed to avoid capture and the kinds have been +-- substituted. substForallTelescope :: Quasi q => DSubst -> DForallTelescope -> q (DSubst, DForallTelescope) substForallTelescope vars tele = @@ -70,16 +76,25 @@ (vars', tvbs') <- substTyVarBndrs vars tvbs return (vars', DForallInvis tvbs') +-- | Capture-avoiding substitution on a telescope of 'DTyVarBndr's. This returns +-- a pair containing the new 'DSubst' as well as a new telescope of +-- 'DTyVarBndr's, where the names have been renamed to avoid capture and the +-- kinds have been substituted. substTyVarBndrs :: Quasi q => DSubst -> [DTyVarBndr flag] -> q (DSubst, [DTyVarBndr flag]) -substTyVarBndrs = mapAccumLM substTvb +substTyVarBndrs = mapAccumLM substTyVarBndr -substTvb :: Quasi q => DSubst -> DTyVarBndr flag +-- | Capture-avoiding substitution on a 'DTyVarBndr'. This uses the 'Quasi' +-- constraint to create a new, fresh name (based on the name of the supplied +-- 'DTyVarBndr'), update the 'DSubst' to map from the old name to the new name, +-- and this also returns a 'DTyVarBndr' containing the new name and the kind of +-- the supplied 'DTyVarBndr' (with the substitution applied). +substTyVarBndr :: Quasi q => DSubst -> DTyVarBndr flag -> q (DSubst, DTyVarBndr flag) -substTvb vars (DPlainTV n flag) = do +substTyVarBndr vars (DPlainTV n flag) = do new_n <- qNewName (nameBase n) return (M.insert n (DVarT new_n) vars, DPlainTV new_n flag) -substTvb vars (DKindedTV n flag k) = do +substTyVarBndr vars (DKindedTV n flag k) = do new_n <- qNewName (nameBase n) k' <- substTy vars k return (M.insert n (DVarT new_n) vars, DKindedTV new_n flag k') @@ -116,12 +131,17 @@ matchTy :: IgnoreKinds -> DType -> DType -> Maybe DSubst matchTy _ (DVarT var_name) arg = Just $ M.singleton var_name arg -- if a pattern has a kind signature, it's really easy to get - -- this wrong. + -- the following two cases wrong. matchTy ign (DSigT ty _ki) arg = case ign of YesIgnore -> matchTy ign ty arg NoIgnore -> Nothing - -- but we can safely ignore kind signatures on the target -matchTy ign pat (DSigT ty _ki) = matchTy ign pat ty +matchTy ign (DAppKindT ty _ki) arg = case ign of + YesIgnore -> matchTy ign ty arg + NoIgnore -> Nothing + -- but we can safely ignore kind signatures on the target, + -- as in the following two cases. +matchTy ign pat (DSigT ty _ki) = matchTy ign pat ty +matchTy ign pat (DAppKindT ty _ki) = matchTy ign pat ty matchTy _ (DForallT {}) _ = error "Cannot match a forall in a pattern" matchTy _ _ (DForallT {}) = diff --git a/Language/Haskell/TH/Desugar/Subst/Capturing.hs b/Language/Haskell/TH/Desugar/Subst/Capturing.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/TH/Desugar/Subst/Capturing.hs @@ -0,0 +1,77 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Language.Haskell.TH.Desugar.Subst.Capturing +-- Copyright : (C) 2024 Ryan Scott +-- License : BSD-style (see LICENSE) +-- Maintainer : Ryan Scott +-- Stability : experimental +-- Portability : non-portable +-- +-- Substitutions on 'DType's that do /not/ avoid capture. (For capture-avoiding +-- substitution functions, use "Language.Haskell.TH.Desugar.Subst" instead.) +-- +---------------------------------------------------------------------------- + +module Language.Haskell.TH.Desugar.Subst.Capturing ( + DSubst, + + -- * Non–capture-avoiding substitution + substTy, substForallTelescope, substTyVarBndrs, substTyVarBndr, + unionSubsts, unionMaybeSubsts, + + -- * Matching a type template against a type + IgnoreKinds(..), matchTy + ) where + +import Data.Bifunctor (second) +import qualified Data.List as L +import qualified Data.Map as M + +import Language.Haskell.TH.Desugar.AST +import Language.Haskell.TH.Desugar.Subst + (DSubst, unionSubsts, unionMaybeSubsts, IgnoreKinds(..), matchTy) + +-- | Non–capture-avoiding substitution on 'DType's. Unlike the @substTy@ +-- function in "Language.Haskell.TH.Desugar.Subst", this 'substTy' function is +-- pure, as it never needs to create fresh names. +substTy :: DSubst -> DType -> DType +substTy subst ty | M.null subst = ty +substTy subst (DForallT tele inner_ty) + = DForallT tele' inner_ty' + where + (subst', tele') = substForallTelescope subst tele + inner_ty' = substTy subst' inner_ty +substTy subst (DConstrainedT cxt inner_ty) = + DConstrainedT (map (substTy subst) cxt) (substTy subst inner_ty) +substTy subst (DAppT ty1 ty2) = substTy subst ty1 `DAppT` substTy subst ty2 +substTy subst (DAppKindT ty ki) = substTy subst ty `DAppKindT` substTy subst ki +substTy subst (DSigT ty ki) = substTy subst ty `DSigT` substTy subst ki +substTy subst (DVarT n) = + case M.lookup n subst of + Just ki -> ki + Nothing -> DVarT n +substTy _ ty@(DConT {}) = ty +substTy _ ty@(DArrowT) = ty +substTy _ ty@(DLitT {}) = ty +substTy _ ty@DWildCardT = ty + +-- | Non–capture-avoiding substitution on 'DForallTelescope's. This returns a +-- pair containing the new 'DSubst' as well as a new 'DForallTelescope' value, +-- where the kinds have been substituted. +substForallTelescope :: DSubst -> DForallTelescope -> (DSubst, DForallTelescope) +substForallTelescope s (DForallInvis tvbs) = second DForallInvis $ substTyVarBndrs s tvbs +substForallTelescope s (DForallVis tvbs) = second DForallVis $ substTyVarBndrs s tvbs + +-- | Non–capture-avoiding substitution on a telescope of 'DTyVarBndr's. This +-- returns a pair containing the new 'DSubst' as well as a new telescope of +-- 'DTyVarBndr's, where the kinds have been substituted. +substTyVarBndrs :: DSubst -> [DTyVarBndr flag] -> (DSubst, [DTyVarBndr flag]) +substTyVarBndrs = L.mapAccumL substTyVarBndr + +-- | Non–capture-avoiding substitution on a 'DTyVarBndr'. This updates the +-- 'DSubst' to remove the 'DTyVarBndr' name from the domain (as that name is now +-- bound by the 'DTyVarBndr') and applies the substitution to the kind of the +-- 'DTyVarBndr'. +substTyVarBndr :: DSubst -> DTyVarBndr flag -> (DSubst, DTyVarBndr flag) +substTyVarBndr s tvb@(DPlainTV n _) = (M.delete n s, tvb) +substTyVarBndr s (DKindedTV n f k) = (M.delete n s, DKindedTV n f (substTy s k)) diff --git a/Language/Haskell/TH/Desugar/Sweeten.hs b/Language/Haskell/TH/Desugar/Sweeten.hs --- a/Language/Haskell/TH/Desugar/Sweeten.hs +++ b/Language/Haskell/TH/Desugar/Sweeten.hs @@ -39,7 +39,7 @@ import Prelude hiding (exp) import Control.Arrow -import Language.Haskell.TH hiding (cxt) +import Language.Haskell.TH hiding (Extension(..), cxt) import Language.Haskell.TH.Datatype.TyVarBndr import Language.Haskell.TH.Desugar.AST @@ -51,8 +51,6 @@ expToTH (DConE n) = ConE n expToTH (DLitE l) = LitE l expToTH (DAppE e1 e2) = AppE (expToTH e1) (expToTH e2) -expToTH (DLamE names exp) = LamE (map VarP names) (expToTH exp) -expToTH (DCaseE exp matches) = CaseE (expToTH exp) (map matchToTH matches) expToTH (DLetE decs exp) = LetE (map letDecToTH decs) (expToTH exp) expToTH (DSigE exp ty) = SigE (expToTH exp) (typeToTH ty) expToTH (DStaticE exp) = StaticE (expToTH exp) @@ -63,7 +61,94 @@ -- type applications, we will simply drop the applied type. expToTH (DAppTypeE exp _) = expToTH exp #endif +expToTH (DLamCasesE clauses) + -- In the source language, `\cases` expressions must have at least one clause. + -- As such, we adopt the convention that a DLamCasesE value with no clauses + -- shall sweeten to a `\case{}` expression. Unlike `\cases`, it is legal for + -- `\case` to have no clauses, and `\case{}` is assumed to have a single + -- argument. + | null clauses + = LamCaseE [] +#if __GLASGOW_HASKELL__ >= 904 + -- If building with GHC 9.4 or later, sweetening a DLamCasesE value is as + -- simple as using LamCasesE... + | otherwise + = LamCasesE (map clauseToTH clauses) +#else + -- ...but if we are building with a pre-9.4 version of GHC, we do not have + -- access to LamCasesE, making our life harder. We want to have at least + -- /some/ support for sweetening DLamCasesE values, since we desugar simpler + -- language constructs like lambda, `case`, and `\case` expressions to + -- DLamCasesE, and we'd like to be able to sweeten them back. + -- + -- Therefore, we add special treatment for DLamCasesE values that look simpler + -- language constructs and sweeten these back to LamE, LamCaseE, etc. If we + -- encounter anything more complicated, we give up and raise an error. + -- Special case: if a DLamCasesE value has exactly one clause, we can sweeten + -- the DLamCasesE value as though it were a lambda expression (LamE). + | [DClause pats exp] <- clauses + = LamE (map patToTH pats) (expToTH exp) + -- Special case: if a DLamCasesE value's clauses each have exactly one + -- pattern, we can sweeten the DLamCasesE value as though it were a `\case` + -- expression (LamCaseE). + | Just matches <- traverse dMatch_maybe clauses + = LamCaseE (map matchToTH matches) + -- NB: You might wonder why there is not another special case that returns + -- CaseE for things that look like `case` expressions. This is because the + -- special case for LamCaseE above already suffices. Note that we desugar + -- `case` expressions to code that looks like this: + -- + -- (\cases + -- pat_1 -> rhs_1 + -- ... + -- pat_n -> rhs_n) scrut + -- + -- That is, a value that looks like `DAppE (DLamCasesE ...) scrut`. Each + -- clause in the DLamCasesE value has exactly one pattern, however. Therefore, + -- because of the special treatment for LamCaseE above, this code would + -- sweeten to `AppE (LamCaseE ...) scrut`. + + -- If we lack a special case for the DLamCasesE value, then we raise an error. + | otherwise + = error $ unlines + [ "Non-trivial \\cases expressions supported only in GHC 9.4+." + , "Here, \"non-trivial\" means that the \\cases expression cannot easily" + , "be rewritten to a lambda, case, or \\case expression without" + , "significantly rewriting the expression. Either rewrite the expression" + , "yourself or upgrade to a later version of GHC." + ] +#endif +#if __GLASGOW_HASKELL__ >= 907 +expToTH (DTypedBracketE exp) = TypedBracketE (expToTH exp) +expToTH (DTypedSpliceE exp) = TypedSpliceE (expToTH exp) +#else +expToTH (DTypedBracketE {}) = + error "Typed Template Haskell brackets supported only in GHC 9.8+" +expToTH (DTypedSpliceE {}) = + error "Typed Template Haskell splices supported only in GHC 9.8+" +#endif +#if __GLASGOW_HASKELL__ >= 909 +expToTH (DTypeE ty) = TypeE (typeToTH ty) +#else +expToTH (DTypeE {}) = + error "Embedded type expressions supported only in GHC 9.10+" +#endif +#if __GLASGOW_HASKELL__ >= 911 +expToTH (DForallE tele exp) = + case tele of + DForallInvis tvbs -> ForallE (map tvbToTH tvbs) exp' + DForallVis tvbs -> ForallVisE (map tvbToTH tvbs) exp' + where + exp' = expToTH exp +expToTH (DConstrainedE cxt exp) = ConstrainedE (map expToTH cxt) (expToTH exp) +#else +expToTH (DForallE {}) = + error "Embedded `forall`s supported only in GHC 9.12+" +expToTH (DConstrainedE {}) = + error "Embedded constraints supported only in GHC 9.12+" +#endif + matchToTH :: DMatch -> Match matchToTH (DMatch pat exp) = Match (patToTH pat) (NormalB (expToTH exp)) [] @@ -79,6 +164,15 @@ patToTH (DBangP pat) = BangP (patToTH pat) patToTH (DSigP pat ty) = SigP (patToTH pat) (typeToTH ty) patToTH DWildP = WildP +#if __GLASGOW_HASKELL__ >= 909 +patToTH (DTypeP ty) = TypeP (typeToTH ty) +patToTH (DInvisP ty) = InvisP (typeToTH ty) +#else +patToTH (DTypeP {}) = + error "Embedded type patterns supported only in GHC 9.10+" +patToTH (DInvisP {}) = + error "Invisible type patterns supported only in GHC 9.10+" +#endif decsToTH :: [DDec] -> [Dec] decsToTH = map decToTH @@ -108,9 +202,10 @@ DataFamilyD n (map tvbToTH tvbs) (fmap typeToTH mk) decToTH (DDataInstD nd cxt mtvbs lhs mk cons derivings) = let ndc = case (nd, cons) of - (Newtype, [con]) -> DNewtypeCon con - (Newtype, _) -> error "Newtype that doesn't have only one constructor" - (Data, _) -> DDataCons cons + (Newtype, [con]) -> DNewtypeCon con + (Newtype, _) -> error "Newtype that doesn't have only one constructor" + (Data, _) -> DDataCons cons + (TypeData, _) -> error "Data family instance that is combined with `type data`" in dataInstDecToTH ndc cxt mtvbs lhs mk derivings #if __GLASGOW_HASKELL__ >= 807 decToTH (DTySynInstD eqn) = TySynInstD (snd $ tySynEqnToTH eqn) @@ -146,6 +241,15 @@ decToTH (DDefaultD{}) = error "Default declarations supported only in GHC 9.4+" #endif +#if __GLASGOW_HASKELL__ >= 906 +decToTH (DDataD TypeData _cxt n tvbs mk cons _derivings) = + -- NB: Due to the invariants on 'DDataD' and 'TypeData', _cxt and _derivings + -- will be empty. + TypeDataD n (map tvbToTH tvbs) (fmap typeToTH mk) (map conToTH cons) +#else +decToTH (DDataD TypeData _cxt _n _tvbs _mk _cons _derivings) = + error "`type data` declarations supported only in GHC 9.6+" +#endif #if __GLASGOW_HASKELL__ < 801 patSynErr :: a @@ -199,7 +303,12 @@ letDecToTH (DFunD name clauses) = FunD name (map clauseToTH clauses) letDecToTH (DValD pat exp) = ValD (patToTH pat) (NormalB (expToTH exp)) [] letDecToTH (DSigD name ty) = SigD name (typeToTH ty) -letDecToTH (DInfixD f name) = InfixD f name +letDecToTH (DInfixD f _ns_spec name) = + InfixD f +#if __GLASGOW_HASKELL__ >= 909 + _ns_spec +#endif + name letDecToTH (DPragmaD prag) = PragmaD (pragmaToTH prag) conToTH :: DCon -> Con @@ -254,6 +363,22 @@ pragmaToTH (DOpaqueP n) = OpaqueP n #else pragmaToTH (DOpaqueP {}) = error "OPAQUE pragmas only supported in GHC 9.4+" +#endif +#if __GLASGOW_HASKELL__ >= 909 +pragmaToTH (DSCCP nm mstr) = SCCP nm mstr +#else +pragmaToTH (DSCCP {}) = error "SCCP pragmas only supported in GHC 9.10+" +#endif +#if __GLASGOW_HASKELL__ >= 913 +pragmaToTH (DSpecialiseEP mTyBndrs tmBndrs specE mInline phases) = + SpecialiseEP + (fmap (fmap tvbToTH) mTyBndrs) + (map ruleBndrToTH tmBndrs) + (expToTH specE) + mInline + phases +#else +pragmaToTH (DSpecialiseEP {}) = error "DSpecialiseEP pragmas only supported in GHC 9.14+" #endif ruleBndrToTH :: DRuleBndr -> RuleBndr 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 @@ -6,9 +6,9 @@ Utility functions for th-desugar package. -} -{-# LANGUAGE CPP, DeriveDataTypeable, RankNTypes, ScopedTypeVariables, - TupleSections, AllowAmbiguousTypes, TemplateHaskellQuotes, - TypeApplications #-} +{-# LANGUAGE CPP, DeriveDataTypeable, DeriveGeneric, DeriveLift, RankNTypes, + ScopedTypeVariables, TupleSections, AllowAmbiguousTypes, + TemplateHaskellQuotes, TypeApplications, MagicHash #-} module Language.Haskell.TH.Desugar.Util ( newUniqueName, @@ -16,39 +16,71 @@ nameOccursIn, allNamesIn, mkTypeName, mkDataName, mkNameWith, isDataName, stripVarP_maybe, extractBoundNamesStmt, concatMapM, mapAccumLM, mapMaybeM, expectJustM, - stripPlainTV_maybe, + stripPlainTV_maybe, extractTvbKind_maybe, thirdOf3, splitAtList, extractBoundNamesDec, extractBoundNamesPat, - tvbToType, tvbToTypeWithSig, tvbToTANormalWithSig, - nameMatches, thdOf3, liftFst, liftSnd, firstMatch, - unboxedSumDegree_maybe, unboxedSumNameDegree_maybe, - tupleDegree_maybe, tupleNameDegree_maybe, unboxedTupleDegree_maybe, - unboxedTupleNameDegree_maybe, splitTuple_maybe, + tvbToType, tvbToTypeWithSig, + nameMatches, thdOf3, liftFst, liftSnd, firstMatch, firstMatchM, + tupleNameDegree_maybe, + unboxedSumNameDegree_maybe, unboxedTupleNameDegree_maybe, splitTuple_maybe, topEverywhereM, isInfixDataCon, isTypeKindName, typeKindName, unSigType, unfoldType, ForallTelescope(..), FunArgs(..), VisFunArg(..), filterVisFunArgs, ravelType, unravelType, TypeArg(..), applyType, filterTANormals, probablyWrongUnTypeArg, - bindIP + tyVarBndrVisToTypeArg, tyVarBndrVisToTypeArgWithSig, + bindIP, + DataFlavor(..), + freeKindVariablesWellScoped, + ForAllTyFlag(..), tvbForAllTyFlagsToSpecs, tvbForAllTyFlagsToBndrVis, + matchUpSAKWithDecl ) where import Prelude hiding (mapM, foldl, concatMap, any) import Language.Haskell.TH hiding ( cxt ) +import Language.Haskell.TH.Datatype import Language.Haskell.TH.Datatype.TyVarBndr import qualified Language.Haskell.TH.Desugar.OSet as OS import Language.Haskell.TH.Desugar.OSet (OSet) +import Language.Haskell.TH.Instances () import Language.Haskell.TH.Syntax import qualified Control.Monad.Fail as Fail import Data.Foldable +import Data.Function ( on ) +import Data.Generics ( Data, Typeable, everything, extM, gmapM, mkQ ) import qualified Data.Kind as Kind -import Data.Generics hiding ( Fixity ) -import Data.Traversable +import qualified Data.List as List +import qualified Data.Map as Map +import Data.Map ( Map ) import Data.Maybe +import qualified Data.Set as Set +import Data.Traversable import GHC.Classes ( IP ) +import GHC.Generics ( Generic ) import Unsafe.Coerce ( unsafeCoerce ) +#if __GLASGOW_HASKELL__ >= 900 +import Language.Haskell.TH.Ppr ( PprFlag(..) ) +import qualified Language.Haskell.TH.PprLib as Ppr +#endif + +#if __GLASGOW_HASKELL__ >= 906 +import GHC.Tuple ( Solo(MkSolo) ) +#elif __GLASGOW_HASKELL__ >= 900 +import GHC.Tuple ( Solo(Solo) ) +#endif + +#if __GLASGOW_HASKELL__ >= 908 +import GHC.Tuple ( Tuple0, Unit ) +import Text.Read ( readMaybe ) +#endif + +#if __GLASGOW_HASKELL__ >= 910 +import GHC.Types ( Solo#, Sum2#, Tuple0#, Unit# ) +#endif + ---------------------------------------- -- TH manipulations ---------------------------------------- @@ -101,6 +133,11 @@ stripPlainTV_maybe :: TyVarBndr_ flag -> Maybe Name stripPlainTV_maybe = elimTV Just (\_ _ -> Nothing) +-- | Extracts the kind from a 'TyVarBndr'. Returns @'Just' k@ if the 'TyVarBndr' +-- is a 'KindedTV' and returns 'Nothing' if it is a 'PlainTV'. +extractTvbKind_maybe :: TyVarBndr_ flag -> Maybe Kind +extractTvbKind_maybe = elimTV (\_ -> Nothing) (\_ k -> Just k) + -- | Report that a certain TH construct is impossible impossible :: Fail.MonadFail q => String -> q a impossible err = Fail.fail (err ++ "\n This should not happen in Haskell.\n Please email rae@cs.brynmawr.edu with your code if you see this.") @@ -115,11 +152,6 @@ tvbToTypeWithSig :: TyVarBndr_ flag -> Type tvbToTypeWithSig = elimTV VarT (\n k -> SigT (VarT n) k) --- | Convert a 'TyVarBndr' into a 'TypeArg' (specifically, a 'TANormal'), --- preserving the kind signature (if it has one). -tvbToTANormalWithSig :: TyVarBndr_ flag -> TypeArg -tvbToTANormalWithSig = TANormal . tvbToTypeWithSig - -- | Do two names name the same thing? nameMatches :: Name -> Name -> Bool nameMatches n1@(Name occ1 flav1) n2@(Name occ2 flav2) @@ -137,27 +169,103 @@ | otherwise = n1 == n2 --- | Extract the degree of a tuple -tupleDegree_maybe :: String -> Maybe Int -tupleDegree_maybe s = do - '(' : s1 <- return s - (commas, ")") <- return $ span (== ',') s1 - let degree - | "" <- commas = 0 - | otherwise = length commas + 1 - return degree - --- | Extract the degree of a tuple name +-- | Extract the degree of a tuple 'Name'. +-- +-- In addition to recognizing tuple syntax (e.g., @''(,,)@), this also +-- recognizes the following: +-- +-- * @''Unit@ (for 0-tuples) +-- +-- * @''Solo@/@'MkSolo@ (for 1-tuples) +-- +-- * @''Tuple@ (for -tuples) +-- +-- In recent versions of GHC, @''()@ is a synonym for @''Unit@, @''(,)@ is a +-- synonym for @''Tuple2@, and so on. As a result, we must check for @''Unit@ +-- and @''Tuple@ in 'tupleDegree_maybe' to be thorough. (There is no special +-- tuple syntax for @''Solo@/@'MkSolo@, but we check them here as well for the +-- sake of completeness.) tupleNameDegree_maybe :: Name -> Maybe Int -tupleNameDegree_maybe = tupleDegree_maybe . nameBase +tupleNameDegree_maybe name + -- First, check for Solo/MkSolo... +#if __GLASGOW_HASKELL__ >= 900 + | name == ''Solo = Just 1 +#if __GLASGOW_HASKELL__ >= 906 + | name == 'MkSolo = Just 1 +#else + | name == 'Solo = Just 1 +#endif +#endif +#if __GLASGOW_HASKELL__ >= 908 + -- ...then, check for Unit... + | name == ''Unit = Just 0 + -- ...then, check for Tuple. It is theoretically possible for the supplied + -- Name to be a user-defined data type named Tuple, rather than the actual + -- tuple types defined in GHC.Tuple. As such, we check that the package and + -- module for the supplied Name does in fact come from ghc-prim:GHC.Tuple as + -- a sanity check. + | -- We use Tuple0 here simply because it is a convenient identifier from + -- GHC.Tuple. We could just as well use any other identifier from GHC.Tuple, + -- however. + namePackage name == namePackage ''Tuple0 + , nameModule name == nameModule ''Tuple0 + , 'T':'u':'p':'l':'e':n <- nameBase name + -- This relies on the Read Int instance. This is more permissive than what + -- we need, since there are valid Int strings (e.g., "-1") that do not have + -- corresponding Tuple names (e.g., "Tuple-1" is not a data type in + -- GHC.Tuple). As such, we depend on the assumption that the input string + -- does in fact come from GHC.Tuple, which we check above. + = readMaybe n +#endif + -- ...otherwise, fall back on tuple syntax. + | otherwise + = tuple_syntax_degree_maybe (nameBase name) + where + -- Extract the degree of a string using tuple syntax (e.g., @''(,,)@). + tuple_syntax_degree_maybe :: String -> Maybe Int + tuple_syntax_degree_maybe s = do + '(' : s1 <- return s + (commas, ")") <- return $ span (== ',') s1 + let degree + | "" <- commas = 0 + | otherwise = length commas + 1 + return degree -- | Extract the degree of an unboxed sum unboxedSumDegree_maybe :: String -> Maybe Int unboxedSumDegree_maybe = unboxedSumTupleDegree_maybe '|' --- | Extract the degree of an unboxed sum name +-- | Extract the degree of an unboxed sum 'Name'. +-- +-- In addition to recognizing unboxed sum syntax (e.g., @''(#||#)@), this also +-- recognizes @''Sum#@ (for unboxed -ary sum type constructors). In recent +-- versions of GHC, @''Sum2#@ is a synonym for @''(#|#)@, @''Sum3#@ is a synonym +-- for @''(#||#)@, and so on. As a result, we must check for @''Sum#@ in +-- 'unboxedSumNameDegree_maybe' to be thorough. unboxedSumNameDegree_maybe :: Name -> Maybe Int -unboxedSumNameDegree_maybe = unboxedSumDegree_maybe . nameBase +unboxedSumNameDegree_maybe name +#if __GLASGOW_HASKELL__ >= 910 + -- Check for Sum#. It is theoretically possible for the supplied + -- Name to be a user-defined data type named Sum#, rather than the actual + -- unboxed sum types defined in GHC.Types. As such, we check that the package + -- and module for the supplied Name does in fact come from ghc-prim:GHC.Types + -- as a sanity check. + | -- We use Sum2# here simply because it is a convenient identifier from + -- GHC.Types. We could just as well use any other identifier from GHC.Types, + -- however. + namePackage name == namePackage ''Sum2# + , nameModule name == nameModule ''Sum2# + , 'S':'u':'m':n:"#" <- nameBase name + -- This relies on the Read Int instance. This is more permissive than what + -- we need, since there are valid Int strings (e.g., "-1") that do not have + -- corresponding Sum# names (e.g., "Sum-1#" is not a data type in + -- GHC.Types). As such, we depend on the assumption that the input string + -- does in fact come from GHC.Types, which we check above. + = readMaybe [n] +#endif + -- ...otherwise, fall back on unboxed sum syntax. + | otherwise + = unboxedSumDegree_maybe (nameBase name) -- | Extract the degree of an unboxed tuple unboxedTupleDegree_maybe :: String -> Maybe Int @@ -173,9 +281,50 @@ | otherwise = length seps + 1 return degree --- | Extract the degree of an unboxed tuple name +-- | Extract the degree of an unboxed tuple 'Name'. +-- +-- In addition to recognizing unboxed tuple syntax (e.g., @''(#,,#)@), this also +-- recognizes the following: +-- +-- * @''Unit#@ (for unboxed 0-tuples) +-- +-- * @''Solo#@/@'Solo#@ (for unboxed 1-tuples) +-- +-- * @''Tuple#@ (for unboxed -tuples) +-- +-- In recent versions of GHC, @''(##)@ is a synonym for @''Unit#@, @''(#,#)@ is +-- a synonym for @''Tuple2#@, and so on. As a result, we must check for +-- @''Unit#@, and @''Tuple@ in 'unboxedTupleNameDegree_maybe' to be thorough. +-- (There is no special unboxed tuple type constructor for @''Solo#@/@'Solo#@, +-- but we check them here as well for the sake of completeness.) unboxedTupleNameDegree_maybe :: Name -> Maybe Int -unboxedTupleNameDegree_maybe = unboxedTupleDegree_maybe . nameBase +unboxedTupleNameDegree_maybe name +#if __GLASGOW_HASKELL__ >= 910 + -- First, check for Solo#... + | name == ''Solo# = Just 1 + -- ...then, check for Unit#... + | name == ''Unit# = Just 0 + -- ...then, check for Tuple#. It is theoretically possible for the supplied + -- Name to be a user-defined data type named Tuple#, rather than the actual + -- unboxed tuple types defined in GHC.Types. As such, we check that the + -- package and module for the supplied Name does in fact come from + -- ghc-prim:GHC.Types as a sanity check. + | -- We use Tuple0# here simply because it is a convenient identifier from + -- GHC.Types. We could just as well use any other identifier from GHC.Types, + -- however. + namePackage name == namePackage ''Tuple0# + , nameModule name == nameModule ''Tuple0# + , 'T':'u':'p':'l':'e':n:"#" <- nameBase name + -- This relies on the Read Int instance. This is more permissive than what + -- we need, since there are valid Int strings (e.g., "-1") that do not have + -- corresponding Tuple# names (e.g., "Tuple-1#" is not a data type in + -- GHC.Types). As such, we depend on the assumption that the input string + -- does in fact come from GHC.Types, which we check above. + = readMaybe [n] +#endif + -- ...otherwise, fall back on unboxed tuple syntax. + | otherwise + = unboxedTupleDegree_maybe (nameBase name) -- | If the argument is a tuple type, return the components splitTuple_maybe :: Type -> Maybe [Type] @@ -308,18 +457,40 @@ -- @ -- ('ConT' ''Proxy, ['TyArg' ('ConT' ''Type), 'TANormal' ('ConT' ''Char)]) -- @ +-- +-- This process forgets about infix application, so both of these types: +-- +-- @ +-- Int :++: Int +-- (:++:) Int Int +-- @ +-- +-- will be unfolded to this: +-- +-- @ +-- ('ConT' ''(:+:), ['TANormal' ('ConT' ''Int), 'TANormal' ('ConT' ''Int)]) +-- @ +-- +-- This function should only be used after all 'UInfixT' and 'PromotedUInfixT' +-- types have been resolved (e.g., via @th-abstraction@'s +-- @@ +-- function). unfoldType :: Type -> (Type, [TypeArg]) unfoldType = go [] where go :: [TypeArg] -> Type -> (Type, [TypeArg]) - go acc (ForallT _ _ ty) = go acc ty - go acc (AppT ty1 ty2) = go (TANormal ty2:acc) ty1 - go acc (SigT ty _) = go acc ty - go acc (ParensT ty) = go acc ty + go acc (ForallT _ _ ty) = go acc ty + go acc (AppT ty1 ty2) = go (TANormal ty2:acc) ty1 + go acc (SigT ty _) = go acc ty + go acc (ParensT ty) = go acc ty + go acc (InfixT ty1 n ty2) = go (TANormal ty1:TANormal ty2:acc) (ConT n) #if __GLASGOW_HASKELL__ >= 807 - go acc (AppKindT ty ki) = go (TyArg ki:acc) ty + go acc (AppKindT ty ki) = go (TyArg ki:acc) ty #endif - go acc ty = (ty, acc) +#if __GLASGOW_HASKELL__ >= 904 + go acc (PromotedInfixT ty1 n ty2) = go (TANormal ty1:TANormal ty2:acc) (PromotedT n) +#endif + go acc ty = (ty, acc) -- | An argument to a type, either a normal type ('TANormal') or a visible -- kind application ('TyArg'). @@ -354,6 +525,36 @@ getTANormal (TANormal t) = Just t getTANormal (TyArg {}) = Nothing +-- | Convert a 'TyVarBndrVis' to a 'TypeArg'. That is, convert a binder with a +-- 'BndrReq' visibility to a 'TANormal' and a binder with 'BndrInvis' +-- visibility to a 'TyArg'. +-- +-- If given a 'KindedTV', the resulting 'TypeArg' will omit the kind signature. +-- Use 'tyVarBndrVisToTypeArgWithSig' if you want to preserve the kind +-- signature. +tyVarBndrVisToTypeArg :: TyVarBndrVis -> TypeArg +tyVarBndrVisToTypeArg bndr = + case tvFlag bndr of + BndrReq -> TANormal bndr_ty + BndrInvis -> TyArg bndr_ty + where + bndr_ty = tvbToType bndr + +-- | Convert a 'TyVarBndrVis' to a 'TypeArg'. That is, convert a binder with a +-- 'BndrReq' visibility to a 'TANormal' and a binder with 'BndrInvis' +-- visibility to a 'TyArg'. +-- +-- If given a 'KindedTV', the resulting 'TypeArg' will preserve the kind +-- signature. Use 'tyVarBndrVisToTypeArg' if you want to omit the kind +-- signature. +tyVarBndrVisToTypeArgWithSig :: TyVarBndrVis -> TypeArg +tyVarBndrVisToTypeArgWithSig bndr = + case tvFlag bndr of + BndrReq -> TANormal bndr_ty + BndrInvis -> TyArg bndr_ty + where + bndr_ty = tvbToTypeWithSig bndr + -- | Extract the underlying 'Type' or 'Kind' from a 'TypeArg'. This forgets -- information about whether a type is a normal argument or not, so use with -- caution. @@ -361,6 +562,487 @@ probablyWrongUnTypeArg (TANormal t) = t probablyWrongUnTypeArg (TyArg k) = k +------------------------------------------------------------------------------- +-- Matching standalone kind signatures with binders in type-level declarations +------------------------------------------------------------------------------- + +-- @'matchUpSAKWithDecl' decl_sak decl_bndrs@ produces @TyVarBndr' +-- 'ForAllTyFlag'@s for a declaration, using the original declaration's +-- standalone kind signature (@decl_sak@) and its user-written binders +-- (@decl_bndrs@) as a template. For this example: +-- +-- @ +-- type D :: forall j k. k -> j -> Type +-- data D \@j \@l (a :: l) b = ... +-- @ +-- +-- We would produce the following @'TyVarBndr' 'ForAllTyFlag'@s: +-- +-- @ +-- \@j \@l (a :: l) (b :: j) +-- @ +-- +-- From here, these @'TyVarBndr' 'ForAllTyFlag'@s can be converted into other +-- forms of 'TyVarBndr's: +-- +-- * They can be converted to 'TyVarBndrSpec's using 'tvbForAllTyFlagsToSpecs'. +-- +-- * They can be converted to 'TyVarBndrVis'es using 'tvbForAllTyFlagsToVis'. +-- +-- Note that: +-- +-- * This function has a precondition that the length of @decl_bndrs@ must +-- always be equal to the number of visible quantifiers (i.e., the number of +-- function arrows plus the number of visible @forall@–bound variables) in +-- @decl_sak@. +-- +-- * Whenever possible, this function reuses type variable names from the +-- declaration's user-written binders. This is why the @'TyVarBndr' +-- 'ForAllTyFlag'@ use @\@j \@l@ instead of @\@j \@k@, since the @(a :: l)@ +-- binder uses @l@ instead of @k@. We could have just as well chose the other +-- way around, but we chose to pick variable names from the user-written +-- binders since they scope over other parts of the declaration. (For example, +-- the user-written binders of a @data@ declaration scope over the type +-- variables mentioned in a @deriving@ clause.) As such, keeping these names +-- avoids having to perform some alpha-renaming. +-- +-- This function's implementation was heavily inspired by parts of GHC's +-- kcCheckDeclHeader_sig function: +-- https://gitlab.haskell.org/ghc/ghc/-/blob/1464a2a8de082f66ae250d63ab9d94dbe2ef8620/compiler/GHC/Tc/Gen/HsType.hs#L2524-2643 +matchUpSAKWithDecl :: + forall q. + Fail.MonadFail q + => Kind + -- ^ The declaration's standalone kind signature + -> [TyVarBndrVis] + -- ^ The user-written binders in the declaration + -> q [TyVarBndr_ ForAllTyFlag] +matchUpSAKWithDecl decl_sak decl_bndrs = do + -- (1) First, explicitly quantify any free kind variables in `decl_sak` using + -- an invisible @forall@. This is done to ensure that precondition (2) in + -- `matchUpSigWithDecl` is upheld. (See the Haddocks for that function). + let decl_sak_free_tvbs = + changeTVFlags SpecifiedSpec $ freeVariablesWellScoped [decl_sak] + decl_sak' = ForallT decl_sak_free_tvbs [] decl_sak + + -- (2) Next, compute type variable binders using `matchUpSigWithDecl`. Note + -- that these can be biased towards type variable names mention in `decl_sak` + -- over names mentioned in `decl_bndrs`, but we will fix that up in the next + -- step. + let (decl_sak_args, _) = unravelType decl_sak' + sing_sak_tvbs <- matchUpSigWithDecl decl_sak_args decl_bndrs + + -- (3) Finally, swizzle the type variable names so that names in `decl_bndrs` + -- are preferred over names in `decl_sak`. + -- + -- This is heavily inspired by similar code in GHC: + -- https://gitlab.haskell.org/ghc/ghc/-/blob/cec903899234bf9e25ea404477ba846ac1e963bb/compiler/GHC/Tc/Gen/HsType.hs#L2607-2616 + let invis_decl_sak_args = filterInvisTvbArgs decl_sak_args + invis_decl_sak_arg_nms = map tvName invis_decl_sak_args + + invis_decl_bndrs = freeKindVariablesWellScoped decl_bndrs + invis_decl_bndr_nms = map tvName invis_decl_bndrs + + swizzle_env = + Map.fromList $ zip invis_decl_sak_arg_nms invis_decl_bndr_nms + (_, swizzled_sing_sak_tvbs) = + List.mapAccumL (swizzleTvb swizzle_env) Map.empty sing_sak_tvbs + pure swizzled_sing_sak_tvbs + +-- Match the quantifiers in a type-level declaration's standalone kind signature +-- with the user-written binders in the declaration. This function assumes the +-- following preconditions: +-- +-- 1. The number of required binders in the declaration's user-written binders +-- is equal to the number of visible quantifiers (i.e., the number of +-- function arrows plus the number of visible @forall@–bound variables) in +-- the standalone kind signature. +-- +-- 2. The number of invisible \@-binders in the declaration's user-written +-- binders is less than or equal to the number of invisible quantifiers +-- (i.e., the number of invisible @forall@–bound variables) in the +-- standalone kind signature. +-- +-- The implementation of this function is heavily based on a GHC function of +-- the same name: +-- https://gitlab.haskell.org/ghc/ghc/-/blob/1464a2a8de082f66ae250d63ab9d94dbe2ef8620/compiler/GHC/Tc/Gen/HsType.hs#L2645-2715 +matchUpSigWithDecl :: + forall q. + Fail.MonadFail q + => FunArgs + -- ^ The quantifiers in the declaration's standalone kind signature + -> [TyVarBndrVis] + -- ^ The user-written binders in the declaration + -> q [TyVarBndr_ ForAllTyFlag] +matchUpSigWithDecl = go_fun_args Map.empty + where + go_fun_args :: + Map Name Type + -- ^ A substitution from the names of @forall@-bound variables in the + -- standalone kind signature to corresponding binder names in the + -- user-written binders. This is because we want to reuse type variable + -- names from the user-written binders whenever possible. For example: + -- + -- @ + -- type T :: forall a. forall b -> Maybe (a, b) -> Type + -- data T @x y z + -- @ + -- + -- After matching up the @a@ in @forall a.@ with @x@ and + -- the @b@ in @forall b ->@ with @y@, this substitution will be + -- extended with @[a :-> x, b :-> y]@. This ensures that we will + -- produce @Maybe (x, y)@ instead of @Maybe (a, b)@ in + -- the kind for @z@. + -> FunArgs -> [TyVarBndrVis] -> q [TyVarBndr_ ForAllTyFlag] + go_fun_args _ FANil [] = + pure [] + -- This should not happen, per precondition (1). + go_fun_args _ FANil decl_bndrs = + fail $ "matchUpSigWithDecl.go_fun_args: Too many binders: " ++ show decl_bndrs + -- GHC now disallows kind-level constraints, per this GHC proposal: + -- https://github.com/ghc-proposals/ghc-proposals/blob/b0687d96ce8007294173b7f628042ac4260cc738/proposals/0547-no-kind-equalities.rst + -- As such, we reject non-empty kind contexts. Empty contexts (which are + -- benign) can sometimes arise due to @ForallT@, so we add a special case + -- to allow them. + go_fun_args subst (FACxt [] args) decl_bndrs = + go_fun_args subst args decl_bndrs + go_fun_args _ (FACxt (_:_) _) _ = + fail "matchUpSigWithDecl.go_fun_args: Unexpected kind-level constraint" + go_fun_args subst (FAForalls (ForallInvis tvbs) sig_args) decl_bndrs = + go_invis_tvbs subst tvbs sig_args decl_bndrs + go_fun_args subst (FAForalls (ForallVis tvbs) sig_args) decl_bndrs = + go_vis_tvbs subst tvbs sig_args decl_bndrs + go_fun_args subst (FAAnon anon sig_args) (decl_bndr:decl_bndrs) = + case tvFlag decl_bndr of + -- If the next decl_bndr is required, then we must match its kind (if + -- one is provided) against the anonymous kind argument. + BndrReq -> do + let decl_bndr_name = tvName decl_bndr + mb_decl_bndr_kind = extractTvbKind_maybe decl_bndr + anon' = applySubstitution subst anon + + anon'' = + case mb_decl_bndr_kind of + Nothing -> anon' + Just decl_bndr_kind -> do + let mb_match_subst = matchTy decl_bndr_kind anon' + maybe decl_bndr_kind (`applySubstitution` decl_bndr_kind) mb_match_subst + sig_args' <- go_fun_args subst sig_args decl_bndrs + pure $ kindedTVFlag decl_bndr_name Required anon'' : sig_args' + -- We have a visible, anonymous argument in the kind, but an invisible + -- @-binder as the next decl_bndr. This is ill kinded, so throw an + -- error. + -- + -- This should not happen, per precondition (2). + BndrInvis -> + fail $ "dMatchUpSigWithDecl.go_fun_args: Expected visible binder, encountered invisible binder: " + ++ show decl_bndr + -- This should not happen, per precondition (1). + go_fun_args _ _ [] = + fail "matchUpSigWithDecl.go_fun_args: Too few binders" + + go_invis_tvbs :: + Map Name Type + -> [TyVarBndrSpec] + -> FunArgs + -> [TyVarBndrVis] + -> q [TyVarBndr_ ForAllTyFlag] + go_invis_tvbs subst [] sig_args decl_bndrs = + go_fun_args subst sig_args decl_bndrs + go_invis_tvbs subst (invis_tvb:invis_tvbs) sig_args decl_bndrss = + case decl_bndrss of + [] -> skip_invis_bndr + decl_bndr:decl_bndrs -> + case tvFlag decl_bndr of + BndrReq -> skip_invis_bndr + -- If the next decl_bndr is an invisible @-binder, then we must match it + -- against the invisible forall–bound variable in the kind. + BndrInvis -> do + let (subst', sig_tvb) = match_tvbs subst invis_tvb decl_bndr + sig_args' <- go_invis_tvbs subst' invis_tvbs sig_args decl_bndrs + pure (mapTVFlag Invisible sig_tvb : sig_args') + where + -- There is an invisible forall in the kind without a corresponding + -- invisible @-binder, which is allowed. In this case, we simply apply + -- the substitution and recurse. + skip_invis_bndr :: q [TyVarBndr_ ForAllTyFlag] + skip_invis_bndr = do + let (subst', invis_tvb') = substTvb subst invis_tvb + sig_args' <- go_invis_tvbs subst' invis_tvbs sig_args decl_bndrss + pure $ mapTVFlag Invisible invis_tvb' : sig_args' + + go_vis_tvbs :: + Map Name Type + -> [TyVarBndrUnit] + -> FunArgs + -> [TyVarBndrVis] + -> q [TyVarBndr_ ForAllTyFlag] + go_vis_tvbs subst [] sig_args decl_bndrs = + go_fun_args subst sig_args decl_bndrs + -- This should not happen, per precondition (1). + go_vis_tvbs _ (_:_) _ [] = + fail "matchUpSigWithDecl.go_vis_tvbs: Too few binders" + go_vis_tvbs subst (vis_tvb:vis_tvbs) sig_args (decl_bndr:decl_bndrs) = do + case tvFlag decl_bndr of + -- If the next decl_bndr is required, then we must match it against the + -- visible forall–bound variable in the kind. + BndrReq -> do + let (subst', sig_tvb) = match_tvbs subst vis_tvb decl_bndr + sig_args' <- go_vis_tvbs subst' vis_tvbs sig_args decl_bndrs + pure (mapTVFlag (const Required) sig_tvb : sig_args') + -- We have a visible forall in the kind, but an invisible @-binder as + -- the next decl_bndr. This is ill kinded, so throw an error. + -- + -- This should not happen, per precondition (2). + BndrInvis -> + fail $ "matchUpSigWithDecl.go_vis_tvbs: Expected visible binder, encountered invisible binder: " + ++ show decl_bndr + + -- @match_tvbs subst sig_tvb decl_bndr@ will match the kind of @decl_bndr@ + -- against the kind of @sig_tvb@ to produce a new kind. This function + -- produces two values as output: + -- + -- 1. A new @subst@ that has been extended such that the name of @sig_tvb@ + -- maps to the name of @decl_bndr@. (See the Haddocks for the @Map Name + -- Type@ argument to @go_fun_args@ for an explanation of why we do this.) + -- + -- 2. A 'TyVarBndrSpec' that has the name of @decl_bndr@, but with the new + -- kind resulting from matching. + match_tvbs :: + Map Name Type + -> TyVarBndr_ flag + -> TyVarBndrVis + -> (Map Name Type, TyVarBndr_ flag) + match_tvbs subst sig_tvb decl_bndr = + let decl_bndr_name = tvName decl_bndr + mb_decl_bndr_kind = extractTvbKind_maybe decl_bndr + + sig_tvb_name = tvName sig_tvb + sig_tvb_flag = tvFlag sig_tvb + mb_sig_tvb_kind = applySubstitution subst <$> extractTvbKind_maybe sig_tvb + + mb_kind :: Maybe Kind + mb_kind = + case (mb_decl_bndr_kind, mb_sig_tvb_kind) of + (Nothing, Nothing) -> Nothing + (Just decl_bndr_kind, Nothing) -> Just decl_bndr_kind + (Nothing, Just sig_tvb_kind) -> Just sig_tvb_kind + (Just decl_bndr_kind, Just sig_tvb_kind) -> do + match_subst <- matchTy decl_bndr_kind sig_tvb_kind + Just $ applySubstitution match_subst decl_bndr_kind + + subst' = Map.insert sig_tvb_name (VarT decl_bndr_name) subst + sig_tvb' = case mb_kind of + Nothing -> plainTVFlag decl_bndr_name sig_tvb_flag + Just kind -> kindedTVFlag decl_bndr_name sig_tvb_flag kind in + + (subst', sig_tvb') + +-- Collect the invisible type variable binders from a sequence of FunArgs. +filterInvisTvbArgs :: FunArgs -> [TyVarBndrSpec] +filterInvisTvbArgs FANil = [] +filterInvisTvbArgs (FACxt _ args) = filterInvisTvbArgs args +filterInvisTvbArgs (FAAnon _ args) = filterInvisTvbArgs args +filterInvisTvbArgs (FAForalls tele args) = + let res = filterInvisTvbArgs args in + case tele of + ForallVis _ -> res + ForallInvis tvbs' -> tvbs' ++ res + +-- | Take a telescope of 'TyVarBndr's, find the free variables in their kinds, +-- and sort them in reverse topological order to ensure that they are well +-- scoped. Because the argument list is assumed to be telescoping, kind +-- variables that are bound earlier in the list are not returned. For example, +-- this: +-- +-- @ +-- 'freeKindVariablesWellScoped' [a :: k, b :: Proxy a] +-- @ +-- +-- Will return @[k]@, not @[k, a]@, since @a@ is bound earlier by @a :: k@. +freeKindVariablesWellScoped :: [TyVarBndr_ flag] -> [TyVarBndrUnit] +freeKindVariablesWellScoped tvbs = + foldr (\tvb kvs -> + foldMap (\t -> freeVariablesWellScoped [t]) (extractTvbKind_maybe tvb) `List.union` + List.deleteBy ((==) `on` tvName) tvb kvs) + [] + (changeTVFlags () tvbs) + +-- | @'matchTy' tmpl targ@ matches a type template @tmpl@ against a type target +-- @targ@. This returns a Map from names of type variables in the type template +-- to types if the types indeed match up, or @Nothing@ otherwise. In the @Just@ +-- case, it is guaranteed that every type variable mentioned in the template is +-- mapped by the returned substitution. +-- +-- Note that this function will always return @Nothing@ if the template contains +-- an explicit kind signature or visible kind application. +-- +-- This is heavily inspired by the function of the same name in +-- "Language.Haskell.TH.Desugar.Subst", which works over 'DType's instead of +-- 'Type's. +matchTy :: Type -> Type -> Maybe (Map Name Type) +matchTy (VarT var_name) arg = Just $ Map.singleton var_name arg +matchTy (SigT {}) _ = Nothing +matchTy pat (SigT ty _ki) = matchTy pat ty +#if __GLASGOW_HASKELL__ >= 807 +matchTy (AppKindT {}) _ = Nothing +matchTy pat (AppKindT ty _ki) = matchTy pat ty +#endif +matchTy (ForallT {}) _ = + error "Cannot match a forall in a pattern" +matchTy _ (ForallT {}) = + error "Cannot match a forall in a target" +matchTy (AppT pat1 pat2) (AppT arg1 arg2) = + unionMaybeSubsts [matchTy pat1 arg1, matchTy pat2 arg2] +matchTy (ConT pat_con) (ConT arg_con) + | pat_con == arg_con + = Just Map.empty + | otherwise + = Nothing +matchTy ArrowT ArrowT = Just Map.empty +matchTy (LitT pat_lit) (LitT arg_lit) + | pat_lit == arg_lit + = Just Map.empty + | otherwise + = Nothing +matchTy _ _ = Nothing + +-- | This is inspired by the function of the same name in +-- "Language.Haskell.TH.Desugar.Subst". +unionMaybeSubsts :: [Maybe (Map Name Type)] -> Maybe (Map Name Type) +unionMaybeSubsts = List.foldl' union_subst1 (Just Map.empty) + where + union_subst1 :: + Maybe (Map Name Type) -> Maybe (Map Name Type) -> Maybe (Map Name Type) + union_subst1 ma mb = do + a <- ma + b <- mb + unionSubsts a b + +-- | Computes the union of two substitutions. Fails if both subsitutions map +-- the same variable to different types. +-- +-- This is inspired by the function of the same name in +-- "Language.Haskell.TH.Desugar.Subst". +unionSubsts :: Map Name Type -> Map Name Type -> Maybe (Map Name Type) +unionSubsts a b = + let shared_key_set = Map.keysSet a `Set.intersection` Map.keysSet b + matches_up = Set.foldr (\name -> ((a Map.! name) == (b Map.! name) &&)) + True shared_key_set + in + if matches_up then return (a `Map.union` b) else Nothing + +-- | This is inspired by the function of the same name in +-- "Language.Haskell.TH.Desugar.Subst.Capturing". +substTvb :: Map Name Kind -> TyVarBndr_ flag -> (Map Name Kind, TyVarBndr_ flag) +substTvb s tvb = (Map.delete (tvName tvb) s, mapTVKind (applySubstitution s) tvb) + +-- This is heavily inspired by the `swizzleTcb` function in GHC: +-- https://gitlab.haskell.org/ghc/ghc/-/blob/cec903899234bf9e25ea404477ba846ac1e963bb/compiler/GHC/Tc/Gen/HsType.hs#L2741-2755 +swizzleTvb :: + Map Name Name + -- ^ A \"swizzle environment\" (i.e., a map from binder names in a + -- standalone kind signature to binder names in the corresponding + -- type-level declaration). + -> Map Name Type + -- ^ Like the swizzle environment, but as a full-blown substitution. + -> TyVarBndr_ flag + -> (Map Name Type, TyVarBndr_ flag) +swizzleTvb swizzle_env subst tvb = + (subst', tvb2) + where + subst' = Map.insert tvb_name (VarT (tvName tvb2)) subst + tvb_name = tvName tvb + tvb1 = mapTVKind (applySubstitution subst) tvb + tvb2 = + case Map.lookup tvb_name swizzle_env of + Just user_name -> mapTVName (const user_name) tvb1 + Nothing -> tvb1 + +-- The visibility of a binder in a type-level declaration. This generalizes +-- 'Specificity' (which lacks an equivalent to 'Required') and 'BndrVis' (which +-- lacks an equivalent to @'Invisible' 'Inferred'@). +-- +-- This is heavily inspired by a data type of the same name in GHC: +-- https://gitlab.haskell.org/ghc/ghc/-/blob/98597ad5fca81544d74f721fb508295fd2650232/compiler/GHC/Types/Var.hs#L458-465 +data ForAllTyFlag + = Invisible !Specificity + -- ^ If the 'Specificity' value is 'SpecifiedSpec', then the binder is + -- permitted by request (e.g., @\@a@). If the 'Specificity' value is + -- 'InferredSpec', then the binder is prohibited from appearing in source + -- Haskell (e.g., @\@{a}@). + | Required + -- ^ The binder is required to appear in source Haskell (e.g., @a@). + deriving (Show, Eq, Ord, Data, Generic, Lift) + +instance DefaultBndrFlag ForAllTyFlag where + defaultBndrFlag = Required + +#if __GLASGOW_HASKELL__ >= 900 +instance PprFlag ForAllTyFlag where + pprTyVarBndr (PlainTV nm vis) = + pprForAllTyFlag vis (ppr nm) + pprTyVarBndr (KindedTV nm vis k) = + pprForAllTyFlag vis (Ppr.parens (ppr nm Ppr.<+> Ppr.dcolon Ppr.<+> ppr k)) + +pprForAllTyFlag :: ForAllTyFlag -> Ppr.Doc -> Ppr.Doc +pprForAllTyFlag (Invisible SpecifiedSpec) d = Ppr.char '@' Ppr.<> d +pprForAllTyFlag (Invisible InferredSpec) d = Ppr.braces d +pprForAllTyFlag Required d = d +#endif + +-- | Convert a list of @'TyVarBndr' 'ForAllTyFlag'@s to a list of +-- 'TyVarBndrSpec's, which is suitable for use in an invisible @forall@. +-- Specifically: +-- +-- * Variable binders that use @'Invisible' spec@ are converted to @spec@. +-- +-- * Variable binders that are 'Required' are converted to 'SpecifiedSpec', +-- as all of the 'TyVarBndrSpec's are invisible. As an example of how this +-- is used, consider what would happen when singling this data type: +-- +-- @ +-- type T :: forall k -> k -> Type +-- data T k (a :: k) where ... +-- @ +-- +-- Here, the @k@ binder is 'Required'. When we produce the standalone kind +-- signature for the singled data type, we use 'tvbForAllTyFlagsToSpecs' to +-- produce the type variable binders in the outermost @forall@: +-- +-- @ +-- type ST :: forall k (a :: k). T k a -> Type +-- data ST z where ... +-- @ +-- +-- Note that the @k@ is bound visibily (i.e., using 'SpecifiedSpec') in the +-- outermost, invisible @forall@. +tvbForAllTyFlagsToSpecs :: [TyVarBndr_ ForAllTyFlag] -> [TyVarBndrSpec] +tvbForAllTyFlagsToSpecs = map (mapTVFlag to_spec) + where + to_spec :: ForAllTyFlag -> Specificity + to_spec (Invisible spec) = spec + to_spec Required = SpecifiedSpec + +-- | Convert a list of @'TyVarBndr' 'ForAllTyFlag'@s to a list of +-- 'TyVarBndrVis'es, which is suitable for use in a type-level declaration +-- (e.g., the @var_1 ... var_n@ in @class C var_1 ... var_n@). Specifically: +-- +-- * Variable binders that use @'Invisible' 'InferredSpec'@ are dropped +-- entirely. Such binders cannot be represented in source Haskell. +-- +-- * Variable binders that use @'Invisible' 'SpecifiedSpec'@ are converted to +-- 'BndrInvis'. +-- +-- * Variable binders that are 'Required' are converted to 'BndrReq'. +tvbForAllTyFlagsToBndrVis :: [TyVarBndr_ ForAllTyFlag] -> [TyVarBndrVis] +tvbForAllTyFlagsToBndrVis = catMaybes . map (traverseTVFlag to_spec_maybe) + where + to_spec_maybe :: ForAllTyFlag -> Maybe BndrVis + to_spec_maybe (Invisible InferredSpec) = Nothing + to_spec_maybe (Invisible SpecifiedSpec) = Just bndrInvis + to_spec_maybe Required = Just BndrReq + ---------------------------------------- -- Free names, etc. ---------------------------------------- @@ -373,7 +1055,10 @@ allNamesIn :: Data a => a -> [Name] allNamesIn = everything (++) $ mkQ [] (:[]) --- | Extract the names bound in a @Stmt@ +-- | Extract the names bound in a @Stmt@. +-- +-- This does /not/ extract any type variables bound by pattern signatures, +-- constructor patterns, or type patterns. extractBoundNamesStmt :: Stmt -> OSet Name extractBoundNamesStmt (BindS pat _) = extractBoundNamesPat pat extractBoundNamesStmt (LetS decs) = foldMap extractBoundNamesDec decs @@ -384,12 +1069,18 @@ #endif -- | Extract the names bound in a @Dec@ that could appear in a @let@ expression. +-- +-- This does /not/ extract any type variables bound by pattern signatures, +-- constructor patterns, or type patterns. extractBoundNamesDec :: Dec -> OSet Name extractBoundNamesDec (FunD name _) = OS.singleton name extractBoundNamesDec (ValD pat _ _) = extractBoundNamesPat pat extractBoundNamesDec _ = OS.empty --- | Extract the names bound in a @Pat@ +-- | Extract the names bound in a @Pat@. +-- +-- This does /not/ extract any type variables bound by pattern signatures, +-- constructor patterns, or type patterns. extractBoundNamesPat :: Pat -> OSet Name extractBoundNamesPat (LitP _) = OS.empty extractBoundNamesPat (VarP name) = OS.singleton name @@ -418,6 +1109,13 @@ #if __GLASGOW_HASKELL__ >= 801 extractBoundNamesPat (UnboxedSumP pat _ _) = extractBoundNamesPat pat #endif +#if __GLASGOW_HASKELL__ >= 909 +extractBoundNamesPat (TypeP _) = OS.empty +extractBoundNamesPat (InvisP _) = OS.empty +#endif +#if __GLASGOW_HASKELL__ >= 911 +extractBoundNamesPat (OrP pats) = foldMap extractBoundNamesPat pats +#endif ---------------------------------------- -- General utility @@ -492,6 +1190,9 @@ firstMatch :: (a -> Maybe b) -> [a] -> Maybe b firstMatch f xs = listToMaybe $ mapMaybe f xs +firstMatchM :: Monad m => (a -> m (Maybe b)) -> [a] -> m (Maybe b) +firstMatchM f xs = listToMaybe <$> mapMaybeM f xs + -- | Semi-shallow version of 'everywhereM' - does not recurse into children of nodes of type @a@ (only applies the handler to them). -- -- >>> topEverywhereM (pure . fmap (*10) :: [Integer] -> Identity [Integer]) ([1,2,3] :: [Integer], "foo" :: String) @@ -532,3 +1233,11 @@ uniStarKindName :: Name uniStarKindName = ''(Kind.★) #endif + +-- | Is a data type or data instance declaration a @newtype@ declaration, a +-- @data@ declaration, or a @type data@ declaration? +data DataFlavor + = Newtype -- ^ @newtype@ + | Data -- ^ @data@ + | TypeData -- ^ @type data@ + deriving (Eq, Show, Data, Generic, Lift) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -31,6 +31,46 @@ Known limitations ----------------- +## Desugaring depends on language extensions of use sites + +Suppose you quote some Template Haskell declarations in module `A`: + +```hs +{-# LANGUAGE ... #-} +module A where + +decs :: Q [Dec] +decs = [d| ... |] +``` + +And later desugar the declarations with `th-desugar` in module `B`: + +```hs +{-# LANGUAGE ... #-} +module B where + +import A (decs) +import Language.Haskell.TH.Desugar (dsDecs) + +$(do desugaredDecs <- dsDecs decs + ...) +``` + +There are some situations where `th-desugar`'s desugaring depends on which +language extensions are enabled, such as: + +* `MonadFailDesugaring` (for desugaring partial pattern matches in `do` + notation) +* `NoFieldSelectors` (for determining if a record field can be reified as a + field selector with `lookupValueNameWithLocals`) + +Somewhat counterintuitively, `th-desugar` will consult the language extensions +in module `B` (the site where the `decs` are used) for this process, not module +`A` (where the `decs` were defined). This is really a Template Haskell +limitation, since Template Haskell does not offer any way to reify which +language extensions were enabled at the time the declarations were defined. As a +result, `th-desugar` can only check for language extensions at use sites. + ## Limited support for kind inference `th-desugar` sometimes has to construct types for certain Haskell entities. @@ -104,3 +144,268 @@ way that linear types interact with Template Haskell, which sometimes make it impossible to tell whether a reified function type is linear or not. See, for instance, [GHC#18378](https://gitlab.haskell.org/ghc/ghc/-/issues/18378). + +## Limitations of support for desugaring guards + +`th-desugar` supports guards in the sense that it will desugar guards to +equivalent code that instead uses `case` expressions. For example, this code: + +```hs +f (x, y) + | x == "hello" = x + | otherwise = y +``` + +Will be desugared to this code: + +```hs +f arg = + case arg of + (x, y) -> + case x2 == "hello" of + True -> x + False -> y +``` + +This has the advantage that it saves users from needing to care about the +complexities of guards. It does have some drawbacks, however, which we describe +below. + +### Desugaring guards can result in quadratic code size + +If you desugar this program involving guards: + +```hs +data T = A Int | B Int | C Int + +f :: T -> T -> Maybe Int +f (A x1) (A x2) + | x1 == x2 + = Just x1 +f (B x1) (B x2) + | x1 == x2 + = Just x1 +f (C x1) (C x2) + | x1 == x2 + = Just x1 +f _ _ = Nothing +``` + +You will end up with: + +```hs +f :: T -> T -> Maybe Int +f arg1 arg2 = + case (# arg1, arg2 #) of + (# A x1, A x2 #) -> + case x1 == x2 of + True -> + Just x1 + False -> + case (# arg1, arg2 #) of + (# B y1, B y2 #) -> + case y1 == y2 of + True -> + Just y1 + False -> + case (# arg1, arg2 #) of + (# C z1, C z2 #) -> + case z1 == z2 of + True -> + Just z1 + False -> + case (# arg1, arg2 #) of + (# _, _ #) -> + Nothing + (# _, _ #) -> + Nothing + (# C y1, C y2 #) -> + case y1 == y2 of + True -> + Just y1 + False -> + case (# arg1, arg2 #) of + (# _, _ #) -> + Nothing + (# _, _ #) -> + Nothing + (# B x1, B x2 #) -> + case x1 == x2 of + True -> + Just x1 + False -> + case (# arg1, arg2 #) of + (# C y1, C y2 #) -> + case y1 == y2 of + True -> + Just y1 + False -> + case (# arg1, arg2 #) of + (# _, _ #) -> + Nothing + (# _, _ #) -> + Nothing + (# C x1, C x2 #) -> + case x1 == x2 of + True -> + Just x1 + False -> + case (# arg1, arg2 #) of + (# _, _ #) -> + Nothing + (# _, _ #) -> + Nothing +``` + +That is signficantly more code. In the worst case, the algorithm that +`th-desugar` uses for desugaring guards can lead to a quadratic increase in +code size. One way to avoid this is avoid having incomplete guards that fall +through to later clauses. That is, if you rewrite the original code to this: + +```hs +f :: T -> T -> Maybe Int +f (A x1) (A x2) + | x1 == x2 + = Just x1 + | otherwise + = Nothing +f (B x1) (B x2) + | x1 == x2 + = Just x1 + | otherwise + = Nothing +f (C x1) (C x2) + | x1 == x2 + = Just x1 + | otherwise + = Nothing +``` + +Then `th-desugar` will desugar it to: + +```hs +f :: T -> T -> Maybe Int +f arg1 arg2 = + case (# arg1, arg2 #) of + (# A x1, A x2 #) -> + case x1 == x2 of + True -> + Just x1 + False -> + Nothing + (# B x1, B x2 #) -> + case x1 == x2 of + True -> + Just x1 + False -> + Nothing + (# C x1, C x2 #) -> + case x1 == x2 of + True -> + Just x1 + False -> + Nothing +``` + +This code, while still more verbose than the original, uses a constant amount +of extra code per clause. + +### Desugaring guards can produce more warnings than the original code + +The approach that `th-desugar` uses to desugar guards can result in code that +produces GHC compiler warnings (if `-fenable-th-splice-warnings` is enabled) +where the original code does not. For example, consider the example from above: + +```hs +data T = A Int | B Int | C Int + +f :: T -> T -> Maybe Int +f (A x1) (A x2) + | x1 == x2 + = Just x1 +f (B x1) (B x2) + | x1 == x2 + = Just x1 +f (C x1) (C x2) + | x1 == x2 + = Just x1 +f _ _ = Nothing +``` + +This code compiles without any GHC warnings. If you desugar this code using +`th-desugar`, however, it will produce these warnings: + +``` +warning: [-Woverlapping-patterns] + Pattern match is redundant + In a case alternative: (# B y1, B y2 #) -> ... + | + | (# B y1, B y2 #) -> + | ^^^^^^^^^^^^^^^^^^^... + +warning: [-Woverlapping-patterns] + Pattern match is redundant + In a case alternative: (# C y1, C y2 #) -> ... + | + | (# C y1, C y2 #) -> + | ^^^^^^^^^^^^^^^^^^^... + +warning: [-Woverlapping-patterns] + Pattern match is redundant + In a case alternative: (# C y1, C y2 #) -> ... + | + | (# C y1, C y2 #) -> + | ^^^^^^^^^^^^^^^^^^^... +``` + +GHC is correct here: these matches are wholly redundant. `th-desugar` could +potentially recognize this and perform a more sophisticated analysis to detect +and remove such matches when desugaring guards, but it currently doesn't do +such an analysis. + +## No support for view patterns + +`th-desugar` does not support desugaring view patterns. An alternative to using +view patterns in the patterns of a function is to use pattern guards. +Currently, there is not a viable workaround for using view patterns in pattern +synonym definitions—see [this `th-desugar` +issue](https://github.com/goldfirere/th-desugar/issues/174). + +## No support for or-patterns + +`th-desugar` does not support desugaring +[or-patterns](https://github.com/ghc-proposals/ghc-proposals/blob/c9401f037cb22d1661931b2ec621925101052997/proposals/0522-or-patterns.rst). +See [this `th-desugar` +issue](https://github.com/goldfirere/th-desugar/issues/232). + +## No support for `ApplicativeDo` + +`th-desugar` does not take the `ApplicativeDo` extension into account when +desugaring `do` notation. For example, if you desugar this: + +```hs +{-# LANGUAGE ApplicativeDo #-} + +f x y = do + x' <- x + y' <- y + return (x' ++ y') +``` + +Then `th-desugar` will translate the uses of `<-` in the `do` block to uses of +`Monad` operations (e.g., `(>>=)`) rather than `Applicative` operations (e.g., +`(<*>)`). See [this `th-desugar` +issue](https://github.com/goldfirere/th-desugar/issues/138). + +## No support for `RecursiveDo` + +`th-desugar` does not support the `RecursiveDo` extension at all, so it cannot +desugar any uses of `mdo` expressions or `rec` statements. + +## No support for unresolved infix operators + +`th-desugar` does not support desugaring unresolved infix operators, such as +`UInfixE`. You are unlikely to encounter this limitation when dealing with +Template Haskell quotes, since quoted infix operators will translate to uses of +`InfixE` rather than `UInfixE`. Rather, this limitation would only be +encountered if you manually construct a Template Haskell `Exp` using `UInfixE`. diff --git a/Test/Dec.hs b/Test/Dec.hs --- a/Test/Dec.hs +++ b/Test/Dec.hs @@ -9,6 +9,12 @@ FlexibleInstances, DataKinds, CPP, RankNTypes, StandaloneDeriving, DefaultSignatures, ConstraintKinds, RoleAnnotations, DeriveAnyClass #-} +#if __GLASGOW_HASKELL__ >= 810 +{-# LANGUAGE StandaloneKindSignatures #-} +#endif +#if __GLASGOW_HASKELL__ >= 907 +{-# LANGUAGE TypeAbstractions #-} +#endif {-# OPTIONS_GHC -Wno-orphans -Wno-name-shadowing -Wno-redundant-constraints #-} @@ -42,6 +48,15 @@ #if __GLASGOW_HASKELL__ >= 809 $(S.dectest18) +#endif + +#if __GLASGOW_HASKELL__ >= 907 +$(S.dectest19) +#endif + +#if __GLASGOW_HASKELL__ >= 909 +$(S.dectest20) +$(S.dectest21) #endif $(fmap unqualify S.instance_test) diff --git a/Test/DsDec.hs b/Test/DsDec.hs --- a/Test/DsDec.hs +++ b/Test/DsDec.hs @@ -8,10 +8,17 @@ MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, DataKinds, CPP, RankNTypes, StandaloneDeriving, DefaultSignatures, - ConstraintKinds, RoleAnnotations, DeriveAnyClass #-} + ConstraintKinds, RoleAnnotations, DeriveAnyClass, + TypeApplications #-} #if __GLASGOW_HASKELL__ >= 801 {-# LANGUAGE DerivingStrategies #-} #endif +#if __GLASGOW_HASKELL__ >= 810 +{-# LANGUAGE StandaloneKindSignatures #-} +#endif +#if __GLASGOW_HASKELL__ >= 907 +{-# LANGUAGE TypeAbstractions #-} +#endif {-# OPTIONS_GHC -Wno-orphans -Wno-incomplete-patterns -Wno-name-shadowing -Wno-redundant-constraints #-} @@ -21,6 +28,7 @@ import qualified Splices as S import Splices ( dsDecSplice, unqualify ) +import qualified Language.Haskell.TH.Datatype.TyVarBndr as THAbs import Language.Haskell.TH.Desugar import Language.Haskell.TH.Syntax ( qReport ) @@ -67,9 +75,18 @@ $(dsDecSplice S.dectest18) #endif +#if __GLASGOW_HASKELL__ >= 907 +$(dsDecSplice S.dectest19) +#endif + +#if __GLASGOW_HASKELL__ >= 909 +$(dsDecSplice S.dectest20) +$(dsDecSplice S.dectest21) +#endif + $(do decs <- S.rec_sel_test withLocalDeclarations decs $ do - [DDataD nd [] name [DPlainTV tvbName ()] k cons []] <- dsDecs decs + [DDataD nd [] name [DPlainTV tvbName THAbs.BndrReq] k cons []] <- dsDecs decs recsels <- getRecordSelectors cons let num_sels = length recsels `div` 2 -- ignore type sigs when (num_sels /= S.rec_sel_test_num_sels) $ @@ -82,5 +99,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) []] + plaindata = [DDataD nd [] name [DPlainTV tvbName THAbs.BndrReq] k (map unrecord cons) []] return (decsToTH plaindata ++ map letDecToTH recsels)) diff --git a/Test/FakeSums.hs b/Test/FakeSums.hs new file mode 100644 --- /dev/null +++ b/Test/FakeSums.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE MagicHash #-} + +-- | Defines data types with names identical to those found in "GHC.Types". +-- This is used as part of a series of unit tests for the +-- @unboxedSumNameDegree_maybe@ function, which should only return 'Just' when the +-- argument 'Name' is actually an unboxed sum from "GHC.Types", not a user-defined +-- type. +module FakeSums + ( Sum2#, Sum3#, Sum4# + ) where + +data Sum2# a b +data Sum3# a b c +data Sum4# a b c diff --git a/Test/FakeTuples.hs b/Test/FakeTuples.hs new file mode 100644 --- /dev/null +++ b/Test/FakeTuples.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE MagicHash #-} + +-- | Defines data types with names identical to those found in "GHC.Tuple". +-- This is used as part of a series of unit tests for the +-- @tupleNameDegree_maybe@ and @unboxedTupleNameDegree_maybe@ functions, which +-- should only return 'Just' when the argument 'Name' is actually a tuple from +-- "GHC.Tuple", not a user-defined type. +module FakeTuples + ( Tuple0, Tuple1, Tuple2, Tuple3 + , Tuple0#, Tuple1#, Tuple2#, Tuple3# + ) where + +data Tuple0 +data Tuple1 a +data Tuple2 a b +data Tuple3 a b c + +data Tuple0# +data Tuple1# a +data Tuple2# a b +data Tuple3# a b c diff --git a/Test/ReifyTypeCUSKs.hs b/Test/ReifyTypeCUSKs.hs --- a/Test/ReifyTypeCUSKs.hs +++ b/Test/ReifyTypeCUSKs.hs @@ -1,9 +1,12 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} +#if __GLASGOW_HASKELL__ < 806 {-# LANGUAGE TypeInType #-} +#endif #if __GLASGOW_HASKELL__ >= 809 {-# LANGUAGE CUSKs #-} #endif diff --git a/Test/Run.hs b/Test/Run.hs --- a/Test/Run.hs +++ b/Test/Run.hs @@ -10,7 +10,7 @@ FlexibleInstances, ExistentialQuantification, ScopedTypeVariables, GADTs, ViewPatterns, TupleSections, TypeOperators, PartialTypeSignatures, PatternSynonyms, - TypeApplications #-} + TypeApplications, MagicHash #-} {-# OPTIONS -Wno-incomplete-patterns -Wno-overlapping-patterns -Wno-unused-matches -Wno-type-defaults -Wno-missing-signatures -Wno-unused-do-bind @@ -22,10 +22,30 @@ {-# LANGUAGE QuantifiedConstraints #-} #endif +#if __GLASGOW_HASKELL__ < 806 +{-# LANGUAGE TypeInType #-} +#endif + #if __GLASGOW_HASKELL__ >= 809 {-# LANGUAGE StandaloneKindSignatures #-} #endif +#if __GLASGOW_HASKELL__ >= 906 +{-# LANGUAGE TypeData #-} +#endif + +#if __GLASGOW_HASKELL__ >= 907 +{-# LANGUAGE TypeAbstractions #-} +#endif + +#if __GLASGOW_HASKELL__ >= 909 +{-# LANGUAGE RequiredTypeArguments #-} +#endif + +#if __GLASGOW_HASKELL__ >= 911 +{-# LANGUAGE ImpredicativeTypes #-} +#endif + module Main where import Prelude hiding ( exp ) @@ -41,11 +61,13 @@ import ReifyTypeCUSKs import ReifyTypeSigs import T159Decs ( t159A, t159B ) +import T183 ( t183 ) +import qualified Language.Haskell.TH.Datatype.TyVarBndr as THAbs import Language.Haskell.TH.Desugar import qualified Language.Haskell.TH.Desugar.OSet as OS import Language.Haskell.TH.Desugar.Expand ( expandUnsoundly ) import Language.Haskell.TH -import qualified Language.Haskell.TH.Syntax as Syn ( lift ) +import qualified Language.Haskell.TH.Syntax as Syn import Control.Exception ( ErrorCall ) import Control.Monad @@ -54,9 +76,26 @@ import Data.Proxy #if __GLASGOW_HASKELL__ >= 900 +import Data.Kind (Constraint) import Prelude as P #endif +#if __GLASGOW_HASKELL__ >= 906 +import GHC.Tuple ( Solo(MkSolo) ) +#elif __GLASGOW_HASKELL__ >= 900 +import GHC.Tuple ( Solo(Solo) ) +#endif + +#if __GLASGOW_HASKELL__ >= 908 +import qualified FakeTuples +import GHC.Tuple ( Tuple0, Tuple1, Tuple2, Tuple3, Unit ) +#endif + +#if __GLASGOW_HASKELL__ >= 910 +import qualified FakeSums +import GHC.Types (Solo#, Sum2#, Sum3#, Sum4#, Tuple0#, Tuple1#, Tuple2#, Tuple3#, Unit#) +#endif + -- | -- Convert a HUnit test suite to a spec. This can be used to run existing -- HUnit tests with Hspec. @@ -151,6 +190,31 @@ , "opaque_pragma" ~: $test55_opaque_pragma @=? $(dsSplice test55_opaque_pragma) , "lambda_cases" ~: $test56_lambda_cases @=? $(dsSplice test56_lambda_cases) #endif +#if __GLASGOW_HASKELL__ >= 907 + , "typed_th_bracket" ~: $$($test57_typed_th_bracket) @=? $$($(dsSplice test57_typed_th_bracket)) + , "typed_th_splice" ~: $test58_typed_th_splice @=? $(dsSplice test58_typed_th_splice) +#endif +#if __GLASGOW_HASKELL__ >= 909 + , "embedded_types_keyword" ~: $test59_embedded_types_keyword @=? $(dsSplice test59_embedded_types_keyword) + , "embedded_types_no_keyword" ~: $test60_embedded_types_no_keyword @=? $(dsSplice test60_embedded_types_no_keyword) + , "invis_type_pat" ~: $test61_invis_type_pat @=? $(dsSplice test61_invis_type_pat) + , "embedded_types_lambda_keyword" ~: $test62_embedded_types_lambda_keyword @=? $(dsSplice test62_embedded_types_lambda_keyword) + , "embedded_types_case_keyword" ~: $test63_embedded_types_case_keyword @=? $(dsSplice test63_embedded_types_case_keyword) + , "embedded_types_cases_keyword" ~: $test64_embedded_types_cases_keyword @=? $(dsSplice test64_embedded_types_cases_keyword) + , "embedded_types_lambda_no_keyword" ~: $test65_embedded_types_lambda_no_keyword @=? $(dsSplice test65_embedded_types_lambda_no_keyword) + , "embedded_types_case_no_keyword" ~: $test66_embedded_types_case_no_keyword @=? $(dsSplice test66_embedded_types_case_no_keyword) + , "embedded_types_cases_no_keyword" ~: $test67_embedded_types_cases_no_keyword @=? $(dsSplice test67_embedded_types_cases_no_keyword) + , "invis_type_pat_lambda" ~: $test68_invis_type_pat_lambda @=? $(dsSplice test68_invis_type_pat_lambda) + , "invis_type_pat_cases" ~: $test69_invis_type_pat_cases @=? $(dsSplice test69_invis_type_pat_cases) +#endif +#if __GLASGOW_HASKELL__ >= 911 + , "embedded_forall_invis" ~: $(test70_embedded_forall_invis) @=? $(dsSplice test70_embedded_forall_invis) + , "embedded_forall_vis" ~: $(test71_embedded_forall_vis) @=? $(dsSplice test71_embedded_forall_vis) + , "embedded_constraint" ~: $(test72_embedded_constraint) @=? $(dsSplice test72_embedded_constraint) +#endif +#if __GLASGOW_HASKELL__ >= 913 + , "specialise_exp_pragma" ~: $(test73_specialise_exp_pragma) @=? $(dsSplice test73_specialise_exp_pragma) +#endif ] test35a = $test35_expand @@ -272,7 +336,7 @@ (decsToTH [ -- type family F (x :: k) :: k DOpenTypeFamilyD (DTypeFamilyHead fam_name - [DKindedTV x () (DVarT k)] + [DKindedTV x THAbs.BndrReq (DVarT k)] (DKindSig (DVarT k)) Nothing) -- type instance F (x :: ()) = x @@ -325,10 +389,11 @@ let type_kind = DConT typeKindName data_kind_sig = DArrowT `DAppT` type_kind `DAppT` (DArrowT `DAppT` type_kind `DAppT` type_kind) - (tvbs, _) <- withLocalDeclarations - [decToTH (DDataD Data [] data_name [DPlainTV a ()] - (Just data_kind_sig) [] [])] - (getDataD "th-desugar: Impossible" data_name) + (_, tvbs, _) <- + withLocalDeclarations + [decToTH (DDataD Data [] data_name [DPlainTV a THAbs.BndrReq] + (Just data_kind_sig) [] [])] + (getDataD "th-desugar: Impossible" data_name) [| $(Syn.lift (length tvbs)) |]) test_t100 :: Bool @@ -405,8 +470,8 @@ -- m :: a -- -- We define this by hand to avoid GHC#17608 on pre-9.0 GHCs. - decs = sweeten [ DClassD [] c [DPlainTV a ()] [] - [ DLetDec (DInfixD fixity m) + decs = sweeten [ DClassD [] c [DPlainTV a THAbs.BndrReq] [] + [ DLetDec (DInfixD fixity NoNamespaceSpecifier m) , DLetDec (DSigD m (DVarT a)) ] ] @@ -414,6 +479,98 @@ actual <- withLocalDeclarations decs (reifyFixityWithLocals m) expected `eqTHSplice` actual) +#if __GLASGOW_HASKELL__ >= 801 +-- Test local reification of pattern synonym record selectors. +test_t137 :: [Bool] +test_t137 = + $(do a <- newName "a" + b <- newName "b" + let aVarT = DVarT a + aVarP = DVarP a + bVarT = DVarT b + bVarP = DVarP b + aTvb = DPlainTV a SpecifiedSpec + bTvb = DPlainTV b SpecifiedSpec + + p1 = mkName "P1" + unP1a = mkName "unP1a" + unP1b = mkName "unP1b" + p2 = mkName "P2" + unP2a = mkName "unP2a" + unP2b = mkName "unP2b" + p3 = mkName "P3" + unP3a = mkName "unP3a" + unP3b = mkName "unP3b" + + tupleTy = DConT (tupleTypeName 2) `DAppT` aVarT `DAppT` bVarT + showCxt = [DConT ''Show `DAppT` aVarT] + patSynSigDBodyTy = + DArrowT `DAppT` aVarT `DAppT` (DArrowT `DAppT` bVarT `DAppT` tupleTy) + + -- pattern P{unPa, unPb} = (unPa, unPb) + mkPatSynD :: Name -> Name -> Name -> DDec + mkPatSynD p unPa unPb = + DPatSynD + p + (RecordPatSyn [unPa, unPb]) + DImplBidir + (DConP (tupleDataName 2) [] [aVarP, bVarP]) + + decs :: [Dec] + decs = sweeten + [ -- pattern P1 :: a -> b -> (a, b) + DPatSynSigD p1 patSynSigDBodyTy + , mkPatSynD p1 unP1a unP1b + + -- pattern P2 :: Show a => a -> b -> (a, b) + , DPatSynSigD p2 $ DConstrainedT showCxt patSynSigDBodyTy + , mkPatSynD p2 unP2a unP2b + + -- pattern P3 :: forall b a. Show a => a -> b -> (a, b) + , DPatSynSigD p3 $ + DForallT (DForallInvis [bTvb, aTvb]) $ + DConstrainedT showCxt patSynSigDBodyTy + , mkPatSynD p3 unP3a unP3b + ] + + -- Pair each pattern synonym record selector name with the type that + -- local reification should produce. + expecteds :: [(Name, DType)] + expecteds = + [ (unP1a, DForallT (DForallInvis [aTvb, bTvb]) $ + DArrowT `DAppT` tupleTy `DAppT` aVarT) + , (unP1b, DForallT (DForallInvis [aTvb, bTvb]) $ + DArrowT `DAppT` tupleTy `DAppT` bVarT) + + -- The reified types below use (DForallInvis []) due to the way + -- that ForallT is desugared. + -- See Note [Desugaring and sweetening ForallT] in + -- Language.Haskell.TH.Desugar.Core. + , (unP2a, DForallT (DForallInvis []) $ + DConstrainedT showCxt $ + DArrowT `DAppT` tupleTy `DAppT` aVarT) + , (unP2b, DForallT (DForallInvis []) $ + DConstrainedT showCxt $ + DArrowT `DAppT` tupleTy `DAppT` bVarT) + + , (unP3a, DForallT (DForallInvis [bTvb, aTvb]) $ + DConstrainedT showCxt $ + DArrowT `DAppT` tupleTy `DAppT` aVarT) + , (unP3b, DForallT (DForallInvis [bTvb, aTvb]) $ + DConstrainedT showCxt $ + DArrowT `DAppT` tupleTy `DAppT` bVarT) + ] + + expected_eq_actual :: (Name, DType) -> DsM Q Bool + expected_eq_actual (sel_name, expected_ty) = do + let expected_info = Just $ DVarI sel_name expected_ty Nothing + actual_info <- dsReify sel_name + pure $ expected_info `eqTH` actual_info + + bs <- withLocalDeclarations decs $ mapM expected_eq_actual expecteds + Syn.lift bs) +#endif + test_t154 :: Bool test_t154 = $(do decs <- [d| data T where @@ -436,6 +593,251 @@ testOne t159A testOne t159B +#if __GLASGOW_HASKELL__ >= 906 +test_t170 :: [Bool] +test_t170 = + $(do decs <- [d| type data TyData = MkTyData |] + + let test_TypeData_NameSpace nameStr = + withLocalDeclarations decs $ do + Just name <- lookupTypeNameWithLocals nameStr + mbNS <- reifyNameSpace name + mbNS `eqTHSplice` Just Syn.TcClsName + + let b1 = test_TypeData_NameSpace "TyData" + let b2 = test_TypeData_NameSpace "MkTyData" + [| [$b1, $b2] |]) +#endif + +test_t171 :: Bool +test_t171 = + $(do a <- newName "a" + b <- newName "b" + c <- newName "c" + x <- newName "x" + y <- newName "y" + + let aVarT = DVarT a + bVarT = DVarT b + cVarT = DVarT c + aTvb = DPlainTV a SpecifiedSpec + bTvb = DPlainTV b SpecifiedSpec + cTvb = DPlainTV c SpecifiedSpec + t = mkName "T" + mkT = mkName "mkT" + getT1 = mkName "getT1" + getT2 = mkName "getT2" + + dec = -- data T x y where + -- MkT :: forall b a c. { getT1 :: b, getT2 :: c } -> T a b + DDataD + Data + [] + t + [DPlainTV x THAbs.BndrReq, DPlainTV y THAbs.BndrReq] + Nothing + [ DCon + [bTvb, aTvb, cTvb] + [] + mkT + (DRecC [ ( getT1 + , Bang NoSourceUnpackedness NoSourceStrictness + , bVarT + ) + , ( getT2 + , Bang NoSourceUnpackedness NoSourceStrictness + , cVarT + ) + ]) + res_ty + ] + [] + res_ty = DConT t `DAppT` aVarT `DAppT` bVarT + expected_ty = DForallT (DForallInvis [bTvb, aTvb]) $ + DArrowT `DAppT` res_ty `DAppT` bVarT + + withLocalDeclarations (sweeten [dec]) $ do + Just (DVarI _ actual_ty _) <- dsReify getT1 + expected_ty `eqTHSplice` actual_ty) + +-- Unit tests for tupleNameDegree_maybe. These also act as a regression test for +-- #187. +test_t187 :: [Bool] +test_t187 = + map (\(s, expected) -> tupleNameDegree_maybe s == expected) + [ (''(), Just 0) + , (''(,), Just 2) + , (''(,,), Just 3) + , (''Maybe, Nothing) + , (tupleTypeName 0, Just 0) + , (tupleTypeName 2, Just 2) + , (tupleTypeName 3, Just 3) +#if __GLASGOW_HASKELL__ >= 900 + , (''Solo, Just 1) +#if __GLASGOW_HASKELL__ >= 906 + , ('MkSolo, Just 1) +#else + , ('Solo, Just 1) +#endif +#endif +#if __GLASGOW_HASKELL__ >= 908 + , (''Unit, Just 0) + , (''Tuple0, Just 0) + , (''Tuple1, Just 1) + , (''Tuple2, Just 2) + , (''Tuple3, Just 3) + , (''FakeTuples.Tuple0, Nothing) + , (''FakeTuples.Tuple1, Nothing) + , (''FakeTuples.Tuple2, Nothing) + , (''FakeTuples.Tuple3, Nothing) +#endif + ] + +-- A regression test for #188, which ensures that it produces the correct answer +-- for an unusual telescope like: +-- +-- ... forall (a1 :: a2). forall (a2 :: a1). ... +-- +-- Here, a2 is free in the kind of a1 (the first `forall`), but then the second +-- `forall` binds another a2 that shadows what was already in scope. In this +-- example, `toposortKindVarsOfTvbs [(a1 :: a2), (a2 :: a1)]` should return +-- [a2]. +test_t188 :: Bool +test_t188 = + let a1 = mkName "a1" + a2 = mkName "a2" in + toposortKindVarsOfTvbs [DKindedTV a1 () (DVarT a2), DKindedTV a2 () (DVarT a1)] + == [DPlainTV a2 ()] + +#if __GLASGOW_HASKELL__ >= 900 +-- A regression test for #199, which ensures that a locally reified data +-- constructor is given a type signature that takes into account the fact that +-- its parent data type's standalone kind signature marks `k` as inferred. +test_t199 :: [Bool] +test_t199 = + $(do decs <- [d| type P :: forall {k}. k -> Type + data P (a :: k) = MkP |] + + withLocalDeclarations decs $ do + let k = mkName "k" + a = mkName "a" + kTvb = DPlainTV k InferredSpec + aTvb = DKindedTV a SpecifiedSpec (DVarT k) + p = mkName "P" + mkP = mkName "MkP" + pTy = DConT p `DAppT` DVarT a + mbPInfo <- dsReify p + let b1 = + case mbPInfo of + Just (DTyConI (DDataD _ _ _ _ _ [conActual] _) _) -> + let conExpected = + DCon [kTvb, aTvb] [] mkP (DNormalC False []) pTy in + conExpected `eqTH` conActual + _ -> + False + + mbMkPInfo <- dsReify mkP + let b2 = + case mbMkPInfo of + Just (DVarI _ conTyActual _) -> + let conTyExpected = + DForallT (DForallInvis [kTvb, aTvb]) pTy in + conTyExpected `eqTH` conTyActual + _ -> + False + + [| [b1, b2] |]) +#endif + +-- Unit tests for unboxedTupleNameDegree_maybe and unboxedSumNameDegree_maybe. +-- These also act as a regression test for #213. +test_t213 :: [Bool] +test_t213 = + map (\(s, expected) -> unboxedTupleNameDegree_maybe s == expected) + [ (''(##), Just 0) + , (''(#,#), Just 2) + , (''(#,,#), Just 3) + , (''Maybe, Nothing) +#if __GLASGOW_HASKELL__ >= 802 + , (unboxedTupleTypeName 0, Just 0) +#endif + , (unboxedTupleTypeName 2, Just 2) + , (unboxedTupleTypeName 3, Just 3) +#if __GLASGOW_HASKELL__ >= 910 + , (''Unit#, Just 0) + , (''Tuple0#, Just 0) + , (''Solo#, Just 1) + , (''Tuple1#, Just 1) + , (''Tuple2#, Just 2) + , (''Tuple3#, Just 3) + , (''FakeTuples.Tuple0#, Nothing) + , (''FakeTuples.Tuple1#, Nothing) + , (''FakeTuples.Tuple2#, Nothing) + , (''FakeTuples.Tuple3#, Nothing) +#endif + ] +#if __GLASGOW_HASKELL__ >= 802 + ++ + map (\(s, expected) -> unboxedSumNameDegree_maybe s == expected) + [ (unboxedSumTypeName 2, Just 2) + , (unboxedSumTypeName 3, Just 3) + , (unboxedSumTypeName 4, Just 4) +#if __GLASGOW_HASKELL__ >= 910 + , (''Sum2#, Just 2) + , (''Sum3#, Just 3) + , (''Sum4#, Just 4) + , (''FakeSums.Sum2#, Nothing) + , (''FakeSums.Sum3#, Nothing) + , (''FakeSums.Sum4#, Nothing) +#endif + ] +#endif + +#if __GLASGOW_HASKELL__ >= 900 +-- A regression test for #220, which ensures that a locally reified class method +-- is given a type signature that takes into account the fact that its parent +-- class's standalone kind signature marks `k` as inferred. +test_t220 :: Bool +test_t220 = + $(do decs <- [d| type C :: forall {k}. k -> Constraint + class C (a :: k) where + m :: Proxy a |] + + withLocalDeclarations decs $ do + let k = mkName "k" + a = mkName "a" + kTvb = DPlainTV k InferredSpec + aTvb = DKindedTV a SpecifiedSpec (DVarT k) + c = mkName "C" + m = mkName "m" + cTy = DConT c `DAppT` DVarT a + mbMInfo <- dsReify m + case mbMInfo of + Just (DVarI _ mTyActual _) -> + let mTyExpected = + DForallT (DForallInvis [kTvb, aTvb]) $ + DConstrainedT [cTy] $ + DConT ''Proxy `DAppT` DVarT a in + mTyExpected `eqTHSplice` mTyActual + _ -> + [| False |]) +#endif + +-- A regression test for #228, which ensures that dMatchUpSAKWithDecl behaves +-- as expected on code that looks like this: +-- +-- @ +-- type D :: forall (a :: Type). Type +-- data D +-- @ +test_t228 :: Bool +test_t228 = + let sak = DForallT (DForallInvis [DKindedTV (mkName "a") SpecifiedSpec (DConT ''Type)]) (DConT ''Type) + expected_bndrs = [DKindedTV (mkName "a") (Invisible SpecifiedSpec) (DConT ''Type)] in + case dMatchUpSAKWithDecl sak [] of + Nothing -> False + Just actual_bndrs -> expected_bndrs `eqTH` actual_bndrs + -- Unit tests for functions that compute free variables (e.g., fvDType) test_fvs :: [Bool] test_fvs = @@ -576,9 +978,17 @@ , matchTy NoIgnore (DConT ''Int) (DConT ''Bool) == Nothing , matchTy NoIgnore (DConT ''Int) (DConT ''Int) == Just M.empty , matchTy NoIgnore (DConT ''Int) (DVarT a) == Nothing + -- Test `DSigT` with both `IgnoreKinds` options , matchTy NoIgnore (DVarT a `DSigT` DConT ''Bool) (DConT ''Int) == Nothing , matchTy YesIgnore (DVarT a `DSigT` DConT ''Bool) (DConT ''Int) == Just (M.singleton a (DConT ''Int)) + -- Test `DAppKindT` with both `IgnoreKinds` options + , matchTy NoIgnore (DConT ''Proxy `DAppKindT` DConT ''Bool `DAppT` DVarT a) + (DConT ''Proxy `DAppT` DConT ''Int) + == Nothing + , matchTy YesIgnore (DConT ''Proxy `DAppKindT` DConT ''Bool `DAppT` DVarT a) + (DConT ''Proxy `DAppT` DConT ''Int) + == Just (M.singleton a (DConT ''Int)) ] where a = mkName "a" @@ -640,6 +1050,11 @@ it "reifies fixity declarations inside of classes" $ test_t132 +#if __GLASGOW_HASKELL__ >= 801 + zipWithM (\b n -> it ("reifies local pattern synonym record selectors " ++ show n) b) + test_t137 [1..] +#endif + zipWithM (\b n -> it ("computes free variables correctly " ++ show n) b) test_fvs [1..] @@ -647,6 +1062,35 @@ it "desugars non-exhaustive expressions into code that errors at runtime" $ test_t159 +#if __GLASGOW_HASKELL__ >= 906 + zipWithM (\b n -> it ("looks up TypeData names in the type namespace correctly " ++ show n) b) + test_t170 [1..] +#endif + + it "locally reifies GADT record selector types with explicit foralls correctly" $ test_t171 + + it "doesn't reify a field selector with lookupValueNameWithLocals when NoFieldSelectors is set" $ + t183 == Nothing + + zipWithM (\b n -> it ("recognizes tuple names with tupleDegree_maybe correctly " ++ show n) b) + test_t187 [1..] + + it "computes free kind variables correctly in a telescope that uses shadowing" $ test_t188 + +#if __GLASGOW_HASKELL__ >= 900 + zipWithM (\b n -> it ("correctly reifies the type of a data constructor with an inferred type variable binder " ++ show n) b) + test_t199 [1..] +#endif + + zipWithM (\b n -> it ("recognizes unboxed {tuple,sum} names with unboxed{Tuple,Sum}Degree_maybe correctly " ++ show n) b) + test_t213 [1..] + +#if __GLASGOW_HASKELL__ >= 900 + it "correctly reifies the type of a class method with an inferred type variable binder" $ test_t220 +#endif + + it "correctly matches up an invisible forall without a corresponding @-binder" $ test_t228 + -- Remove map pprints here after switch to th-orphans zipWithM (\t t' -> it ("can do Type->DType->Type of " ++ t) $ t == t') $(sequence round_trip_types >>= Syn.lift . map pprint) @@ -654,8 +1098,8 @@ mapM (\ t -> withLocalDeclarations [] (dsType t >>= expandType >>= return . typeToTH)) >>= Syn.lift . map pprint) - zipWith3M (\a b n -> it ("reifies local definition " ++ show n) $ a == b) - local_reifications normal_reifications [1..] + zipWith3M (\a b nm -> it ("reifies local definition " ++ nameBase nm) $ a == b) + local_reifications normal_reifications reifyDecsNames zipWithM (\b n -> it ("works on simplCase test " ++ show n) b) simplCase [1..] diff --git a/Test/Splices.hs b/Test/Splices.hs --- a/Test/Splices.hs +++ b/Test/Splices.hs @@ -29,6 +29,10 @@ {-# LANGUAGE QuantifiedConstraints #-} #endif +#if __GLASGOW_HASKELL__ < 806 +{-# LANGUAGE TypeInType #-} +#endif + #if __GLASGOW_HASKELL__ >= 807 {-# LANGUAGE ImplicitParams #-} #endif @@ -45,12 +49,26 @@ {-# LANGUAGE OverloadedRecordDot #-} #endif +#if __GLASGOW_HASKELL__ >= 906 +{-# LANGUAGE TypeData #-} +#endif + +#if __GLASGOW_HASKELL__ >= 907 +{-# LANGUAGE TypeAbstractions #-} +#endif + +#if __GLASGOW_HASKELL__ >= 909 +{-# LANGUAGE RequiredTypeArguments #-} +#endif + {-# OPTIONS_GHC -Wno-missing-signatures -Wno-type-defaults -Wno-name-shadowing #-} module Splices where import qualified Data.List as L +import qualified Data.List.NonEmpty as NE +import Data.List.NonEmpty (NonEmpty(..)) import Data.Char import qualified Data.Kind as Kind (Type) import GHC.Exts @@ -90,16 +108,33 @@ unqualify = everywhere (mkT (mkName . nameBase)) assumeStarT :: Data a => a -> a -assumeStarT = everywhere (mkT assume_spec . mkT assume_unit) +assumeStarT = everywhere (assume_spec_t . assume_vis_t . assume_unit_t) where - assume_spec :: TyVarBndrSpec -> TyVarBndrSpec + assume_spec_t :: Typeable a => a -> a #if __GLASGOW_HASKELL__ >= 900 + assume_spec_t = mkT assume_spec + + assume_spec :: TyVarBndrSpec -> TyVarBndrSpec assume_spec (PlainTV n spec) = KindedTV n spec StarT assume_spec (KindedTV n spec k) = KindedTV n spec (assumeStarT k) #else - assume_spec = assume_unit + assume_spec_t = id #endif + assume_vis_t :: Typeable a => a -> a +#if __GLASGOW_HASKELL__ >= 907 + assume_vis_t = mkT assume_vis + + assume_vis :: TyVarBndrVis -> TyVarBndrVis + assume_vis (PlainTV n vis) = KindedTV n vis StarT + assume_vis (KindedTV n vis k) = KindedTV n vis (assumeStarT k) +#else + assume_vis_t = id +#endif + + assume_unit_t :: Typeable a => a -> a + assume_unit_t = mkT assume_unit + assume_unit :: TyVarBndrUnit -> TyVarBndrUnit assume_unit = elimTV (\n -> kindedTV n StarT) (\n k -> kindedTV n (assumeStarT k)) @@ -107,10 +142,11 @@ dropTrailing0s :: Data a => a -> a dropTrailing0s = everywhere (mkT (mkName . frob . nameBase)) where - frob str - | head str == 'r' = str - | head str == 'R' = str - | otherwise = L.dropWhileEnd isDigit str + frob str = + case str of + 'r':_ -> str + 'R':_ -> str + _ -> L.dropWhileEnd isDigit str -- Because th-desugar does not support linear types, we must pretend like -- MulArrowT does not exist for testing purposes. @@ -154,11 +190,11 @@ data Record = MkRecord1 { field1 :: Bool, field2 :: Int } | MkRecord2 { field2 :: Int, field3 :: Char } -test14_record = [| let r1 = [MkRecord1 { field2 = 5, field1 = False }, MkRecord2 { field2 = 6, field3 = 'q' }] - r2 = map (\r -> r { field2 = 18 }) r1 - r3 = (head r2) { field1 = True } in - map (\case MkRecord1 { field2 = some_int, field1 = some_bool } -> show some_int ++ show some_bool - MkRecord2 { field2 = some_int, field3 = some_char } -> show some_int ++ show some_char) (r3 : r2) |] +test14_record = [| let r1 = MkRecord1 { field2 = 5, field1 = False } :| [MkRecord2 { field2 = 6, field3 = 'q' }] + r2 = fmap (\r -> r { field2 = 18 }) r1 + r3 = (NE.head r2) { field1 = True } in + fmap (\case MkRecord1 { field2 = some_int, field1 = some_bool } -> show some_int ++ show some_bool + MkRecord2 { field2 = some_int, field3 = some_char } -> show some_int ++ show some_char) (NE.cons r3 r2) |] test15_litp = [| map (\case { 5 -> True ; _ -> False }) [5,6] |] test16_tupp = [| map (\(x,y,z) -> x + y + z) [(1,2,3),(4,5,6)] |] @@ -197,8 +233,8 @@ test28_tupt = [| let f :: (a,b) -> a f (a,_) = a in map f [(1,'a'),(2,'b')] |] -test29_listt = [| let f :: [[a]] -> a - f = head . head in +test29_listt = [| let f :: [[Int]] -> [[Int]] + f = map (map (+1)) in map f [ [[1]], [[2]] ] |] test30_promoted = [| let f :: Proxy '() -> Proxy '[Int, Bool] -> () f _ _ = () in @@ -351,6 +387,108 @@ _ _ -> "") (Just "Hello") (Just "World") |] #endif +#if __GLASGOW_HASKELL__ >= 907 +test57_typed_th_bracket = + typedBracketE [| 'x' |] + +test58_typed_th_splice = + typedSpliceE (typedBracketE [| 'y' |]) +#endif + +#if __GLASGOW_HASKELL__ >= 909 +test59_embedded_types_keyword = + [| let idv :: forall a -> a -> a + idv (type a) (x :: a) = x :: a + + in idv (type Bool) True |] + +test60_embedded_types_no_keyword = + [| let idv :: forall a -> a -> a + idv a (x :: a) = x :: a + + in idv Bool True |] + +test61_invis_type_pat = + [| let f :: a -> a + f @a = id @a + + in f @Bool True |] + +test62_embedded_types_lambda_keyword = + [| let idv :: forall a -> a -> a + idv = \(type a) (x :: a) -> x :: a + + in idv (type Bool) True |] + +test63_embedded_types_case_keyword = + [| let idv :: forall a -> a -> a + idv = \case + (type a) -> id @a + + in idv (type Bool) True |] + +test64_embedded_types_cases_keyword = + [| let idv :: forall a -> a -> a + idv = \cases + (type a) (x :: a) -> x :: a + + in idv (type Bool) True |] + +test65_embedded_types_lambda_no_keyword = + [| let idv :: forall a -> a -> a + idv = \a (x :: a) -> x :: a + + in idv Bool True |] + +test66_embedded_types_case_no_keyword = + [| let idv :: forall a -> a -> a + idv = \case + a -> id @a + + in idv Bool True |] + +test67_embedded_types_cases_no_keyword = + [| let idv :: forall a -> a -> a + idv = \cases + a (x :: a) -> x :: a + + in idv Bool True |] + +aux :: (forall a. a -> a) -> (forall a. a -> a) +aux f x = f x + +test68_invis_type_pat_lambda = + [| aux (\ @a (x :: a) -> x :: a) @Bool True |] + +test69_invis_type_pat_cases = + [| aux (\cases @a (x :: a) -> x :: a) @Bool True |] +#endif + +#if __GLASGOW_HASKELL__ >= 911 +test70_embedded_forall_invis = + [| let idv :: forall a -> a -> a + idv _ x = x + in idv (forall a. a -> a) id True |] + +test71_embedded_forall_vis = + [| let idv :: forall a -> a -> a + idv _ x = x + in idv (forall a -> a -> a) idv Bool True |] + +test72_embedded_constraint = + [| let idv :: forall a -> a -> a + idv _ x = x + in idv (forall a. (a ~ Bool) => a -> a) (\x -> not x) False |] +#endif + +#if __GLASGOW_HASKELL__ >= 913 +test73_specialise_exp_pragma = + [| let {-# SPECIALISE f @() #-} + f :: forall a. Show a => a -> String + f = show + in f () |] +#endif + type family TFExpand x type instance TFExpand Int = Bool type instance TFExpand (Maybe a) = [a] @@ -500,6 +638,25 @@ MkDec18 :: forall k (a :: k). Dec18 k a |] #endif +#if __GLASGOW_HASKELL__ >= 907 +dectest19 = [d| type Dec19 :: forall k. k -> Kind.Type + data Dec19 @k (a :: k) = MkDec19 k (Proxy a) |] +#endif + +#if __GLASGOW_HASKELL__ >= 909 +dectest20 = [d| infixr 3 data !@# + infixr 3 type !@# + + (!@#) :: Bool -> Bool -> Bool + (!@#) = (&&) + + type family (!@#) :: Bool -> Bool -> Bool |] + +dectest21 = [d| {-# SCC dec21 "dec21" #-} + dec21 :: a -> a + dec21 x = x |] +#endif + instance_test = [d| instance (Show a, Show b) => Show (a -> b) where show _ = "function" |] @@ -662,6 +819,19 @@ data R33 a where R34 :: { r35 :: Int } -> R33 Int + +#if __GLASGOW_HASKELL__ >= 906 + type data R36 a = R37 a + type data R38 a where + R39 :: forall a. a -> R38 a +#endif + + -- A regression test for #184 + data family x ^^^ y + data instance x ^^^ y = R40 x y + + -- A regression test for #188 + data R41 a (x :: Maybe a) = R42 |] reifyDecsNames :: [Name] @@ -677,6 +847,11 @@ , "R32" #endif , "R33", "R34", "r35" +#if __GLASGOW_HASKELL__ >= 906 + , "R36", "R37", "R38", "R39" +#endif + , "R40" + , "R41", "R42" ] simplCaseTests :: [Q Exp] @@ -774,5 +949,30 @@ #if __GLASGOW_HASKELL__ >= 903 , test55_opaque_pragma , test56_lambda_cases +#endif +#if __GLASGOW_HASKELL__ >= 907 + , test57_typed_th_bracket + , test58_typed_th_splice +#endif +#if __GLASGOW_HASKELL__ >= 909 + , test59_embedded_types_keyword + , test60_embedded_types_no_keyword + , test61_invis_type_pat + , test62_embedded_types_lambda_keyword + , test63_embedded_types_case_keyword + , test64_embedded_types_cases_keyword + , test65_embedded_types_lambda_no_keyword + , test66_embedded_types_case_no_keyword + , test67_embedded_types_cases_no_keyword + , test68_invis_type_pat_lambda + , test69_invis_type_pat_cases +#endif +#if __GLASGOW_HASKELL__ >= 911 + , test70_embedded_forall_invis + , test71_embedded_forall_vis + , test72_embedded_constraint +#endif +#if __GLASGOW_HASKELL__ >= 913 + , test73_specialise_exp_pragma #endif ] diff --git a/Test/T158Exp.hs b/Test/T158Exp.hs --- a/Test/T158Exp.hs +++ b/Test/T158Exp.hs @@ -1,5 +1,6 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-incomplete-patterns #-} -- | A regression test for #158 which ensures that lambda expressions -- containing patterns with unlifted types desugar as expected. We define this diff --git a/Test/T183.hs b/Test/T183.hs new file mode 100644 --- /dev/null +++ b/Test/T183.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} + +#if __GLASGOW_HASKELL__ >= 907 +{-# LANGUAGE NoFieldSelectors #-} +#endif + +-- | A regression test for #T183 which ensures that 'lookupValueNameWithLocals' +-- does not reify a field selector when the @NoFieldSelectors@ language +-- extension is set on GHC 9.8 or later. We define this test in its own module +-- to avoid having to enable @NoFieldSelectors@ in other parts of the test +-- suite. +module T183 (t183) where + +import Language.Haskell.TH (Name) +#if __GLASGOW_HASKELL__ >= 907 +import Language.Haskell.TH.Desugar +#endif + +t183 :: Maybe Name +#if __GLASGOW_HASKELL__ >= 907 +-- This should return 'Nothing', as the 'unT' record should not be made into a +-- top-level field selector due to @NoFieldSelectors@. +t183 = + $(do decs <- [d| data T = MkT { unT :: Int } |] + mbName <- withLocalDeclarations decs (lookupValueNameWithLocals "unT") + [| mbName |]) +#else +-- Lacking @NoFieldSelectors@ on older versions of GHC, we simply hard-code the +-- result to 'Nothing'. +t183 = Nothing +#endif diff --git a/th-desugar.cabal b/th-desugar.cabal --- a/th-desugar.cabal +++ b/th-desugar.cabal @@ -1,5 +1,5 @@ name: th-desugar -version: 1.14 +version: 1.19 cabal-version: >= 1.10 synopsis: Functions to desugar Template Haskell homepage: https://github.com/goldfirere/th-desugar @@ -19,7 +19,13 @@ , GHC == 8.8.4 , GHC == 8.10.7 , GHC == 9.0.2 - , GHC == 9.2.2 + , GHC == 9.2.8 + , GHC == 9.4.8 + , GHC == 9.6.7 + , GHC == 9.8.4 + , GHC == 9.10.3 + , GHC == 9.12.2 + , GHC == 9.14.1 description: This package provides the Language.Haskell.TH.Desugar module, which desugars Template Haskell's rich encoding of Haskell syntax into a simpler encoding. @@ -45,14 +51,14 @@ build-depends: base >= 4.9 && < 5, ghc-prim, - template-haskell >= 2.11 && < 2.20, + template-haskell >= 2.11 && < 2.25, containers >= 0.5, mtl >= 2.1 && < 2.4, ordered-containers >= 0.2.2, syb >= 0.4, - th-abstraction >= 0.4 && < 0.5, - th-lift >= 0.6.1, - th-orphans >= 0.13.7, + th-abstraction >= 0.6 && < 0.8, + th-compat >= 0.1 && < 0.2, + th-orphans >= 0.13.11, transformers-compat >= 0.6.3 default-extensions: TemplateHaskell exposed-modules: Language.Haskell.TH.Desugar @@ -62,6 +68,7 @@ Language.Haskell.TH.Desugar.OMap.Strict Language.Haskell.TH.Desugar.OSet Language.Haskell.TH.Desugar.Subst + Language.Haskell.TH.Desugar.Subst.Capturing Language.Haskell.TH.Desugar.Sweeten other-modules: Language.Haskell.TH.Desugar.AST Language.Haskell.TH.Desugar.Core @@ -82,21 +89,22 @@ main-is: Run.hs other-modules: Dec DsDec + FakeSums + FakeTuples ReifyTypeCUSKs ReifyTypeSigs Splices T158Exp T159Decs + T183 build-depends: base >= 4 && < 5, + ghc-prim, template-haskell, containers >= 0.5, - mtl >= 2.1, syb >= 0.4, HUnit >= 1.2, hspec >= 1.3, - th-abstraction >= 0.4 && < 0.5, - th-desugar, - th-lift >= 0.6.1, - th-orphans >= 0.13.9 + th-abstraction, + th-desugar