diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index 12f22e8dd37d83ebda1238c2204344fd592141c6..97329aaa553e9e451556c7d28319cd825feea9d9 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 6eaadd648eaa59247ba7181c771b00d9411a2afb..792a78b6061c78629f861b40b23cc421c6c628fd 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 2d79d5a28f6a2a2dd0929148c92197687676009e..f79a8e2b0cf4e19ef3fce1a106832d4265199bce 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 0000000000000000000000000000000000000000..8bc847d271cd7e03b1d3f42c960d1524263ebb70
--- /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 0000000000000000000000000000000000000000..d4b98c944ab7c4b2313f7fef7604d80a0cae9f5d
--- /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 0000000000000000000000000000000000000000..d4308ecbaaea097cb8f44588b81fc51d74d10d7f
--- /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 0000000000000000000000000000000000000000..8309912f6425ee25c35589103802e79b846e53b2
--- /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 0000000000000000000000000000000000000000..5e262586e2f134df6b5931b4a49d41caa59d8d06
--- /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 0000000000000000000000000000000000000000..38475cce3c58e8a131f0edfa1f0f57c0ff14f3db
--- /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 0000000000000000000000000000000000000000..6a92043e26f7d4ff0b021f57ea09597ec41637b5
--- /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 0000000000000000000000000000000000000000..57ba8725bacbbb5f2dab046c531da1e254a97614
--- /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 0000000000000000000000000000000000000000..0ba2325578c51f7856c2e88d4560a716e18f71d3
--- /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 0000000000000000000000000000000000000000..90884a09da719d4269417f5d8405dda9aeca65d2
--- /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 def7a843c85aabb027d69b9cdce87d07c456551c..02902c395610d7aeefec1cb245d8ac64a36d2275 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, [''])