Ticket #4430: template-haskell.patch

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

    From 77f478a0ab1eff87c113697794764e16ffaddfdb Mon Sep 17 00:00:00 2001
    From: Reiner Pope <[email protected]>
    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 #) }  @