Ticket #4430: template-haskell.patch

File template-haskell.patch, 8.6 KB (added by reinerp, 3 years ago)
  • Language/Haskell/TH.hs

    From 77f478a0ab1eff87c113697794764e16ffaddfdb Mon Sep 17 00:00:00 2001
    From: Reiner Pope <reiner.pope@gmail.com>
    Date: Tue, 19 Jul 2011 23:28:00 +1000
    Subject: [PATCH] Add unresolved infix patterns and expressions
    
    ---
     Language/Haskell/TH.hs        |   66 +++++++++++++++++++++++++++++++++++++++-
     Language/Haskell/TH/Lib.hs    |   15 +++++++++
     Language/Haskell/TH/Ppr.hs    |   17 +++++++++--
     Language/Haskell/TH/Syntax.hs |   12 +++++++
     4 files changed, 105 insertions(+), 5 deletions(-)
    
    diff --git a/Language/Haskell/TH.hs b/Language/Haskell/TH.hs
    index c2bc267..a7e2382 100644
    a b module Language.Haskell.TH( 
    2727    -- | The lowercase versions (/syntax operators/) of these constructors are 
    2828    -- preferred to these constructors, since they compose better with 
    2929    -- quotations (@[| |]@) and splices (@$( ... )@) 
     30 
     31    -- $infix 
    3032        Dec(..), Exp(..), Con(..), Type(..), TyVarBndr(..), Kind(..), Cxt, 
    3133        Pred(..), Match(..), Clause(..), Body(..), Guard(..), Stmt(..), 
    3234        Range(..), Lit(..), Pat(..), FieldExp, FieldPat,  
    module Language.Haskell.TH( 
    4648        intPrimL, wordPrimL, floatPrimL, doublePrimL, integerL, rationalL, 
    4749        charL, stringL, stringPrimL, 
    4850    -- *** Patterns 
    49         litP, varP, tupP, conP, infixP, tildeP, bangP, asP, wildP, recP, 
     51        litP, varP, tupP, conP, unresolvedInfixP, parensP, infixP,  
     52        tildeP, bangP, asP, wildP, recP, 
    5053        listP, sigP, viewP, 
    5154        fieldPat, 
    5255 
    module Language.Haskell.TH( 
    5457        normalB, guardedB, normalG, normalGE, patG, patGE, match, clause,  
    5558 
    5659    -- *** Expressions 
    57         dyn, global, varE, conE, litE, appE, infixE, infixApp, sectionL, sectionR,  
     60        dyn, global, varE, conE, litE, appE, unresolvedInfixE, parensE, 
     61        infixE, infixApp, sectionL, sectionR,  
    5862        lamE, lam1E, tupE, condE, letE, caseE, appsE, 
    5963        listE, sigE, recConE, recUpdE, stringE, fieldExp, 
    6064    -- **** Ranges 
    import Language.Haskell.TH.Syntax 
    99103import Language.Haskell.TH.Lib 
    100104import Language.Haskell.TH.Ppr 
    101105 
     106----------------------------------------------------- 
     107-- 
     108--      Note about infix expressions/patterns 
     109-- 
     110----------------------------------------------------- 
     111 
     112{- $infix #infix#  
     113Note [Unresolved infix] 
     114 
     115When implementing antiquotation for quasiquoters, one often wants 
     116to parse strings into expressions: 
     117 
     118> parse :: String -> Maybe 'Exp' 
     119 
     120But how should we parse @a + b * c@? If we don't know the fixities 
     121of @+@ and @*@, we don't know whether to parse it as @a + (b * c)@ or @(a + b) * c@. 
     122 
     123In cases like this, use 'UnresolvedInfixE' or 'UnresolvedInfixP'. When the compiler  
     124is given a splice containing a tree of @UnresolvedInfixE@ applications such as 
     125 
     126> UnresolvedInfixE  
     127>   (UnresolvedInfixE e1 op1 e2) 
     128>   op2 
     129>   (UnresolvedInfixE e3 op3 e4) 
     130 
     131it will look up and the fixities of the relevant operators and 
     132reassociate the tree as necessary. 
     133 
     134  * trees will not be reassociated across 'ParensE' or 'ParensP',  
     135    which are of use for parsing expressions like 
     136 
     137    > (a + b * c) + d * e 
     138 
     139  * 'InfixE' and 'InfixP' expressions are never reassociated, with 
     140    one exception described in the following point. 
     141 
     142  * The 'UnresolvedInfixE' constructor doesn't support sections. Sections  
     143    such as @(a *)@ have no ambiguity, so 'InfixE' suffices. For longer 
     144    sections such as @(a + b * c -)@, use an 'InfixE' constructor for the  
     145    outer-most section, and use 'UnresolvedInfixE' constructors for all 
     146    other operators: 
     147 
     148    > InfixE 
     149    >   Just (UnresolvedInfixE ...a + b * c...) 
     150    >   op 
     151    >   Nothing 
     152 
     153    This special handling for sections is the exception to the previous point. 
     154 
     155  * Quoted expressions such as 
     156 
     157    > [| a * b + c |] :: Q Exp 
     158    > [p| a : b : c |] :: Q Pat 
     159 
     160    will never contain 'UnresolvedInfixE', 'UnresolvedInfixP', 'ParensE', or 'ParensP' 
     161    constructors. 
     162 
     163-} 
  • Language/Haskell/TH/Lib.hs

    diff --git a/Language/Haskell/TH/Lib.hs b/Language/Haskell/TH/Lib.hs
    index 894bb33..5bbe9c0 100644
    a b infixP :: PatQ -> Name -> PatQ -> PatQ 
    7373infixP p1 n p2 = do p1' <- p1 
    7474                    p2' <- p2 
    7575                    return (InfixP p1' n p2') 
     76unresolvedInfixP :: PatQ -> Name -> PatQ -> PatQ 
     77unresolvedInfixP p1 n p2 = do p1' <- p1 
     78                              p2' <- p2 
     79                              return (UnresolvedInfixP p1' n p2') 
     80parensP :: PatQ -> PatQ 
     81parensP p = do p' <- p 
     82               return (ParensP p') 
     83 
    7684tildeP :: PatQ -> PatQ 
    7785tildeP p = do p' <- p 
    7886              return (TildeP p') 
    litE c = return (LitE c) 
    200208appE :: ExpQ -> ExpQ -> ExpQ 
    201209appE x y = do { a <- x; b <- y; return (AppE a b)} 
    202210 
     211parensE :: ExpQ -> ExpQ 
     212parensE x = do { x' <- x; return (ParensE x') } 
     213 
     214unresolvedInfixE :: ExpQ -> ExpQ -> ExpQ -> ExpQ 
     215unresolvedInfixE x s y = do { x' <- x; s' <- s; y' <- y; 
     216                              return (UnresolvedInfixE x' s' y') } 
     217 
    203218infixE :: Maybe ExpQ -> ExpQ -> Maybe ExpQ -> ExpQ 
    204219infixE (Just x) s (Just y) = do { a <- x; s' <- s; b <- y; 
    205220                                  return (InfixE (Just a) s' (Just b))} 
  • Language/Haskell/TH/Ppr.hs

    diff --git a/Language/Haskell/TH/Ppr.hs b/Language/Haskell/TH/Ppr.hs
    index 6c324f0..a0fb6be 100644
    a b nestDepth :: Int 
    1616nestDepth = 4 
    1717 
    1818type Precedence = Int 
    19 appPrec, opPrec, noPrec :: Precedence 
    20 appPrec = 2    -- Argument of a function application 
    21 opPrec  = 1    -- Argument of an infix operator 
     19appPrec, unopPrec, opPrec, noPrec :: Precedence 
     20appPrec = 3    -- Argument of a function application 
     21opPrec  = 2    -- Argument of an infix operator 
     22unopPrec = 1   -- Argument of an unresolved infix operator 
    2223noPrec  = 0    -- Others 
    2324 
    2425parensIf :: Bool -> Doc -> Doc 
    pprExp _ (ConE c) = pprName' Applied c 
    9899pprExp i (LitE l)     = pprLit i l 
    99100pprExp i (AppE e1 e2) = parensIf (i >= appPrec) $ pprExp opPrec e1 
    100101                                              <+> pprExp appPrec e2 
     102pprExp _ (ParensE e)  = parens (pprExp noPrec e) 
     103pprExp i (UnresolvedInfixE e1 op e2) 
     104 = parensIf (i > unopPrec) $ pprExp unopPrec e1 
     105                         <+> pprInfixExp op 
     106                         <+> pprExp unopPrec e2 
    101107pprExp i (InfixE (Just e1) op (Just e2)) 
    102108 = parensIf (i >= opPrec) $ pprExp opPrec e1 
    103109                        <+> pprInfixExp op 
    pprPat _ (TupP ps) = parens $ sep $ punctuate comma $ map ppr ps 
    194200pprPat _ (UnboxedTupP ps) = hashParens $ sep $ punctuate comma $ map ppr ps 
    195201pprPat i (ConP s ps)  = parensIf (i >= appPrec) $ pprName' Applied s 
    196202                                              <+> sep (map (pprPat appPrec) ps) 
     203pprPat _ (ParensP p)  = parens $ pprPat noPrec p 
     204pprPat i (UnresolvedInfixP p1 n p2) 
     205                      = parensIf (i > unopPrec) (pprPat unopPrec p1 <+> 
     206                                                 pprName' Infix n   <+> 
     207                                                 pprPat unopPrec p2) 
    197208pprPat i (InfixP p1 n p2) 
    198209                      = parensIf (i >= opPrec) (pprPat opPrec p1 <+> 
    199210                                                pprName' Infix n <+> 
  • Language/Haskell/TH/Syntax.hs

    diff --git a/Language/Haskell/TH/Syntax.hs b/Language/Haskell/TH/Syntax.hs
    index 2360f55..ec56c7c 100644
    a b data Pat 
    715715  | UnboxedTupP [Pat]             -- ^ @{ (# p1,p2 #) }@ 
    716716  | ConP Name [Pat]               -- ^ @data T1 = C1 t1 t2; {C1 p1 p1} = e@ 
    717717  | InfixP Pat Name Pat           -- ^ @foo ({x :+ y}) = e@ 
     718  | UnresolvedInfixP Pat Name Pat -- ^ @foo ({x :+ y}) = e@ 
     719                                  -- 
     720                                  -- See "Language.Haskell.TH#infix" 
     721  | ParensP Pat                   -- ^ @{(p)}@ 
     722                                  -- 
     723                                  -- See "Language.Haskell.TH#infix" 
    718724  | TildeP Pat                    -- ^ @{ ~p }@ 
    719725  | BangP Pat                     -- ^ @{ !p }@ 
    720726  | AsP Name Pat                  -- ^ @{ x \@ p }@ 
    data Exp 
    756762    -- Maybe there should be a var-or-con type? 
    757763    -- Or maybe we should leave it to the String itself? 
    758764 
     765  | UnresolvedInfixE Exp Exp Exp       -- ^ @{x + y}@ 
     766                                       -- 
     767                                       -- See "Language.Haskell.TH#infix" 
     768  | ParensE Exp                        -- ^ @{ (e) }@ 
     769                                       -- 
     770                                       -- See "Language.Haskell.TH#infix" 
    759771  | LamE [Pat] Exp                     -- ^ @{ \ p1 p2 -> e }@ 
    760772  | TupE [Exp]                         -- ^ @{ (e1,e2) }  @ 
    761773  | UnboxedTupE [Exp]                  -- ^ @{ (# e1,e2 #) }  @