[Git][ghc/ghc][master] ThToHs: fix overzealous parenthesization

[Marge Bot (@marge-bot)]

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC


Commits:
30e625e6 by Vladislav Zavialov at 2022-11-01T12:49:10-04:00
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 changed files:

- compiler/GHC/ThToHs.hs
- testsuite/tests/th/T13776.stderr
- testsuite/tests/th/T14681.stderr
- testsuite/tests/th/T17608.stderr
- + testsuite/tests/th/TH_fun_par.hs
- + testsuite/tests/th/TH_fun_par.stderr
- testsuite/tests/th/all.T


Changes:

=====================================
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


=====================================
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


=====================================
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)


=====================================
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


=====================================
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 []


=====================================
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"


=====================================
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



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/30e625e6d4bdd15960edce8ecc40b85ce3d72b28

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/30e625e6d4bdd15960edce8ecc40b85ce3d72b28
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20221101/eb4fb299/attachment-0001.html>