Add parentheses in more cases. (#34)

- Op applied to argument
- patterns (for older GHCs)

src/GHC/SourceGen/Overloaded.hs

@@ -126,7 +126,7 @@ instance App HsExpr' where
             PlaceHolder
 #endif
             (parenthesizeExprForOp $ builtLoc y)
-    x @@ y = noExt HsApp (builtLoc x)
+    x @@ y = noExt HsApp (parenthesizeExprForOp $ builtLoc x)
                 (parenthesizeExprForApp $ builtLoc y)
 
 instance App HsType' where
@@ -135,7 +135,7 @@ instance App HsType' where
                 (typeRdrName o)
                 (parenthesizeTypeForOp $ builtLoc y)
     x @@ y = noExt HsAppTy
-                (builtLoc x)
+                (parenthesizeTypeForOp $ builtLoc x)
                 (parenthesizeTypeForApp $ builtLoc y)
 
 class HasTuple e where

src/GHC/SourceGen/Pat.hs

@@ -4,6 +4,7 @@
 -- license that can be found in the LICENSE file or at
 -- https://developers.google.com/open-source/licenses/bsd
 
+{-# LANGUAGE CPP #-}
 -- | This module provides combinators for constructing Haskell patterns.
 module GHC.SourceGen.Pat
     ( Pat'
@@ -15,10 +16,13 @@ module GHC.SourceGen.Pat
     , lazyP
     ) where
 
+import SrcLoc (unLoc)
 import HsTypes
 import HsPat hiding (LHsRecField')
 
 import GHC.SourceGen.Name.Internal
+import GHC.SourceGen.Overloaded (par)
+import GHC.SourceGen.Expr.Internal (litNeedsParen, overLitNeedsParen)
 import GHC.SourceGen.Syntax.Internal
 
 -- | A wild pattern (@_@).
@@ -31,7 +35,7 @@ wildP = noExtOrPlaceHolder WildPat
 -- > =====
 -- > asP "a" (var "B")
 asP :: RdrNameStr -> Pat' -> Pat'
-v `asP` p = noExt AsPat (valueRdrName v) $ builtPat p
+v `asP` p = noExt AsPat (valueRdrName v) $ builtPat $ parenthesize p
 
 -- | A pattern constructor.
 --
@@ -39,7 +43,34 @@ v `asP` p = noExt AsPat (valueRdrName v) $ builtPat p
 -- > =====
 -- > conP "A" [var "b", var "c"]
 conP :: RdrNameStr -> [Pat'] -> Pat'
-conP c xs = ConPatIn (valueRdrName c) $ PrefixCon $ map builtPat xs
+conP c xs = ConPatIn (valueRdrName c) $ PrefixCon
+                $ map (builtPat . parenthesize) xs
+
+-- Note: GHC>=8.6 inserts parentheses automatically when pretty-printing patterns.
+-- When we stop supporting lower versions, we may be able to simplify this.
+parenthesize :: Pat' -> Pat'
+parenthesize p
+    | needsPar p = par p
+    | otherwise = p
+
+needsPar :: Pat' -> Bool
+#if MIN_VERSION_ghc(8,6,0)
+needsPar (LitPat _ l) = litNeedsParen l
+needsPar (NPat _ l _ _) = overLitNeedsParen $ unLoc l
+#else
+needsPar (LitPat l) = litNeedsParen l
+needsPar (NPat l _ _ _) = overLitNeedsParen $ unLoc l
+#endif
+needsPar (ConPatIn _ (PrefixCon xs)) = not $ null xs
+needsPar (ConPatIn _ (InfixCon _ _)) = True
+needsPar ConPatOut{} = True
+#if MIN_VERSION_ghc(8,6,0)
+needsPar SigPat{} = True
+#else
+needsPar SigPatIn{} = True
+needsPar SigPatOut{} = True
+#endif
+needsPar _ = False
 
 recordConP :: RdrNameStr -> [(RdrNameStr, Pat')] -> Pat'
 recordConP c fs
@@ -61,7 +92,7 @@ recordConP c fs
 -- > =====
 -- > strictP (var x)
 strictP :: Pat' -> Pat'
-strictP = noExt BangPat . builtPat
+strictP = noExt BangPat . builtPat . parenthesize
 
 -- | A lazy pattern match.
 --
@@ -69,4 +100,4 @@ strictP = noExt BangPat . builtPat
 -- > =====
 -- > lazyP (conP "A" [var x])
 lazyP :: Pat' -> Pat'
-lazyP = noExt LazyPat . builtPat
+lazyP = noExt LazyPat . builtPat . parenthesize

tests/pprint_test.hs

@@ -17,9 +17,10 @@ data TestCase a = String :~ a
 infixr 0 :~
 
 testCases :: Outputable a => DynFlags -> String -> [TestCase a] -> TestTree
-testCases dflags name cases = testCase name $ mapM_ run cases
+testCases dflags name cases = testGroup name $ map run cases
   where
-    run (expected :~ x) = expected @=? showPpr dflags x
+    run (expected :~ x) =
+        testCase (takeWhile (/='\n') expected) $ expected @=? showPpr dflags x
 
 testTypes :: DynFlags ->  String -> [TestCase HsType'] -> TestTree
 testTypes = testCases
@@ -30,13 +31,17 @@ testExprs = testCases
 testDecls :: DynFlags ->  String -> [TestCase HsDecl'] -> TestTree
 testDecls = testCases
 
+testPats :: DynFlags ->  String -> [TestCase Pat'] -> TestTree
+testPats = testCases
+
+
 main :: IO ()
 main = runGhc (Just libdir) $ do
     dflags <- getDynFlags
     liftIO $ defaultMain $ testGroup "Tests"
-        [typesTest dflags, exprsTest dflags, declsTest dflags]
+        [typesTest dflags, exprsTest dflags, declsTest dflags, patsTest dflags]
 
-typesTest, exprsTest, declsTest :: DynFlags -> TestTree
+typesTest, exprsTest, declsTest, patsTest :: DynFlags -> TestTree
 typesTest dflags = testGroup "Type"
     [ test "var"
         [ "A" :~ var "A"
@@ -49,6 +54,8 @@ typesTest dflags = testGroup "Type"
         [ "A x" :~ var "A" @@ var "x"
         , "(+) x" :~ var "+" @@ var "x"
         , "A (B x)" :~ var "A" @@ par (var "B" @@ var "x")
+        , "A (B x)" :~ var "A" @@ par (var "B" @@ var "x")
+        , "A ((B x))" :~ var "A" @@ par (par (var "B" @@ var "x"))
         , "A x (B y z)" :~ var "A" @@ var "x" @@ (var "B" @@ var "y" @@ var "z")
         , "A w (B x y) Z"
             :~ var "A" @@ var "w" @@ (var "B" @@ var "x" @@ var "y") @@ var "Z"
@@ -57,9 +64,11 @@ typesTest dflags = testGroup "Type"
         [ "x + y" :~ op (var "x") "+" (var "y")
         , "x `add` y" :~ op (var "x") "add" (var "y")
         , "x * (y + z)" :~ op (var "x") "*" (op (var "y") "+" (var "z"))
+        , "(x * y) + z" :~ op (op (var "x") "*" (var "y")) "+" (var "z")
         , "x `mult` (y `add` z)" :~ op (var "x") "mult" (op (var "y") "add" (var "z"))
         , "A x * (B y + C z)" :~ op (var "A" @@ var "x") "*"
                                     (op (var "B" @@ var "y") "+" (var "C" @@ var "z"))
+        , "(f . g) x" :~ op (var "f") "." (var "g") @@ var "x"
         ]
     , test "function"
         [ "a -> b" :~ var "a" --> var "b"
@@ -95,7 +104,9 @@ exprsTest dflags = testGroup "Expr"
         [ "A x" :~ var "A" @@ var "x"
         , "(+) x" :~ var "+" @@ var "x"
         , "(Prelude.+) x" :~ var "Prelude.+" @@ var "x"
+        , "A (B x)" :~ var "A" @@ (var "B" @@ var "x")
         , "A (B x)" :~ var "A" @@ par (var "B" @@ var "x")
+        , "A ((B x))" :~ var "A" @@ par (par (var "B" @@ var "x"))
         , "A x (B y z)" :~ var "A" @@ var "x" @@ (var "B" @@ var "y" @@ var "z")
         , "A w (B x y) Z"
             :~ var "A" @@ var "w" @@ (var "B" @@ var "x" @@ var "y") @@ var "Z"
@@ -105,15 +116,23 @@ exprsTest dflags = testGroup "Expr"
         , "A ((-3) % 1)" :~ var "A" @@ frac (-3.0)
         , "A 'x'" :~ var "A" @@ char 'x'
         , "A \"xyz\"" :~ var "A" @@ string "xyz"
+        , "(\\ x -> x) (\\ x -> x)" :~
+            let f = lambda [var "x"] (var "x")
+            in f @@ f
         ]
     , test "op"
         [ "x + y" :~ op (var "x") "+" (var "y")
         , "x Prelude.+ y" :~ op (var "x") "Prelude.+" (var "y")
         , "x `add` y" :~ op (var "x") "add" (var "y")
         , "x * (y + z)" :~ op (var "x") "*" (op (var "y") "+" (var "z"))
+        , "(x * y) + z" :~ op (op (var "x") "*" (var "y")) "+" (var "z")
         , "x `mult` (y `add` z)" :~ op (var "x") "mult" (op (var "y") "add" (var "z"))
         , "A x * (B y + C z)" :~ op (var "A" @@ var "x") "*"
                                     (op (var "B" @@ var "y") "+" (var "C" @@ var "z"))
+        , "(f . g) x" :~ op (var "f") "." (var "g") @@ var "x"
+        , "(\\ x -> x) . (\\ x -> x)" :~
+            let f = lambda [var "x"] (var "x")
+            in op f "." f
         ]
     , test "period-op"
         [ "(Prelude..) x" :~ var "Prelude.." @@ var "x"
@@ -214,3 +233,44 @@ declsTest dflags = testGroup "Decls"
     ]
   where
     test = testDecls dflags
+
+patsTest dflags = testGroup "Pats"
+    [ test "app"
+        [ "A x y" :~ conP "A" [var "x", var "y"]
+        , "(:) x y" :~ conP ":" [var "x", var "y"]
+        , "(Prelude.:) x" :~ conP "Prelude.:" [var "x"]
+        , "A (B x)" :~ conP "A" [conP "B" [var "x"]]
+        , "A (B x)" :~ conP "A" [par $ conP "B" [var "x"]]
+        , "A ((B x))" :~ conP "A" [par $ par $ conP "B" [var "x"]]
+        , "A x (B y z)" :~ conP "A" [var "x", conP "B" [var "y", var "z"]]
+        , "A w (B x y) Z"
+            :~ conP "A" [var "w", conP "B" [var "x", var "y"], conP "Z" []]
+        , "A 3" :~ conP "A" [int 3]
+        , "A (-3)" :~ conP "A" [int (-3)]
+        -- TODO(#33): this is incorrect:
+        -- , "A (3 % 1)" :~ conP "A" [frac 3.0]
+        -- , "A ((-3) % 1)" :~ conP "A" [frac (-3.0)]
+        , "A 'x'" :~ conP "A" [char 'x']
+        , "A \"xyz\"" :~ conP "A" [string "xyz"]
+        ]
+    , test "asP"
+        [ "x@B" :~ asP "x" $ conP "B" []
+        , "x@(B y)" :~ asP "x" $ conP "B" [var "y"]
+        , "x@_" :~ asP "x" wildP
+        ]
+    , test "strictP"
+        [ "!x" :~ strictP $ var "x"
+        , "!B" :~ strictP $ conP "B" []
+        , "!(B y)" :~ strictP $ conP "B" [var "y"]
+        , "!_" :~ strictP wildP
+        ]
+    , test "lazyP"
+        [ "~x" :~ lazyP $ var "x"
+        , "~B" :~ lazyP $ conP "B" []
+        , "~(B y)" :~ lazyP $ conP "B" [var "y"]
+        , "~_" :~ lazyP wildP
+        ]
+    ]
+  where
+    test = testPats dflags
+