From 2fd1ed541ae55a30ef65e18dc09bba993f37c70e Mon Sep 17 00:00:00 2001
From: nineonine <mail4chemik@gmail.com>
Date: Tue, 2 Jul 2019 12:44:22 -0700
Subject: [PATCH] Fix #16895 by checking whether infix expression operator is a
variable
---
compiler/hsSyn/Convert.hs | 32 ++++++++++++++++---
.../Language/Haskell/TH/Ppr.hs | 5 ++-
.../Language/Haskell/TH/Syntax.hs | 14 +++++---
testsuite/tests/th/T16895a.hs | 7 ++++
testsuite/tests/th/T16895a.stderr | 5 +++
testsuite/tests/th/T16895b.hs | 7 ++++
testsuite/tests/th/T16895b.stderr | 6 ++++
testsuite/tests/th/T16895c.hs | 7 ++++
testsuite/tests/th/T16895c.stderr | 6 ++++
testsuite/tests/th/T16895d.hs | 7 ++++
testsuite/tests/th/T16895d.stderr | 6 ++++
testsuite/tests/th/T16895e.hs | 7 ++++
testsuite/tests/th/T16895e.stderr | 5 +++
testsuite/tests/th/all.T | 5 +++
14 files changed, 108 insertions(+), 11 deletions(-)
create mode 100644 testsuite/tests/th/T16895a.hs
create mode 100644 testsuite/tests/th/T16895a.stderr
create mode 100644 testsuite/tests/th/T16895b.hs
create mode 100644 testsuite/tests/th/T16895b.stderr
create mode 100644 testsuite/tests/th/T16895c.hs
create mode 100644 testsuite/tests/th/T16895c.stderr
create mode 100644 testsuite/tests/th/T16895d.hs
create mode 100644 testsuite/tests/th/T16895d.stderr
create mode 100644 testsuite/tests/th/T16895e.hs
create mode 100644 testsuite/tests/th/T16895e.stderr
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index 12f22e8dd37d..97329aaa553e 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -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]@)
diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
index 6eaadd648eaa..792a78b6061c 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
@@ -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
diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
index 2d79d5a28f6a..f79a8e2b0cf4 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
@@ -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}@
--
diff --git a/testsuite/tests/th/T16895a.hs b/testsuite/tests/th/T16895a.hs
new file mode 100644
index 000000000000..8bc847d271cd
--- /dev/null
+++ b/testsuite/tests/th/T16895a.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module T16895a where
+
+import Language.Haskell.TH
+
+main = print $(uInfixE [|1|] [|id id|] [|2|])
diff --git a/testsuite/tests/th/T16895a.stderr b/testsuite/tests/th/T16895a.stderr
new file mode 100644
index 000000000000..d4b98c944ab7
--- /dev/null
+++ b/testsuite/tests/th/T16895a.stderr
@@ -0,0 +1,5 @@
+
+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 |])
diff --git a/testsuite/tests/th/T16895b.hs b/testsuite/tests/th/T16895b.hs
new file mode 100644
index 000000000000..d4308ecbaaea
--- /dev/null
+++ b/testsuite/tests/th/T16895b.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module T16895b where
+
+import Language.Haskell.TH
+
+main = print $(infixE Nothing [|id id|] (Just [|2|]))
diff --git a/testsuite/tests/th/T16895b.stderr b/testsuite/tests/th/T16895b.stderr
new file mode 100644
index 000000000000..8309912f6425
--- /dev/null
+++ b/testsuite/tests/th/T16895b.stderr
@@ -0,0 +1,6 @@
+
+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 |]))
diff --git a/testsuite/tests/th/T16895c.hs b/testsuite/tests/th/T16895c.hs
new file mode 100644
index 000000000000..5e262586e2f1
--- /dev/null
+++ b/testsuite/tests/th/T16895c.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module T16895c where
+
+import Language.Haskell.TH
+
+main = print $(infixE (Just [|1|]) [|id id|] Nothing)
diff --git a/testsuite/tests/th/T16895c.stderr b/testsuite/tests/th/T16895c.stderr
new file mode 100644
index 000000000000..38475cce3c58
--- /dev/null
+++ b/testsuite/tests/th/T16895c.stderr
@@ -0,0 +1,6 @@
+
+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)
diff --git a/testsuite/tests/th/T16895d.hs b/testsuite/tests/th/T16895d.hs
new file mode 100644
index 000000000000..6a92043e26f7
--- /dev/null
+++ b/testsuite/tests/th/T16895d.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module T16895d where
+
+import Language.Haskell.TH
+
+main = print $(infixE (Just [|1|]) [|(id id)|] (Just [|2|]))
diff --git a/testsuite/tests/th/T16895d.stderr b/testsuite/tests/th/T16895d.stderr
new file mode 100644
index 000000000000..57ba8725bacb
--- /dev/null
+++ b/testsuite/tests/th/T16895d.stderr
@@ -0,0 +1,6 @@
+
+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 |]))
diff --git a/testsuite/tests/th/T16895e.hs b/testsuite/tests/th/T16895e.hs
new file mode 100644
index 000000000000..0ba2325578c5
--- /dev/null
+++ b/testsuite/tests/th/T16895e.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module T16895e where
+
+import Language.Haskell.TH
+
+main = print $(infixE Nothing [|id id|] Nothing)
diff --git a/testsuite/tests/th/T16895e.stderr b/testsuite/tests/th/T16895e.stderr
new file mode 100644
index 000000000000..90884a09da71
--- /dev/null
+++ b/testsuite/tests/th/T16895e.stderr
@@ -0,0 +1,5 @@
+
+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)
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index def7a843c85a..02902c395610 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -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, [''])
--
GitLab