From b160e65a8089bf1b0df26db67bd7c59b080bb47e Mon Sep 17 00:00:00 2001
From: Sean Gillespie <sean@mistersg.net>
Date: Fri, 30 Dec 2016 17:42:37 -0500
Subject: [PATCH] Refactor System F prettyPrinter
If we are printing an abs arg, supress the spaces between
arrows
---
src/Language/SystemF/Expression.hs | 26 ++++++++++++++++---------
test/Language/SystemF/ExpressionSpec.hs | 4 ++++
2 files changed, 21 insertions(+), 9 deletions(-)
diff --git a/src/Language/SystemF/Expression.hs b/src/Language/SystemF/Expression.hs
index 28880c4..ecfd260 100644
--- a/src/Language/SystemF/Expression.hs
+++ b/src/Language/SystemF/Expression.hs
@@ -1,6 +1,8 @@
{-# LANGUAGE FlexibleInstances #-}
module Language.SystemF.Expression where
+import Data.Monoid
+
import Language.Lambda.Util.PrettyPrint
data SystemFExpr name ty
@@ -24,7 +26,7 @@ instance (PrettyPrint n, PrettyPrint t) => PrettyPrint (SystemFExpr n t) where
prettyPrint = prettyPrint . pprExpr empty
instance PrettyPrint n => PrettyPrint (Ty n) where
- prettyPrint = prettyPrint . pprTy empty
+ prettyPrint = prettyPrint . pprTy empty True
-- Same as prettyPrint, but we assume the same type for names and types. Useful
-- for testing.
@@ -78,28 +80,34 @@ pprAbs :: (PrettyPrint n, PrettyPrint t)
pprAbs pdoc name ty body = between vars' lambda' ". " (pprExpr pdoc body')
where (vars, body') = uncurryAbs name ty body
vars' = intercalate (map (uncurry pprArg) vars) " " empty
- pprArg n t = prettyPrint n ++ ":" ++ prettyPrint t
lambda' = [lambda, space]
+ pprArg n t = prettyPrint n ++ (':':pprArg' t)
+ pprArg' t@(TyVar _) = prettyPrint t
+ pprArg' t@(TyArrow _ _) = prettyPrint $ betweenParens (pprTy empty False t) empty
+
-- Pretty print types
pprTy :: PrettyPrint n
=> PDoc String
+ -> Bool -- Add a space between arrows?
-> Ty n
-> PDoc String
-pprTy pdoc (TyVar n) = prettyPrint n `add` pdoc
-pprTy pdoc (TyArrow a b) = pprTyArrow pdoc a b
+pprTy pdoc space (TyVar n) = prettyPrint n `add` pdoc
+pprTy pdoc space (TyArrow a b) = pprTyArrow pdoc space a b
pprTyArrow :: PrettyPrint n
=> PDoc String
+ -> Bool -- Add a space between arrows?
-> Ty n
-> Ty n
-> PDoc String
-pprTyArrow pdoc a@(TyVar _) b = pprTyArrow' pdoc a b
-pprTyArrow pdoc a@(TyArrow _ _) b = pprTyArrow' pdoc a' b
- where a' = betweenParens (pprTy empty a) empty
+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 a b = between arrow (prettyPrint a) (prettyPrint b) pdoc
- where arrow = " -> " `add` empty
+pprTyArrow' pdoc space a b = between arrow (prettyPrint a) (prettyPrint b) pdoc
+ where arrow | space = " -> " `add` empty
+ | otherwise = "->" `add` empty
-- Pretty print a type abstraction
pprTAbs :: (PrettyPrint n, PrettyPrint t)
diff --git a/test/Language/SystemF/ExpressionSpec.hs b/test/Language/SystemF/ExpressionSpec.hs
index 9757e36..674f5c8 100644
--- a/test/Language/SystemF/ExpressionSpec.hs
+++ b/test/Language/SystemF/ExpressionSpec.hs
@@ -27,6 +27,10 @@ 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" $
+ prettyPrint (Abs "f" (TyArrow (TyVar "X") (TyVar "Y")) (Var "f"))
+ `shouldBe ` "λ f:(X->Y). f"
+
it "prints nested type abstractions" $
prettyPrint (TyAbs (TyVar "A") (TyAbs (TyVar "B") (Var "x")))
`shouldBe` "Λ A B. x"
--
GitLab