Add a Type type

src/Language/SystemF/Expression.hs

 {-# LANGUAGE FlexibleInstances #-}
 module Language.SystemF.Expression where
 
+import Data.Monoid
+
 import Language.Lambda.Util.PrettyPrint
 
 data SystemFExpr name ty
@@ -14,10 +16,18 @@ data SystemFExpr name ty
                                                     -- x [X]
   deriving (Eq, Show)
 
+data Ty name
+  = TyVar name                      -- Type variable (T)
+  | TyArrow (Ty name) (Ty name) -- Type arrow    (T -> U)
+  deriving (Eq, Show)
+
 -- Pretty printing
 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
+
 -- Same as prettyPrint, but we assume the same type for names and types. Useful
 -- for testing.
 prettyPrint' :: PrettyPrint n => SystemFExpr n n -> String
@@ -73,6 +83,26 @@ pprAbs pdoc name ty body = between vars' lambda' ". " (pprExpr pdoc body')
         pprArg n t = prettyPrint n ++ ":" ++ prettyPrint t
         lambda' = [lambda, space]
 
+-- Pretty print types
+pprTy :: PrettyPrint n
+      => PDoc String
+      -> Ty n
+      -> PDoc String
+pprTy pdoc (TyVar n) = prettyPrint n `add` pdoc
+pprTy pdoc (TyArrow a b) = pprTyArrow pdoc a b
+
+pprTyArrow :: PrettyPrint n
+           => PDoc String
+           -> 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 a b = between arrow (prettyPrint a) (prettyPrint b) pdoc
+  where arrow = " -> " `add` empty
+
 -- Pretty print a type abstraction
 pprTAbs :: (PrettyPrint n, PrettyPrint t)
         => PDoc String

test/Language/SystemF/ExpressionSpec.hs

@@ -14,7 +14,7 @@ spec = describe "prettyPrint" $ do
   it "prints simple applications" $
     prettyPrint' (App (Var "a") (Var "b")) `shouldBe` "a b"
 
-  it "prints simple abstracctions" $ 
+  it "prints simple abstractions" $ 
     prettyPrint (Abs "x" "T" (Var "x")) `shouldBe` "λ x:T. x"
 
   it "prints simple type abstractions" $
@@ -44,3 +44,17 @@ spec = describe "prettyPrint" $ do
 
     prettyPrint (App (Abs "f" "F" (Var "f")) (Abs "g" "G" (Var "g")))
       `shouldBe` "(λ f:F. f) (λ g:G. g)"
+
+  it "prints simple types" $
+    prettyPrint (TyVar "X") `shouldBe` "X"
+
+  it "print simple arrow types" $
+    prettyPrint (TyArrow (TyVar "A") (TyVar "B")) `shouldBe` "A -> B"
+
+  it "prints chained arrow types" $
+    prettyPrint (TyArrow (TyVar "X") (TyArrow (TyVar "Y") (TyVar "Z")))
+      `shouldBe` "X -> Y -> Z"
+
+  it "prints nested arrow types" $
+    prettyPrint (TyArrow (TyArrow (TyVar "T") (TyVar "U")) (TyVar "V"))
+      `shouldBe` "(T -> U) -> V"