Ticket #4430: template-haskell-0001-Add-support-for-unresolved-infix-expressions-and-pat.patch

File template-haskell-0001-Add-support-for-unresolved-infix-expressions-and-pat.patch, 8.7 KB (added by reinerp, 3 years ago)
  • Language/Haskell/TH.hs

    From 97bb85a7fda23f72e596f10bae4c6e85fd4b4178 Mon Sep 17 00:00:00 2001
    From: Reiner Pope <reiner.pope@gmail.com>
    Date: Sat, 23 Jul 2011 16:13:17 +1000
    Subject: [PATCH] Add support for unresolved infix expressions and patterns.
    
    ---
     Language/Haskell/TH.hs        |    6 ++-
     Language/Haskell/TH/Lib.hs    |   15 ++++++++
     Language/Haskell/TH/Ppr.hs    |   17 ++++++++--
     Language/Haskell/TH/Syntax.hs |   75 +++++++++++++++++++++++++++++++++++++++++
     4 files changed, 108 insertions(+), 5 deletions(-)
    
    diff --git a/Language/Haskell/TH.hs b/Language/Haskell/TH.hs
    index c2bc267..1f4bc5e 100644
    a b module Language.Haskell.TH( 
    4646        intPrimL, wordPrimL, floatPrimL, doublePrimL, integerL, rationalL, 
    4747        charL, stringL, stringPrimL, 
    4848    -- *** Patterns 
    49         litP, varP, tupP, conP, infixP, tildeP, bangP, asP, wildP, recP, 
     49        litP, varP, tupP, conP, uInfixP, parensP, infixP, 
     50        tildeP, bangP, asP, wildP, recP, 
    5051        listP, sigP, viewP, 
    5152        fieldPat, 
    5253 
    module Language.Haskell.TH( 
    5455        normalB, guardedB, normalG, normalGE, patG, patGE, match, clause,  
    5556 
    5657    -- *** Expressions 
    57         dyn, global, varE, conE, litE, appE, infixE, infixApp, sectionL, sectionR,  
     58        dyn, global, varE, conE, litE, appE, uInfixE, parensE, 
     59        infixE, infixApp, sectionL, sectionR,  
    5860        lamE, lam1E, tupE, condE, letE, caseE, appsE, 
    5961        listE, sigE, recConE, recUpdE, stringE, fieldExp, 
    6062    -- **** Ranges 
  • Language/Haskell/TH/Lib.hs

    diff --git a/Language/Haskell/TH/Lib.hs b/Language/Haskell/TH/Lib.hs
    index 8bcf671..92f3dd4 100644
    a b infixP :: PatQ -> Name -> PatQ -> PatQ 
    7373infixP p1 n p2 = do p1' <- p1 
    7474                    p2' <- p2 
    7575                    return (InfixP p1' n p2') 
     76uInfixP :: PatQ -> Name -> PatQ -> PatQ 
     77uInfixP p1 n p2 = do p1' <- p1 
     78                     p2' <- p2 
     79                     return (UInfixP 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 
     214uInfixE :: ExpQ -> ExpQ -> ExpQ -> ExpQ 
     215uInfixE x s y = do { x' <- x; s' <- s; y' <- y; 
     216                     return (UInfixE 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 dc43f4b..dccb53b 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 (UInfixE 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 (UInfixP 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 5ee5cd1..c777b89 100644
    a b module Language.Haskell.TH.Syntax( 
    3333        showName, showName', NameIs(..), 
    3434 
    3535        -- * The algebraic data types 
     36        -- $infix 
    3637        Dec(..), Exp(..), Con(..), Type(..), TyVarBndr(..), Kind(..),Cxt, 
    3738        Pred(..), Match(..),  Clause(..), Body(..), Guard(..), Stmt(..), 
    3839        Range(..), Lit(..), Pat(..), FieldExp, FieldPat, ClassInstance(..), 
    defaultFixity = Fixity maxPrecedence InfixL 
    689690-- 
    690691----------------------------------------------------- 
    691692 
     693{- $infix #infix# 
     694Note [Unresolved infix] 
     695~~~~~~~~~~~~~~~~~~~~~~~ 
     696 
     697When implementing antiquotation for quasiquoters, one often wants 
     698to parse strings into expressions: 
     699 
     700> parse :: String -> Maybe 'Exp' 
     701 
     702But how should we parse @a + b * c@? If we don't know the fixities of 
     703@+@ and @*@, we don't know whether to parse it as @a + (b * c)@ or @(a 
     704+ b) * c@. 
     705 
     706In cases like this, use 'UInfixE' or 'UInfixP', which stand for 
     707\"unresolved infix expression\" and \"unresolved infix pattern\". When 
     708the compiler is given a splice containing a tree of @UInfixE@ 
     709applications such as 
     710 
     711> UInfixE 
     712>   (UInfixE e1 op1 e2) 
     713>   op2 
     714>   (UInfixE e3 op3 e4) 
     715 
     716it will look up and the fixities of the relevant operators and 
     717reassociate the tree as necessary. 
     718 
     719  * trees will not be reassociated across 'ParensE' or 'ParensP', 
     720    which are of use for parsing expressions like 
     721 
     722    > (a + b * c) + d * e 
     723 
     724  * 'InfixE' and 'InfixP' expressions are never reassociated. 
     725 
     726  * The 'UInfixE' constructor doesn't support sections. Sections 
     727    such as @(a *)@ have no ambiguity, so 'InfixE' suffices. For longer 
     728    sections such as @(a + b * c -)@, use an 'InfixE' constructor for the 
     729    outer-most section, and use 'UInfixE' constructors for all 
     730    other operators: 
     731 
     732    > InfixE 
     733    >   Just (UInfixE ...a + b * c...) 
     734    >   op 
     735    >   Nothing 
     736 
     737    Sections such as @(a + b +)@ and @((a + b) +)@ should be rendered 
     738    into 'Exp's differently: 
     739 
     740    > (+ a + b)   ---> InfixE Nothing + (Just $ UInfixE a + b) 
     741    >                    -- will result in a fixity error if (+) is left-infix 
     742    > (+ (a + b)) ---> InfixE Nothing + (Just $ ParensE $ UInfixE a + b) 
     743    >                    -- no fixity errors 
     744 
     745  * Quoted expressions such as 
     746 
     747    > [| a * b + c |] :: Q Exp 
     748    > [p| a : b : c |] :: Q Pat 
     749 
     750    will never contain 'UInfixE', 'UInfixP', 'ParensE', or 'ParensP' 
     751    constructors. 
     752 
     753-} 
     754 
    692755data Lit = CharL Char  
    693756         | StringL String  
    694757         | IntegerL Integer     -- ^ Used for overloaded and non-overloaded 
    data Pat 
    715778  | UnboxedTupP [Pat]             -- ^ @{ (# p1,p2 #) }@ 
    716779  | ConP Name [Pat]               -- ^ @data T1 = C1 t1 t2; {C1 p1 p1} = e@ 
    717780  | InfixP Pat Name Pat           -- ^ @foo ({x :+ y}) = e@ 
     781  | UInfixP Pat Name Pat          -- ^ @foo ({x :+ y}) = e@ 
     782                                  -- 
     783                                  -- See Note [Unresolved infix] at "Language.Haskell.TH.Syntax#infix" 
     784  | ParensP Pat                   -- ^ @{(p)}@ 
     785                                  -- 
     786                                  -- See Note [Unresolved infix] at "Language.Haskell.TH.Syntax#infix" 
    718787  | TildeP Pat                    -- ^ @{ ~p }@ 
    719788  | BangP Pat                     -- ^ @{ !p }@ 
    720789  | AsP Name Pat                  -- ^ @{ x \@ p }@ 
    data Exp 
    756825    -- Maybe there should be a var-or-con type? 
    757826    -- Or maybe we should leave it to the String itself? 
    758827 
     828  | UInfixE Exp Exp Exp                -- ^ @{x + y}@ 
     829                                       -- 
     830                                       -- See Note [Unresolved infix] at "Language.Haskell.TH.Syntax#infix" 
     831  | ParensE Exp                        -- ^ @{ (e) }@ 
     832                                       -- 
     833                                       -- See Note [Unresolved infix] at "Language.Haskell.TH.Syntax#infix" 
    759834  | LamE [Pat] Exp                     -- ^ @{ \ p1 p2 -> e }@ 
    760835  | TupE [Exp]                         -- ^ @{ (e1,e2) }  @ 
    761836  | UnboxedTupE [Exp]                  -- ^ @{ (# e1,e2 #) }  @