diff options
author | Jakob Brünker <jakob.bruenker@gmail.com> | 2021-12-09 13:55:18 +0100 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-12-11 00:55:48 -0500 |
commit | 8d1f30e7cfa5b459aab9dcf3052f3f7f274666e3 (patch) | |
tree | aef54cdd4b1ebf3b82512f573fdd01308efdc272 /libraries/template-haskell | |
parent | b4a554197be38be72b4a52603efac84983a6b2bc (diff) | |
download | haskell-8d1f30e7cfa5b459aab9dcf3052f3f7f274666e3.tar.gz |
Add PromotedInfixT/PromotedUInfixT to TH
Previously, it was not possible to refer to a data constructor using
InfixT with a dynamically bound name (i.e. a name with NameFlavour
`NameS` or `NameQ`) if a type constructor of the same
name exists.
This commit adds promoted counterparts to InfixT and UInfixT,
analogously to how PromotedT is the promoted counterpart to ConT.
Closes #20773
Diffstat (limited to 'libraries/template-haskell')
5 files changed, 103 insertions, 71 deletions
diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib.hs b/libraries/template-haskell/Language/Haskell/TH/Lib.hs index 7dcf328574..42fa6cd501 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Lib.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Lib.hs @@ -56,9 +56,9 @@ module Language.Haskell.TH.Lib ( bindS, letS, noBindS, parS, recS, -- *** Types - forallT, forallVisT, varT, conT, appT, appKindT, arrowT, infixT, - mulArrowT, - uInfixT, parensT, equalityT, listT, tupleT, unboxedTupleT, unboxedSumT, + forallT, forallVisT, varT, conT, appT, appKindT, arrowT, mulArrowT, + infixT, uInfixT, promotedInfixT, promotedUInfixT, + parensT, equalityT, listT, tupleT, unboxedTupleT, unboxedSumT, sigT, litT, wildCardT, promotedT, promotedTupleT, promotedNilT, promotedConsT, implicitParamT, -- **** Type literals diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs index 379a2ad07d..95ccf39447 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs @@ -698,6 +698,16 @@ uInfixT t1 n t2 = do t1' <- t1 t2' <- t2 pure (UInfixT t1' n t2') +promotedInfixT :: Quote m => m Type -> Name -> m Type -> m Type +promotedInfixT t1 n t2 = do t1' <- t1 + t2' <- t2 + pure (PromotedInfixT t1' n t2') + +promotedUInfixT :: Quote m => m Type -> Name -> m Type -> m Type +promotedUInfixT t1 n t2 = do t1' <- t1 + t2' <- t2 + pure (PromotedUInfixT t1' n t2') + parensT :: Quote m => m Type -> m Type parensT t = do t' <- t pure (ParensT t') diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs index 7f34bdc6d6..02f38852ac 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs @@ -1,4 +1,5 @@ {-# LANGUAGE Safe #-} +{-# LANGUAGE LambdaCase #-} -- | contains a prettyprinter for the -- Template Haskell datatypes @@ -760,44 +761,52 @@ pprStrictType = pprBangType ------------------------------ pprParendType :: Type -> Doc -pprParendType (VarT v) = pprName' Applied v +pprParendType (VarT v) = pprName' Applied v -- `Applied` is used here instead of `ppr` because of infix names (#13887) -pprParendType (ConT c) = pprName' Applied c -pprParendType (TupleT 0) = text "()" -pprParendType (TupleT 1) = pprParendType (ConT (tupleTypeName 1)) -pprParendType (TupleT n) = parens (hcat (replicate (n-1) comma)) -pprParendType (UnboxedTupleT n) = hashParens $ hcat $ replicate (n-1) comma -pprParendType (UnboxedSumT arity) = hashParens $ hcat $ replicate (arity-1) bar -pprParendType ArrowT = parens (text "->") -pprParendType MulArrowT = text "FUN" -pprParendType ListT = text "[]" -pprParendType (LitT l) = pprTyLit l -pprParendType (PromotedT c) = text "'" <> pprName' Applied c -pprParendType (PromotedTupleT 0) = text "'()" -pprParendType (PromotedTupleT 1) = pprParendType (PromotedT (tupleDataName 1)) -pprParendType (PromotedTupleT n) = quoteParens (hcat (replicate (n-1) comma)) -pprParendType PromotedNilT = text "'[]" -pprParendType PromotedConsT = text "'(:)" -pprParendType StarT = char '*' -pprParendType ConstraintT = text "Constraint" -pprParendType (SigT ty k) = parens (ppr ty <+> text "::" <+> ppr k) -pprParendType WildCardT = char '_' -pprParendType (InfixT x n y) = parens (ppr x <+> pprName' Infix n <+> ppr y) -pprParendType t@(UInfixT {}) = parens (pprUInfixT t) -pprParendType (ParensT t) = ppr t +pprParendType (ConT c) = pprName' Applied c +pprParendType (TupleT 0) = text "()" +pprParendType (TupleT 1) = pprParendType (ConT (tupleTypeName 1)) +pprParendType (TupleT n) = parens (hcat (replicate (n-1) comma)) +pprParendType (UnboxedTupleT n) = hashParens $ hcat $ replicate (n-1) comma +pprParendType (UnboxedSumT arity) = hashParens $ hcat $ replicate (arity-1) bar +pprParendType ArrowT = parens (text "->") +pprParendType MulArrowT = text "FUN" +pprParendType ListT = text "[]" +pprParendType (LitT l) = pprTyLit l +pprParendType (PromotedT c) = text "'" <> pprName' Applied c +pprParendType (PromotedTupleT 0) = text "'()" +pprParendType (PromotedTupleT 1) = pprParendType (PromotedT (tupleDataName 1)) +pprParendType (PromotedTupleT n) = quoteParens (hcat (replicate (n-1) comma)) +pprParendType PromotedNilT = text "'[]" +pprParendType PromotedConsT = text "'(:)" +pprParendType StarT = char '*' +pprParendType ConstraintT = text "Constraint" +pprParendType (SigT ty k) = parens (ppr ty <+> text "::" <+> ppr k) +pprParendType WildCardT = char '_' +pprParendType t@(InfixT {}) = parens (pprInfixT t) +pprParendType t@(UInfixT {}) = parens (pprInfixT t) +pprParendType t@(PromotedInfixT {}) = parens (pprInfixT t) +pprParendType t@(PromotedUInfixT {}) = parens (pprInfixT t) +pprParendType (ParensT t) = ppr t pprParendType tuple | (TupleT n, args) <- split tuple , length args == n = parens (commaSep args) -pprParendType (ImplicitParamT n t)= text ('?':n) <+> text "::" <+> ppr t -pprParendType EqualityT = text "(~)" -pprParendType t@(ForallT {}) = parens (ppr t) -pprParendType t@(ForallVisT {}) = parens (ppr t) -pprParendType t@(AppT {}) = parens (ppr t) -pprParendType t@(AppKindT {}) = parens (ppr t) - -pprUInfixT :: Type -> Doc -pprUInfixT (UInfixT x n y) = pprUInfixT x <+> pprName' Infix n <+> pprUInfixT y -pprUInfixT t = ppr t +pprParendType (ImplicitParamT n t) = text ('?':n) <+> text "::" <+> ppr t +pprParendType EqualityT = text "(~)" +pprParendType t@(ForallT {}) = parens (ppr t) +pprParendType t@(ForallVisT {}) = parens (ppr t) +pprParendType t@(AppT {}) = parens (ppr t) +pprParendType t@(AppKindT {}) = parens (ppr t) + +pprInfixT :: Type -> Doc +pprInfixT = \case + (InfixT x n y) -> with x n y "" ppr + (UInfixT x n y) -> with x n y "" pprInfixT + (PromotedInfixT x n y) -> with x n y "'" ppr + (PromotedUInfixT x n y) -> with x n y "'" pprInfixT + t -> ppr t + where + with x n y prefix ppr' = ppr' x <+> text prefix <> pprName' Infix n <+> ppr' y instance Ppr Type where ppr (ForallT tvars ctxt ty) = sep [pprForall tvars ctxt, ppr ty] diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs index e99a20c04b..6991d77227 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs @@ -1986,9 +1986,10 @@ But how should we parse @a + b * c@? If we don't know the fixities of @+@ and @*@, we don't know whether to parse it as @a + (b * c)@ or @(a + b) * c@. -In cases like this, use 'UInfixE', 'UInfixP', or 'UInfixT', which stand for -\"unresolved infix expression/pattern/type\", respectively. When the compiler -is given a splice containing a tree of @UInfixE@ applications such as +In cases like this, use 'UInfixE', 'UInfixP', 'UInfixT', or 'PromotedUInfixT', +which stand for \"unresolved infix expression/pattern/type/promoted +constructor\", respectively. When the compiler is given a splice containing a +tree of @UInfixE@ applications such as > UInfixE > (UInfixE e1 op1 e2) @@ -2003,7 +2004,8 @@ reassociate the tree as necessary. > (a + b * c) + d * e - * 'InfixE', 'InfixP', and 'InfixT' expressions are never reassociated. + * 'InfixE', 'InfixP', 'InfixT', and 'PromotedInfixT' expressions are never + reassociated. * The 'UInfixE' constructor doesn't support sections. Sections such as @(a *)@ have no ambiguity, so 'InfixE' suffices. For longer @@ -2030,8 +2032,8 @@ reassociate the tree as necessary. > [p| a : b : c |] :: Q Pat > [t| T + T |] :: Q Type - will never contain 'UInfixE', 'UInfixP', 'UInfixT', 'InfixT', 'ParensE', - 'ParensP', or 'ParensT' constructors. + will never contain 'UInfixE', 'UInfixP', 'UInfixT', 'PromotedUInfixT', + 'InfixT', 'PromotedInfixT, 'ParensE', 'ParensP', or 'ParensT' constructors. -} @@ -2624,35 +2626,39 @@ data PatSynArgs deriving( Show, Eq, Ord, Data, Generic ) data Type = ForallT [TyVarBndr Specificity] Cxt Type -- ^ @forall \<vars\>. \<ctxt\> => \<type\>@ - | ForallVisT [TyVarBndr ()] Type -- ^ @forall \<vars\> -> \<type\>@ - | AppT Type Type -- ^ @T a b@ - | AppKindT Type Kind -- ^ @T \@k t@ - | SigT Type Kind -- ^ @t :: k@ - | VarT Name -- ^ @a@ - | ConT Name -- ^ @T@ - | PromotedT Name -- ^ @'T@ - | InfixT Type Name Type -- ^ @T + T@ - | UInfixT Type Name Type -- ^ @T + T@ - -- - -- See "Language.Haskell.TH.Syntax#infix" - | ParensT Type -- ^ @(T)@ + | ForallVisT [TyVarBndr ()] Type -- ^ @forall \<vars\> -> \<type\>@ + | AppT Type Type -- ^ @T a b@ + | AppKindT Type Kind -- ^ @T \@k t@ + | SigT Type Kind -- ^ @t :: k@ + | VarT Name -- ^ @a@ + | ConT Name -- ^ @T@ + | PromotedT Name -- ^ @'T@ + | InfixT Type Name Type -- ^ @T + T@ + | UInfixT Type Name Type -- ^ @T + T@ + -- + -- See "Language.Haskell.TH.Syntax#infix" + | PromotedInfixT Type Name Type -- ^ @T :+: T@ + | PromotedUInfixT Type Name Type -- ^ @T :+: T@ + -- + -- See "Language.Haskell.TH.Syntax#infix" + | ParensT Type -- ^ @(T)@ -- See Note [Representing concrete syntax in types] - | TupleT Int -- ^ @(,), (,,), etc.@ - | UnboxedTupleT Int -- ^ @(\#,\#), (\#,,\#), etc.@ - | UnboxedSumT SumArity -- ^ @(\#|\#), (\#||\#), etc.@ - | ArrowT -- ^ @->@ - | MulArrowT -- ^ @FUN@ - | EqualityT -- ^ @~@ - | ListT -- ^ @[]@ - | PromotedTupleT Int -- ^ @'(), '(,), '(,,), etc.@ - | PromotedNilT -- ^ @'[]@ - | PromotedConsT -- ^ @(':)@ - | StarT -- ^ @*@ - | ConstraintT -- ^ @Constraint@ - | LitT TyLit -- ^ @0,1,2, etc.@ - | WildCardT -- ^ @_@ - | ImplicitParamT String Type -- ^ @?x :: t@ + | TupleT Int -- ^ @(,), (,,), etc.@ + | UnboxedTupleT Int -- ^ @(\#,\#), (\#,,\#), etc.@ + | UnboxedSumT SumArity -- ^ @(\#|\#), (\#||\#), etc.@ + | ArrowT -- ^ @->@ + | MulArrowT -- ^ @FUN@ + | EqualityT -- ^ @~@ + | ListT -- ^ @[]@ + | PromotedTupleT Int -- ^ @'(), '(,), '(,,), etc.@ + | PromotedNilT -- ^ @'[]@ + | PromotedConsT -- ^ @(':)@ + | StarT -- ^ @*@ + | ConstraintT -- ^ @Constraint@ + | LitT TyLit -- ^ @0,1,2, etc.@ + | WildCardT -- ^ @_@ + | ImplicitParamT String Type -- ^ @?x :: t@ deriving( Show, Eq, Ord, Data, Generic ) data Specificity = SpecifiedSpec -- ^ @a@ diff --git a/libraries/template-haskell/changelog.md b/libraries/template-haskell/changelog.md index f30c9df660..3965279f15 100644 --- a/libraries/template-haskell/changelog.md +++ b/libraries/template-haskell/changelog.md @@ -3,10 +3,17 @@ ## 2.19.0.0 * Add `DefaultD` constructor to support Haskell `default` declarations. - * Add support for Overloaded Record Dot. + + * Add support for Overloaded Record Dot. Introduces `getFieldE :: Quote m => m Exp -> String -> m Exp` and `projectionE :: Quote m => [String] -> m Exp`. + * Add `PromotedInfixT` and `PromotedUInfixT`, which are analogs to `InfixT` + and `UInfixT` that ensure that if a dynamically bound name (i.e. a name + with `NameFlavour` `NameS` or `NameQ`; the flavours produced by `mkName`) + is used as operator, it will be bound to a promoted data constructor rather + than a type constructor, if both are in scope. + ## 2.18.0.0 * The types of `ConP` and `conP` have been changed to allow for an additional list of type applications preceding the argument patterns. |