ThToHs: fix overzealous parenthesization

Before this patch, when converting from TH.Exp to LHsExpr GhcPs,
the compiler inserted more parentheses than required:

	((f a) (b + c)) d

This was happening because the LHS of the function application was
parenthesized as if it was the RHS.

Now we use funPrec and appPrec appropriately and produce sensibly
parenthesized expressions:

	f a (b + c) d

I also took the opportunity to remove the special case for LamE,
which was not special at all and simply duplicated code.

7 files changed, 29 insertions, 13 deletions

diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index 9f5badae49..11f601cd70 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -979,17 +979,13 @@ cvtl e = wrapLA (cvt e)
           l' <- cvt_lit l
           let e' = mk_expr l'
           if is_compound_lit l' then wrapParLA gHsPar e' else pure e'
-    cvt (AppE x@(LamE _ _) y) = do { x' <- cvtl x; y' <- cvtl y
-                                   ; return $ HsApp noComments (mkLHsPar x')
-                                                          (mkLHsPar y')}
-    cvt (AppE x y)            = do { x' <- cvtl x; y' <- cvtl y
-                                   ; return $ HsApp noComments (mkLHsPar x')
-                                                          (mkLHsPar y')}
-    cvt (AppTypeE e t) = do { e' <- cvtl e
-                            ; t' <- cvtType t
-                            ; let tp = parenthesizeHsType appPrec t'
+    cvt (AppE e1 e2)   = do { e1' <- parenthesizeHsExpr opPrec <$> cvtl e1
+                            ; e2' <- parenthesizeHsExpr appPrec <$> cvtl e2
+                            ; return $ HsApp noComments e1' e2' }
+    cvt (AppTypeE e t) = do { e' <- parenthesizeHsExpr opPrec <$> cvtl e
+                            ; t' <- parenthesizeHsType appPrec <$> cvtType t
                             ; return $ HsAppType noExtField e' noHsTok
-                                     $ mkHsWildCardBndrs tp }
+                                     $ mkHsWildCardBndrs t' }
     cvt (LamE [] e)    = cvt e -- Degenerate case. We convert the body as its
                                -- own expression to avoid pretty-printing
                                -- oddities that can result from zero-argument
diff --git a/testsuite/tests/th/T13776.stderr b/testsuite/tests/th/T13776.stderr
index debcc0bbcd..54281b9120 100644
--- a/testsuite/tests/th/T13776.stderr
+++ b/testsuite/tests/th/T13776.stderr
@@ -5,7 +5,7 @@ T13776.hs:7:15-62: Splicing type
 T13776.hs:14:15-75: Splicing expression
     conE '(,) `appE` litE (integerL 1) `appE` litE (integerL 1)
   ======>
-    ((,) 1) 1
+    (,) 1 1
 T13776.hs:17:15-24: Splicing expression conE '[] ======> []
 T13776.hs:20:13-62: Splicing pattern
     conP '(,) [litP (integerL 1), litP (integerL 1)] ======> (,) 1 1
diff --git a/testsuite/tests/th/T14681.stderr b/testsuite/tests/th/T14681.stderr
index e325180dd8..f9838186ca 100644
--- a/testsuite/tests/th/T14681.stderr
+++ b/testsuite/tests/th/T14681.stderr
@@ -8,4 +8,4 @@ T14681.hs:(8,2)-(9,63): Splicing declarations
                          $ VarE '(+) `AppE` LitE (IntegerL (- 1))
                              `AppE` (LitE (IntegerL (- 1)))>]
   ======>
-    g = ((+) (-1)) (-1)
+    g = (+) (-1) (-1)
diff --git a/testsuite/tests/th/T17608.stderr b/testsuite/tests/th/T17608.stderr
index 1073c5030b..c972bbd5d9 100644
--- a/testsuite/tests/th/T17608.stderr
+++ b/testsuite/tests/th/T17608.stderr
@@ -24,7 +24,7 @@ T17608.hs:(4,2)-(20,7): Splicing declarations
           infixl 4 `h`
           h :: () -> Bool -> Bool
           h _ _ = True
-        in (h ()) ((g ()) ())
+        in h () (g () ())
       where
           infixl 4 `g`
           g :: () -> () -> Bool
diff --git a/testsuite/tests/th/TH_fun_par.hs b/testsuite/tests/th/TH_fun_par.hs
new file mode 100644
index 0000000000..f028395cc8
--- /dev/null
+++ b/testsuite/tests/th/TH_fun_par.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module TH_fun_par where
+
+import Data.Foldable (for_)
+import System.IO
+import Language.Haskell.TH
+
+do let eLam = [e| \a b -> (b,a) |]
+       eOp  = [e| even . length |]
+   e1 <- [e| const @Int @Bool (1 + 2) True |]
+   e2 <- [e| $eLam (Just 'x') False |]
+   e3 <- [e| $eOp "Hello" |]
+   for_ [e1, e2, e3] $ \e -> do
+     runIO $ hPutStrLn stderr $ pprint e
+   return []
diff --git a/testsuite/tests/th/TH_fun_par.stderr b/testsuite/tests/th/TH_fun_par.stderr
new file mode 100644
index 0000000000..751917b11f
--- /dev/null
+++ b/testsuite/tests/th/TH_fun_par.stderr
@@ -0,0 +1,3 @@
+GHC.Base.const @GHC.Types.Int @GHC.Types.Bool (1 GHC.Num.+ 2) GHC.Types.True
+(\a_0 b_1 -> (b_1, a_0)) (GHC.Maybe.Just 'x') GHC.Types.False
+(GHC.Real.even GHC.Base.. Data.Foldable.length) "Hello"
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index b77bc737bb..369ca67855 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -555,3 +555,4 @@ test('Lift_ByteArray', normal, compile_and_run, [''])
 test('T21920', normal, compile_and_run, [''])
 test('T21723', normal, compile_and_run, [''])
 test('T21942', normal, compile_and_run, [''])
+test('TH_fun_par', normal, compile, [''])
\ No newline at end of file