mirror of
https://github.com/swarm-game/swarm.git
synced 2024-10-27 01:49:15 +03:00
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.
This commit is contained in:
parent
75eab16115
commit
b89667ab68
@ -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
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user