Commit 21782739 authored by spinda's avatar spinda Committed by Ben Gamari

Add UInfixT to TH types (fixes #10522)

UInfixT is like UInfixE or UInfixP but for types. Template Haskell
splices can use it to punt fixity handling to GHC when constructing
types.

UInfixT is converted in compiler/hsSyn/Convert to a right-biased tree of
HsOpTy, which is already rearranged in compiler/rename/RnTypes to match
operator fixities.

This patch consists of (1) adding UInfixT to the AST, (2) implementing
the conversion and updating relevant comments, (3) updating
pretty-printing and library support, and (4) adding tests.

Test Plan: validate

Reviewers: austin, goldfire, bgamari

Reviewed By: bgamari

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D1088

GHC Trac Issues: #10522
parent f842ad6c
......@@ -747,14 +747,15 @@ We must be quite careful about adding parens:
Note [Converting UInfix]
~~~~~~~~~~~~~~~~~~~~~~~~
When converting @UInfixE@ and @UInfixP@ values, we want to readjust
When converting @UInfixE@, @UInfixP@, and @UInfixT@ values, we want to readjust
the trees to reflect the fixities of the underlying operators:
UInfixE x * (UInfixE y + z) ---> (x * y) + z
This is done by the renamer (see @mkOppAppRn@ and @mkConOppPatRn@ in
RnTypes), which expects that the input will be completely left-biased.
So we left-bias the trees of @UInfixP@ and @UInfixE@ that we come across.
This is done by the renamer (see @mkOppAppRn@, @mkConOppPatRn@, and
@mkHsOpTyRn@ in RnTypes), which expects that the input will be completely
right-biased for types and left-biased for everything else. So we left-bias the
trees of @UInfixP@ and @UInfixE@ and right-bias the trees of @UInfixT@.
Sample input:
......@@ -773,8 +774,8 @@ Sample output:
op3
w
The functions @cvtOpApp@ and @cvtOpAppP@ are responsible for this
left-biasing.
The functions @cvtOpApp@, @cvtOpAppP@, and @cvtOpAppT@ are responsible for this
biasing.
-}
{- | @cvtOpApp x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@.
......@@ -1045,6 +1046,23 @@ cvtTypeKind ty_str ty
WildCardT (Just nm)
-> do { nm' <- tName nm; mk_apps (mkNamedWildCardTy nm') tys' }
InfixT t1 s t2
-> do { s' <- tconName s
; t1' <- cvtType t1
; t2' <- cvtType t2
; mk_apps (HsTyVar s') [t1', t2']
}
UInfixT t1 s t2
-> do { t2' <- cvtType t2
; cvtOpAppT t1 s t2'
} -- Note [Converting UInfix]
ParensT t
-> do { t' <- cvtType t
; returnL $ HsParTy t'
}
PromotedT nm -> do { nm' <- cName nm; mk_apps (HsTyVar nm') tys' }
-- Promoted data constructor; hence cName
......@@ -1096,6 +1114,21 @@ cvtTyLit :: TH.TyLit -> HsTyLit
cvtTyLit (NumTyLit i) = HsNumTy (show i) i
cvtTyLit (StrTyLit s) = HsStrTy s (fsLit s)
{- | @cvtOpAppT x op y@ converts @op@ and @y@ and produces the operator
application @x `op` y@. The produced tree of infix types will be right-biased,
provided @y@ is.
See the @cvtOpApp@ documentation for how this function works.
-}
cvtOpAppT :: TH.Type -> TH.Name -> LHsType RdrName -> CvtM (LHsType RdrName)
cvtOpAppT (UInfixT x op2 y) op1 z
= do { l <- cvtOpAppT y op1 z
; cvtOpAppT x op2 l }
cvtOpAppT x op y
= do { op' <- tconNameL op
; x' <- cvtType x
; returnL (mkHsOpTy x' op' y) }
cvtKind :: TH.Kind -> CvtM (LHsKind RdrName)
cvtKind = cvtTypeKind "kind"
......
......@@ -146,6 +146,18 @@
Partial type signatures can now be used in splices, see <xref linkend="pts-where"/>.
</para>
</listitem>
<listitem>
<para>
<literal>Template Haskell</literal> now supports the use of
<literal>UInfixT</literal> in types to resolve infix
operator fixities, in the same vein as
<literal>UInfixP</literal> and <literal>UInfixE</literal>
in patterns and expressions. <literal>ParensT</literal>
and <literal>InfixT</literal> have also been introduced,
serving the same functions as their pattern and expression
counterparts.
</para>
</listitem>
</itemizedlist>
</sect3>
......
......@@ -105,8 +105,9 @@ module Language.Haskell.TH(
bindS, letS, noBindS, parS,
-- *** Types
forallT, varT, conT, appT, arrowT, equalityT, listT, tupleT, sigT, litT,
promotedT, promotedTupleT, promotedNilT, promotedConsT,
forallT, varT, conT, appT, arrowT, infixT, uInfixT, parensT, equalityT,
listT, tupleT, sigT, litT, promotedT, promotedTupleT, promotedNilT,
promotedConsT,
-- **** Type literals
numTyLit, strTyLit,
-- **** Strictness
......
......@@ -518,6 +518,20 @@ varT = return . VarT
conT :: Name -> TypeQ
conT = return . ConT
infixT :: TypeQ -> Name -> TypeQ -> TypeQ
infixT t1 n t2 = do t1' <- t1
t2' <- t2
return (InfixT t1' n t2')
uInfixT :: TypeQ -> Name -> TypeQ -> TypeQ
uInfixT t1 n t2 = do t1' <- t1
t2' <- t2
return (UInfixT t1' n t2')
parensT :: TypeQ -> TypeQ
parensT t = do t' <- t
return (ParensT t')
appT :: TypeQ -> TypeQ -> TypeQ
appT t1 t2 = do
t1' <- t1
......
......@@ -501,8 +501,15 @@ pprParendType StarT = char '*'
pprParendType ConstraintT = text "Constraint"
pprParendType (SigT ty k) = parens (ppr ty <+> text "::" <+> ppr k)
pprParendType (WildCardT mbName) = char '_' <> maybe empty ppr mbName
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 other = parens (ppr other)
pprUInfixT :: Type -> Doc
pprUInfixT (UInfixT x n y) = pprUInfixT x <+> pprName' Infix n <+> pprUInfixT y
pprUInfixT t = ppr t
instance Ppr Type where
ppr (ForallT tvars ctxt ty)
= text "forall" <+> hsep (map ppr tvars) <+> text "."
......
......@@ -1157,10 +1157,9 @@ 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' or 'UInfixP', which stand for
\"unresolved infix expression\" and \"unresolved infix pattern\". When
the compiler is given a splice containing a tree of @UInfixE@
applications such as
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
> UInfixE
> (UInfixE e1 op1 e2)
......@@ -1170,12 +1169,12 @@ applications such as
it will look up and the fixities of the relevant operators and
reassociate the tree as necessary.
* trees will not be reassociated across 'ParensE' or 'ParensP',
* trees will not be reassociated across 'ParensE', 'ParensP', or 'ParensT',
which are of use for parsing expressions like
> (a + b * c) + d * e
* 'InfixE' and 'InfixP' expressions are never reassociated.
* 'InfixE', 'InfixP', and 'InfixT' expressions are never reassociated.
* The 'UInfixE' constructor doesn't support sections. Sections
such as @(a *)@ have no ambiguity, so 'InfixE' suffices. For longer
......@@ -1200,9 +1199,10 @@ reassociate the tree as necessary.
> [| a * b + c |] :: Q Exp
> [p| a : b : c |] :: Q Pat
> [t| T + T |] :: Q Type
will never contain 'UInfixE', 'UInfixP', 'ParensE', or 'ParensP'
constructors.
will never contain 'UInfixE', 'UInfixP', 'UInfixT', 'InfixT', 'ParensE',
'ParensP', or 'ParensT' constructors.
-}
......@@ -1462,6 +1462,11 @@ data Type = ForallT [TyVarBndr] Cxt Type -- ^ @forall \<vars\>. \<ctxt\> -> \<t
| 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)@
-- See Note [Representing concrete syntax in types]
| TupleT Int -- ^ @(,), (,,), etc.@
......
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE QuasiQuotes #-}
module Main where
......@@ -89,6 +90,30 @@ patterns = [
[p16|unused|] -> True
]
--------------------------------------------------------------------------------
-- Types --
--------------------------------------------------------------------------------
-------------- Completely-unresolved types
_t1 = 1 `Plus` (1 `Times` 1) :: $( int $+? (int $*? int) )
_t2 = 1 `Plus` (1 `Times` 1) :: $( (int $+? int) $*? int )
_t3 = (1 `Plus` 1) `Plus` 1 :: $( int $+? (int $+? int) )
_t4 = (1 `Plus` 1) `Plus` 1 :: $( (int $+? int) $+? int )
-------------- Completely-resolved types
_t5 = 1 `Plus` (1 `Times` 1) :: $( int $+! (int $*! int) )
_t6 = (1 `Plus` 1) `Times` 1 :: $( (int $+! int) $*! int )
_t7 = 1 `Plus` (1 `Plus` 1) :: $( int $+! (int $+! int) )
_t8 = (1 `Plus` 1) `Plus` 1 :: $( (int $+! int) $+! int )
-------------- Mixed resolved/unresolved
_t9 = ((1 `Plus` 1) `Times` 1) `Plus` 1 :: $( (int $+! int) $*? (int $+? int) )
_t10 = 1 `Plus` (1 `Times` (1 `Plus` 1)) :: $( (int $+? int) $*? (int $+! int) )
_t11 = (1 `Plus` 1) `Times` (1 `Plus` 1) :: $( (int $+? int) $*! (int $+! int) )
_t12 = (1 `Plus` 1) `Times` (1 `Plus` 1) :: $( (int $+? int) $*! (int $+? int) )
-------------- Parens
_t13 = (1 `Plus` (1 `Times` 1)) `Plus` (1 `Times` 1) :: $( ((parensT ((int $+? int) $*? int)) $+? int) $*? int )
_t14 = (1 `Plus` 1) `Times` (1 `Plus` 1) :: $( (parensT (int $+? int)) $*? (parensT (int $+? int)) )
_t15 = (1 `Plus` (1 `Times` 1)) `Plus` 1 :: $( parensT ((int $+? int) $*? (int $+? int)) )
main = do
mapM_ print exprs
mapM_ print patterns
......@@ -97,13 +122,19 @@ main = do
runQ [|(N :* N) :+ N|] >>= print
runQ [p|N :* N :+ N|] >>= print
runQ [p|(N :* N) :+ N|] >>= print
runQ [t|Int * Int + Int|] >>= print
runQ [t|(Int * Int) + Int|] >>= print
-- pretty-printing of unresolved infix expressions
let ne = ConE $ mkName "N"
np = ConP (mkName "N") []
nt = ConT (mkName "Int")
plusE = ConE (mkName ":+")
plusP = (mkName ":+")
plusT = (mkName "+")
putStrLn $ pprint (InfixE (Just ne) plusE (Just $ UInfixE ne plusE (UInfixE ne plusE ne)))
putStrLn $ pprint (ParensE ne)
putStrLn $ pprint (InfixP np plusP (UInfixP np plusP (UInfixP np plusP np)))
putStrLn $ pprint (ParensP np)
putStrLn $ pprint (InfixT nt plusT (UInfixT nt plusT (UInfixT nt plusT nt)))
putStrLn $ pprint (ParensT nt)
......@@ -40,7 +40,11 @@ InfixE (Just (InfixE (Just (ConE TH_unresolvedInfix_Lib.N)) (ConE TH_unresolvedI
InfixE (Just (InfixE (Just (ConE TH_unresolvedInfix_Lib.N)) (ConE TH_unresolvedInfix_Lib.:*) (Just (ConE TH_unresolvedInfix_Lib.N)))) (ConE TH_unresolvedInfix_Lib.:+) (Just (ConE TH_unresolvedInfix_Lib.N))
InfixP (InfixP (ConP TH_unresolvedInfix_Lib.N []) TH_unresolvedInfix_Lib.:* (ConP TH_unresolvedInfix_Lib.N [])) TH_unresolvedInfix_Lib.:+ (ConP TH_unresolvedInfix_Lib.N [])
InfixP (InfixP (ConP TH_unresolvedInfix_Lib.N []) TH_unresolvedInfix_Lib.:* (ConP TH_unresolvedInfix_Lib.N [])) TH_unresolvedInfix_Lib.:+ (ConP TH_unresolvedInfix_Lib.N [])
AppT (AppT (ConT TH_unresolvedInfix_Lib.+) (AppT (AppT (ConT TH_unresolvedInfix_Lib.*) (ConT GHC.Types.Int)) (ConT GHC.Types.Int))) (ConT GHC.Types.Int)
AppT (AppT (ConT TH_unresolvedInfix_Lib.+) (AppT (AppT (ConT TH_unresolvedInfix_Lib.*) (ConT GHC.Types.Int)) (ConT GHC.Types.Int))) (ConT GHC.Types.Int)
N :+ (N :+ N :+ N)
(N)
N :+ (N :+ N :+ N)
(N)
(Int + (Int + Int + Int))
Int
{-# LANGUAGE TypeOperators #-}
module TH_unresolvedInfix_Lib where
import Language.Haskell.TH
......@@ -72,3 +74,21 @@ p14 = mkQQ ( (parensP (p ^+? p)) ^*? (parensP (p ^+? p)) )
p15 = mkQQ ( parensP ((p ^+? p) ^*? (p ^+? p)) )
-------------- Dropping constructors
p16 = mkQQ ( p ^*? (tupP [p ^+? p]) )
--------------------------------------------------------------------------------
-- Types --
--------------------------------------------------------------------------------
infixl 6 +
infixl 7 *
data (+) a b = Plus a b
data (*) a b = Times a b
int = conT (mkName "Int")
tyPlus = mkName "+"
tyTimes = mkName "*"
a $+? b = uInfixT a tyPlus b
a $*? b = uInfixT a tyTimes b
a $+! b = infixT a tyPlus b
a $*! b = infixT a tyTimes b
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment