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

14 files changed, 108 insertions, 11 deletions

diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index 12f22e8dd3..97329aaa55 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 6eaadd648e..792a78b606 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 2d79d5a28f..f79a8e2b0c 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 0000000000..8bc847d271
--- /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 0000000000..d4b98c944a
--- /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 0000000000..d4308ecbaa
--- /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 0000000000..8309912f64
--- /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 0000000000..5e262586e2
--- /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 0000000000..38475cce3c
--- /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 0000000000..6a92043e26
--- /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 0000000000..57ba8725ba
--- /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 0000000000..0ba2325578
--- /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 0000000000..90884a09da
--- /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 def7a843c8..02902c3956 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, [''])