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, 4 years ago)
  • Language/Haskell/TH.hs

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