Enough to prove functoriality of Parser

1 files changed, 67 insertions, 12 deletions

diff --git a/src/Haskell/AST.hs b/src/Haskell/AST.hs
index 8326440..e1fd1e4 100644
--- a/src/Haskell/AST.hs
+++ b/src/Haskell/AST.hs
@@ -1,38 +1,40 @@
 module Haskell.AST where
 
+import Data.List
+
 
 type Name = String
 type TyVar = String
 
 data AST = AST [Toplevel]
-  deriving (Show)
+  deriving (Show, Eq)
 
 data Toplevel = TopDef Def
               | TopDecl Decl
               | TopData Data
               | TopClass Class
               | TopInst Inst
-  deriving (Show)
+  deriving (Show, Eq)
 
 data Def = Def Name Expr
-  deriving (Show)
+  deriving (Show, Eq)
 
 data Expr = App Expr [Expr]
           | Ref Name
-          | LitNum Integer
+          | Num Integer
           | Tup [Expr]
           | Lam [Name] Expr
-          | Case Name [(Pat, Expr)]
-  deriving (Show)
+          | Case Expr [(Pat, Expr)]
+  deriving (Show, Eq)
 
 data Pat = PatAny
          | PatVar Name
          | PatCon Name [Pat]
          | PatTup [Pat]
-  deriving (Show)
+  deriving (Show, Eq)
 
 data Decl = Decl Name Type
-  deriving (Show)
+  deriving (Show, Eq)
 
 data Type = TyTup [Type]
           | TyInt
@@ -40,13 +42,66 @@ data Type = TyTup [Type]
           | TyRef Name [Type]
           | TyVar Name
           | TyVoid
-  deriving (Show)
+  deriving (Show, Eq)
 
 data Data = Data Name [TyVar] [(Name, [Type])]
-  deriving (Show)
+  deriving (Show, Eq)
 
 data Class = Class Name [TyVar] [Decl]
-  deriving (Show)
+  deriving (Show, Eq)
 
 data Inst = Inst Name Type [Def]
-  deriving (Show)
+  deriving (Show, Eq)
+
+
+class Pretty a where
+    pretty :: a -> String
+
+instance Pretty AST where
+    pretty (AST tops) = intercalate "\n" (map pretty tops)
+
+instance Pretty Toplevel where
+    pretty (TopDef x) = pretty x
+    pretty (TopDecl x) = pretty x
+    pretty (TopData x) = pretty x
+    pretty (TopClass x) = pretty x
+    pretty (TopInst x) = pretty x
+
+instance Pretty Def where
+    pretty (Def n e) = n ++ " = " ++ pretty e
+
+instance Pretty Expr where
+    pretty (App e as) = "(" ++ intercalate " " (map pretty (e:as)) ++ ")"
+    pretty (Ref n) = n
+    pretty (Num n) = show n
+    pretty (Tup es) = "(" ++ intercalate ", " (map pretty es) ++ ")"
+    pretty (Lam as e) = "(\\" ++ intercalate " " as ++ " -> " ++ pretty e ++ ")"
+    pretty (Case e arms) = "(case " ++ pretty e ++ " of { " ++ intercalate ";" (map go arms) ++ " })"
+      where go (p, e') = pretty p ++ " -> " ++ pretty e'
+
+instance Pretty Pat where
+    pretty PatAny = "_"
+    pretty (PatVar n) = n
+    pretty (PatCon n ps) = "(" ++ n ++ " " ++ intercalate " " (map pretty ps) ++ ")"
+    pretty (PatTup ps) = "(" ++ intercalate ", " (map pretty ps) ++ ")"
+
+instance Pretty Decl where
+    pretty (Decl n t) = n ++ " :: " ++ pretty t
+
+instance Pretty Type where
+    pretty (TyTup ts) = "(" ++ intercalate ", " (map pretty ts) ++ ")"
+    pretty TyInt = "Int"
+    pretty (TyFun t u) = "(" ++ pretty t ++ " -> " ++ pretty u ++ ")"
+    pretty (TyRef n as) = "(" ++ n ++ " " ++ intercalate " " (map pretty as) ++ ")"
+    pretty (TyVar n) = n
+    pretty TyVoid = "#Void"
+
+instance Pretty Data where
+    pretty (Data n as cs) = "data " ++ n ++ " " ++ intercalate " " as ++ " = " ++ intercalate " | " (map go cs)
+      where go (m, ts) = m ++ " " ++ intercalate " " (map pretty ts)
+
+instance Pretty Class where
+    pretty (Class n as ds) = "class " ++ n ++ " " ++ intercalate " " as ++ " where { " ++ intercalate " ; " (map pretty ds) ++ "}"
+
+instance Pretty Inst where
+    pretty (Inst n t ds) = "instance " ++ n ++ " " ++ pretty t ++ " where { " ++ intercalate " ; " (map pretty ds) ++ " }"