Add SystemF expression

lambda-calculator.cabal

@@ -19,7 +19,10 @@ library
                        Language.Lambda.Expression,
                        Language.Lambda.Eval,
                        Language.Lambda.Parser,
-                       Language.Lambda.PrettyPrint
+                       Language.Lambda.PrettyPrint,
+
+                       Language.SystemF,
+                       Language.SystemF.Expression
   build-depends:       base <= 5,
                        parsec
   default-language:    Haskell2010
@@ -48,7 +51,10 @@ test-suite lambda-calculus-test
                        Language.Lambda.EvalSpec,
                        Language.Lambda.HspecUtils,
                        Language.Lambda.ParserSpec,
-                       Language.Lambda.PrettyPrintSpec
+                       Language.Lambda.PrettyPrintSpec,
+
+                       Language.SystemFSpec,
+                       Language.SystemF.ExpressionSpec
   build-depends:       base <= 5,
                        lambda-calculator,
                        hspec,

src/Language/SystemF.hs

+module Language.SystemF (
+  evalString
+  ) where
+
+-- TODO
+evalString = undefined
+

src/Language/SystemF/Expression.hs

+{-# LANGUAGE FlexibleInstances #-}
+module Language.SystemF.Expression where
+
+import Language.Lambda.PrettyPrint
+
+data SystemFExpr name ty
+  = Var name                                        -- Variable
+  | App (SystemFExpr name ty) (SystemFExpr name ty) -- Application
+  | Abs name ty (SystemFExpr name ty)               -- Abstraction
+  | TyAbs ty (SystemFExpr name ty)                  -- Type Abstraction
+                                                    -- \X. body
+
+  | TyApp (SystemFExpr name ty) ty                  -- Type Application
+                                                    -- x [X]
+  deriving (Eq, Show)
+
+-- Pretty printing
+instance (PrettyPrint n, PrettyPrint t) => PrettyPrint (SystemFExpr n t) where
+  prettyPrint = prettyPrint . pprExpr empty
+
+-- Same as prettyPrint, but we assume the same type for names and types. Useful
+-- for testing.
+prettyPrint' :: PrettyPrint n => SystemFExpr n n -> String
+prettyPrint' = prettyPrint
+
+-- Pretty print a system f expression
+pprExpr :: (PrettyPrint n, PrettyPrint t) 
+        => PDoc String 
+        -> SystemFExpr n t 
+        -> PDoc String
+pprExpr pdoc (Var n)        = prettyPrint n `add` pdoc
+pprExpr pdoc (App e1 e2)    = pprApp pdoc e1 e2
+pprExpr pdoc (Abs n t body) = pprAbs pdoc n t body
+
+-- Pretty print an application
+pprApp :: (PrettyPrint n, PrettyPrint t)
+       => PDoc String
+       -> SystemFExpr n t
+       -> SystemFExpr n t
+       -> PDoc String
+pprApp pdoc e1@Abs{} e2@Abs{} = betweenParens (pprExpr pdoc e1) pdoc
+  `mappend` addSpace (betweenParens (pprExpr pdoc e2) pdoc)
+pprApp pdoc e1 e2@App{} = pprExpr pdoc e1
+  `mappend` addSpace (betweenParens (pprExpr pdoc e2) pdoc)
+pprApp pdoc e1 e2@Abs{} = pprExpr pdoc e1
+  `mappend` addSpace (betweenParens (pprExpr pdoc e2) pdoc)
+pprApp pdoc e1@Abs{} e2 = betweenParens (pprExpr pdoc e1) pdoc
+  `mappend` addSpace (pprExpr pdoc e2)
+pprApp pdoc e1 e2
+  = pprExpr pdoc e1 `mappend` addSpace (pprExpr pdoc e2)
+
+-- Pretty print an abstraction
+pprAbs :: (PrettyPrint n, PrettyPrint t)
+       => PDoc String
+       -> n
+       -> t
+       -> SystemFExpr n t
+       -> PDoc String
+pprAbs pdoc name ty body = between vars' [lambda, ' '] ". " (pprExpr pdoc body')
+  where (vars, body') = uncurry' name ty body
+        vars' = intercalate (map (uncurry pprArg) vars) " " empty
+        pprArg n t = prettyPrint n ++ ":" ++ prettyPrint t
+
+uncurry' :: n -> t -> SystemFExpr n t -> ([(n, t)], SystemFExpr n t)
+uncurry' name ty = uncurry'' [(name, ty)] 
+  where uncurry'' ns (Abs n' t' body') = uncurry'' ((n', t'):ns) body'
+        uncurry'' ns body'             = (reverse ns, body')

test/Language/SystemF/ExpressionSpec.hs

+{-# LANGUAGE FlexibleInstances #-}
+module Language.SystemF.ExpressionSpec where
+
+import Test.Hspec
+
+import Language.Lambda.PrettyPrint
+import Language.SystemF.Expression
+
+spec :: Spec
+spec = describe "prettyPrint" $ do
+  it "prints simple variables" $
+    prettyPrint' (Var "x") `shouldBe` "x"
+
+  it "prints simple applications" $
+    prettyPrint' (App (Var "a") (Var "b")) `shouldBe` "a b"
+
+  it "prints simple abstracctions" $ 
+    prettyPrint (Abs "x" "T" (Var "x")) `shouldBe` "λ x:T. x"
+
+

test/Language/SystemFSpec.hs

+module Language.SystemFSpec where
+
+import Test.Hspec
+
+import Language.SystemF
+
+spec :: Spec
+spec = describe "evalString" $ 
+  return ()