From 3aca5ff7a8aac0b724862a201a34c80d9f60486e Mon Sep 17 00:00:00 2001
From: Sean Gillespie <sean@mistersg.net>
Date: Fri, 30 Dec 2016 21:31:12 -0500
Subject: [PATCH] Fix System F pretty printer
X->Y -> Z => X->Y->Z
---
src/Language/SystemF/Expression.hs | 15 ++++++++++-----
test/Language/SystemF/ExpressionSpec.hs | 5 ++++-
2 files changed, 14 insertions(+), 6 deletions(-)
diff --git a/src/Language/SystemF/Expression.hs b/src/Language/SystemF/Expression.hs
index ecfd260..437f0e2 100644
--- a/src/Language/SystemF/Expression.hs
+++ b/src/Language/SystemF/Expression.hs
@@ -101,11 +101,16 @@ pprTyArrow :: PrettyPrint n
-> Ty n
-> Ty n
-> PDoc String
-pprTyArrow pdoc space a@(TyVar _) b = pprTyArrow' pdoc space a b
-pprTyArrow pdoc space a@(TyArrow _ _) b = pprTyArrow' pdoc space a' b
- where a' = betweenParens (pprTy empty space a) empty
-
-pprTyArrow' pdoc space a b = between arrow (prettyPrint a) (prettyPrint b) pdoc
+pprTyArrow pdoc space a@(TyVar _) b = pprTyArrow' space (pprTy pdoc space a)
+ (pprTy pdoc space b)
+pprTyArrow pdoc space (TyArrow a1 a2) b = pprTyArrow' space a' (pprTy pdoc space b)
+ where a' = betweenParens (pprTyArrow pdoc space a1 a2) empty
+
+pprTyArrow' :: Bool -- Add a space between arrows?
+ -> PDoc String
+ -> PDoc String
+ -> PDoc String
+pprTyArrow' space a b = a <> arrow <> b
where arrow | space = " -> " `add` empty
| otherwise = "->" `add` empty
diff --git a/test/Language/SystemF/ExpressionSpec.hs b/test/Language/SystemF/ExpressionSpec.hs
index 674f5c8..21e23d4 100644
--- a/test/Language/SystemF/ExpressionSpec.hs
+++ b/test/Language/SystemF/ExpressionSpec.hs
@@ -27,10 +27,13 @@ spec = describe "prettyPrint" $ do
prettyPrint (Abs "f" (TyVar "F") (Abs "x" (TyVar "X") (Var "x")))
`shouldBe` "λ f:F x:X. x"
- it "prints abstractions with composite types" $
+ it "prints abstractions with composite types" $ do
prettyPrint (Abs "f" (TyArrow (TyVar "X") (TyVar "Y")) (Var "f"))
`shouldBe ` "λ f:(X->Y). f"
+ prettyPrint (Abs "f" (TyArrow (TyVar "X") (TyArrow (TyVar "Y") (TyVar "Z"))) (Var "f"))
+ `shouldBe ` "λ f:(X->Y->Z). f"
+
it "prints nested type abstractions" $
prettyPrint (TyAbs (TyVar "A") (TyAbs (TyVar "B") (Var "x")))
`shouldBe` "Λ A B. x"
--
GitLab