Commit ba4cc4d2 authored by Alex D's avatar Alex D 🍄

Fix #16895 by checking whether infix expression operator is a variable

parent a25f6f55
Pipeline #7924 passed with stages
in 416 minutes and 37 seconds
......@@ -925,7 +925,7 @@ cvtl e = wrapL (cvt e)
}
-- Infix expressions
cvt (InfixE (Just x) s (Just y)) =
cvt (InfixE (Just x) s (Just y)) = ensureValidOpExp s $
do { x' <- cvtl x
; s' <- cvtl s
; y' <- cvtl y
......@@ -937,20 +937,24 @@ cvtl e = wrapL (cvt e)
-- to ensure this operator application does
-- does not get re-associated
-- See Note [Operator association]
cvt (InfixE Nothing s (Just y)) = do { s' <- cvtl s; y' <- cvtl y
cvt (InfixE Nothing s (Just y)) = ensureValidOpExp s $
do { s' <- cvtl s; y' <- cvtl y
; wrapParL (HsPar noExt) $
SectionR noExt s' y' }
-- See Note [Sections in HsSyn] in HsExpr
cvt (InfixE (Just x) s Nothing ) = do { x' <- cvtl x; s' <- cvtl s
cvt (InfixE (Just x) s Nothing ) = ensureValidOpExp s $
do { x' <- cvtl x; s' <- cvtl s
; wrapParL (HsPar noExt) $
SectionL noExt x' s' }
cvt (InfixE Nothing s Nothing ) = do { s' <- cvtl s
cvt (InfixE Nothing s Nothing ) = ensureValidOpExp s $
do { s' <- cvtl s
; return $ HsPar noExt s' }
-- Can I indicate this is an infix thing?
-- Note [Dropping constructors]
cvt (UInfixE x s y) = do { x' <- cvtl x
cvt (UInfixE x s y) = ensureValidOpExp s $
do { x' <- cvtl x
; let x'' = case unLoc x' of
OpApp {} -> x'
_ -> mkLHsPar x'
......@@ -977,6 +981,24 @@ cvtl e = wrapL (cvt e)
cvt (LabelE s) = do { return $ HsOverLabel noExt Nothing (fsLit s) }
cvt (ImplicitParamVarE n) = do { n' <- ipName n; return $ HsIPVar noExt n' }
{- | #16895 Ensure an infix expression's operator is a variable/constructor.
Consider this example:
$(uInfixE [|1|] [|id id|] [|2|])
This infix expression is obviously ill-formed so we use this helper function
to reject such programs outright.
The constructors `ensureValidOpExp` permits should be in sync with `pprInfixExp`
in Language.Haskell.TH.Ppr from the template-haskell library.
-}
ensureValidOpExp :: TH.Exp -> CvtM a -> CvtM a
ensureValidOpExp (VarE _n) m = m
ensureValidOpExp (ConE _n) m = m
ensureValidOpExp (UnboundVarE _n) m = m
ensureValidOpExp _e _m =
failWith (text "Non-variable expression is not allowed in an infix expression")
{- Note [Dropping constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When we drop constructors from the input (for instance, when we encounter @TupE [e]@)
......
......@@ -123,7 +123,10 @@ isSymOcc n
pprInfixExp :: Exp -> Doc
pprInfixExp (VarE v) = pprName' Infix v
pprInfixExp (ConE v) = pprName' Infix v
pprInfixExp _ = text "<<Non-variable/constructor in infix context>>"
pprInfixExp (UnboundVarE v) = pprName' Infix v
-- This case will only ever be reached in exceptional circumstances.
-- For example, when printing an error message in case of a malformed expression.
pprInfixExp e = text "`" <> ppr e <> text "`"
pprExp :: Precedence -> Exp -> Doc
pprExp _ (VarE v) = pprName' Applied v
......
......@@ -1895,11 +1895,15 @@ data Exp
| InfixE (Maybe Exp) Exp (Maybe Exp) -- ^ @{x + y} or {(x+)} or {(+ x)} or {(+)}@
-- It's a bit gruesome to use an Exp as the
-- operator, but how else can we distinguish
-- constructors from non-constructors?
-- Maybe there should be a var-or-con type?
-- Or maybe we should leave it to the String itself?
-- It's a bit gruesome to use an Exp as the operator when a Name
-- would suffice. Historically, Exp was used to make it easier to
-- distinguish between infix constructors and non-constructors.
-- This is a bit overkill, since one could just as well call
-- `startsConId` or `startsConSym` (from `GHC.Lexeme`) on a Name.
-- Unfortunately, changing this design now would involve lots of
-- code churn for consumers of the TH API, so we continue to use
-- an Exp as the operator and perform an extra check during conversion
-- to ensure that the Exp is a constructor or a variable (#16895).
| UInfixE Exp Exp Exp -- ^ @{x + y}@
--
......
{-# LANGUAGE TemplateHaskell #-}
module T16895a where
import Language.Haskell.TH
main = print $(uInfixE [|1|] [|id id|] [|2|])
T16895a.hs:7:16: error:
• Non-variable expression is not allowed in an infix expression
When splicing a TH expression: 1 `GHC.Base.id GHC.Base.id` 2
• In the untyped splice: $(uInfixE [| 1 |] [| id id |] [| 2 |])
{-# LANGUAGE TemplateHaskell #-}
module T16895b where
import Language.Haskell.TH
main = print $(infixE Nothing [|id id|] (Just [|2|]))
T16895b.hs:7:16:
Non-variable expression is not allowed in an infix expression
When splicing a TH expression: (`GHC.Base.id GHC.Base.id` 2)
In the untyped splice:
$(infixE Nothing [| id id |] (Just [| 2 |]))
{-# LANGUAGE TemplateHaskell #-}
module T16895c where
import Language.Haskell.TH
main = print $(infixE (Just [|1|]) [|id id|] Nothing)
T16895c.hs:7:16:
Non-variable expression is not allowed in an infix expression
When splicing a TH expression: (1 `GHC.Base.id GHC.Base.id`)
In the untyped splice:
$(infixE (Just [| 1 |]) [| id id |] Nothing)
{-# LANGUAGE TemplateHaskell #-}
module T16895d where
import Language.Haskell.TH
main = print $(infixE (Just [|1|]) [|(id id)|] (Just [|2|]))
T16895d.hs:7:16:
Non-variable expression is not allowed in an infix expression
When splicing a TH expression: 1 `GHC.Base.id GHC.Base.id` 2
In the untyped splice:
$(infixE (Just [| 1 |]) [| (id id) |] (Just [| 2 |]))
{-# LANGUAGE TemplateHaskell #-}
module T16895e where
import Language.Haskell.TH
main = print $(infixE Nothing [|id id|] Nothing)
T16895e.hs:7:16:
Non-variable expression is not allowed in an infix expression
When splicing a TH expression: (`GHC.Base.id GHC.Base.id`)
In the untyped splice: $(infixE Nothing [| id id |] Nothing)
......@@ -480,3 +480,8 @@ test('T16293b', normal, compile, [''])
test('T16326_TH', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
test('T14741', normal, compile_and_run, [''])
test('T16666', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
test('T16895a', normal, compile_fail, [''])
test('T16895b', normal, compile_fail, [''])
test('T16895c', normal, compile_fail, [''])
test('T16895d', normal, compile_fail, [''])
test('T16895e', normal, compile_fail, [''])
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment