Always use parentheses when pretty-printing sum and product types (#1880)

Fixes #1625.

Before: `path : Unit + Int -> Int * Int + Text -> Cmd (Unit + Dir * Int)`
After: `path : (Unit + Int) -> ((Int * Int) + Text) -> Cmd (Unit + (Dir * Int))`

We essentially consider sum, product, and arrow to all have the same precedence level; but arrows still associate to the right.

src/swarm-lang/Swarm/Language/Pretty.hs

@@ -156,19 +156,20 @@ instance ((UnchainableFun t), (PrettyPrec t)) => PrettyPrec (TypeF t) where
   prettyPrec _ (TyVarF v) = pretty v
   prettyPrec _ (TyRcdF m) = brackets $ hsep (punctuate "," (map prettyBinding (M.assocs m)))
   -- Special cases for type constructors with special syntax.
+  -- Always use parentheses around sum and product types, see #1625
   prettyPrec p (TyConF TCSum [ty1, ty2]) =
-    pparens (p > 1) $
-      prettyPrec 2 ty1 <+> "+" <+> prettyPrec 1 ty2
+    pparens (p > 0) $
+      prettyPrec 2 ty1 <+> "+" <+> prettyPrec 2 ty2
   prettyPrec p (TyConF TCProd [ty1, ty2]) =
-    pparens (p > 2) $
-      prettyPrec 3 ty1 <+> "*" <+> prettyPrec 2 ty2
+    pparens (p > 0) $
+      prettyPrec 2 ty1 <+> "*" <+> prettyPrec 2 ty2
   prettyPrec _ (TyConF TCDelay [ty]) = braces $ ppr ty
   prettyPrec p (TyConF TCFun [ty1, ty2]) =
     let (iniF, lastF) = unsnocNE $ ty1 <| unchainFun ty2
-        funs = (prettyPrec 1 <$> iniF) <> [ppr lastF]
+        funs = (prettyPrec 2 <$> iniF) <> [prettyPrec 1 lastF]
         inLine l r = l <+> "->" <+> r
         multiLine l r = l <+> "->" <> hardline <> r
-     in pparens (p > 0) . align $
+     in pparens (p > 1) . align $
           flatAlt (concatWith multiLine funs) (concatWith inLine funs)
   -- Fallthrough cases for type constructor application.  Handles base
   -- types, Cmd, user-defined types, or ill-kinded things like 'Int

test/unit/TestPretty.hs

@@ -11,6 +11,7 @@ import Swarm.Language.Syntax hiding (mkOp)
 import Swarm.Language.Types
 import Test.Tasty
 import Test.Tasty.HUnit
+import Witch (into)
 
 testPrettyConst :: TestTree
 testPrettyConst =
@@ -86,10 +87,6 @@ testPrettyConst =
         ( equalPretty "(1, 2, 3)" $
             TPair (TInt 1) (TPair (TInt 2) (TInt 3))
         )
-    , testCase
-        "Void type"
-        ( assertEqual "" "Void" . show $ ppr TyVoid
-        )
     , testCase
         "type ascription"
         ( equalPretty "1 : Int" $
@@ -107,7 +104,83 @@ testPrettyConst =
                   :$: STerm (TLam "y" Nothing (mkOp' Mul (TVar "y") (TInt 2)))
               )
         )
+    , testGroup
+        "types"
+        [ testCase
+            "Void type"
+            ( equalPretty "Void" TyVoid
+            )
+        , testCase
+            "Unit type"
+            ( equalPretty "Unit" TyUnit
+            )
+        , testCase
+            "Function type"
+            ( equalPretty "Int -> Cmd Unit" $ TyInt :->: TyCmd TyUnit
+            )
+        , testCase
+            "Cmd type"
+            ( equalPretty "Cmd (Int -> Int)" $ TyCmd (TyInt :->: TyInt)
+            )
+        , testCase
+            "Cmd type"
+            ( equalPretty "Cmd (Int -> Int)" $ TyCmd (TyInt :->: TyInt)
+            )
+        , testCase
+            "Product type"
+            ( equalPretty "Int * Int" $ TyInt :*: TyInt
+            )
+        , testCase
+            "Sum type"
+            ( equalPretty "Int + Int" $ TyInt :+: TyInt
+            )
+        , testCase
+            "Sum of sum right"
+            ( equalPretty "Int + (Unit + Bool)" $ TyInt :+: (TyUnit :+: TyBool)
+            )
+        , testCase
+            "Sum of sum left"
+            ( equalPretty "(Int + Unit) + Bool" $ (TyInt :+: TyUnit) :+: TyBool
+            )
+        , testCase
+            "Product of product right"
+            ( equalPretty "Int * (Unit * Bool)" $ TyInt :*: (TyUnit :*: TyBool)
+            )
+        , testCase
+            "Product of product left"
+            ( equalPretty "(Int * Unit) * Bool" $ (TyInt :*: TyUnit) :*: TyBool
+            )
+        , testCase
+            "Product of sum"
+            ( equalPretty "Int * (Unit + Bool)" $ TyInt :*: (TyUnit :+: TyBool)
+            )
+        , testCase
+            "Sum of product"
+            ( equalPretty "Int + (Unit * Bool)" $ TyInt :+: (TyUnit :*: TyBool)
+            )
+        , testCase
+            "Product of function"
+            ( equalPretty "Int * (Unit -> Bool)" $ TyInt :*: (TyUnit :->: TyBool)
+            )
+        , testCase
+            "Function of product"
+            ( equalPretty "Int -> (Unit * Bool)" $ TyInt :->: (TyUnit :*: TyBool)
+            )
+        , testCase
+            "Function of function right"
+            ( equalPretty "Int -> Unit -> Bool" $ TyInt :->: (TyUnit :->: TyBool)
+            )
+        , testCase
+            "Function of function left"
+            ( equalPretty "(Int -> Unit) -> Bool" $ (TyInt :->: TyUnit) :->: TyBool
+            )
+        , testCase
+            "density (two nested products)"
+            ( equalPretty "((Int * Int) * (Int * Int)) -> Cmd Int" $
+                ((TyInt :*: TyInt) :*: (TyInt :*: TyInt)) :->: TyCmd TyInt
+            )
+        ]
     ]
  where
-  equalPretty :: String -> Term -> Assertion
-  equalPretty expected term = assertEqual "" expected . show $ ppr term
+  equalPretty :: PrettyPrec a => String -> a -> Assertion
+  equalPretty expected = assertEqual "" expected . into @String . prettyTextLine