Add UInfixT to TH types (fixes #10522)
authorMichael Smith <michael@diglumi.com>
Mon, 27 Jul 2015 11:19:01 +0000 (13:19 +0200)
committerBen Gamari <ben@smart-cactus.org>
Mon, 27 Jul 2015 11:50:10 +0000 (13:50 +0200)
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

compiler/hsSyn/Convert.hs
docs/users_guide/7.12.1-notes.xml
libraries/template-haskell/Language/Haskell/TH.hs
libraries/template-haskell/Language/Haskell/TH/Lib.hs
libraries/template-haskell/Language/Haskell/TH/Ppr.hs
libraries/template-haskell/Language/Haskell/TH/Syntax.hs
testsuite/tests/th/TH_unresolvedInfix.hs
testsuite/tests/th/TH_unresolvedInfix.stdout
testsuite/tests/th/TH_unresolvedInfix_Lib.hs

index d4a0b54..db4ae97 100644 (file)
@@ -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"
 
index 27ad849..eccf13d 100644 (file)
                     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>
 
index a39bdd1..5d08227 100644 (file)
@@ -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
index f0431cf..5d2b08c 100644 (file)
@@ -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
index c8f42ef..e792d1e 100644 (file)
@@ -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 "."
index d2233a1..e21bb1c 100644 (file)
@@ -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.@
index 03e97cf..49f283b 100644 (file)
@@ -1,3 +1,4 @@
+{-# 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)
index 9ef0da4..7790e7b 100644 (file)
@@ -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
index aa734ab..e6ad9f0 100644 (file)
@@ -1,3 +1,5 @@
+{-# 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