From e83d85eb08a370f3943294f21a4c27cd3b12ad09 Mon Sep 17 00:00:00 2001
From: Tom Smeding <tom.smeding@gmail.com>
Date: Wed, 24 Apr 2019 21:57:27 +0200
Subject: Start working on a type checker

---
 src/Haskell/AST.hs | 60 ++++++++++++++++++++++++++++++++++++++----------------
 1 file changed, 42 insertions(+), 18 deletions(-)

(limited to 'src/Haskell/AST.hs')

diff --git a/src/Haskell/AST.hs b/src/Haskell/AST.hs
index f8b5c72..54d19d3 100644
--- a/src/Haskell/AST.hs
+++ b/src/Haskell/AST.hs
@@ -20,12 +20,12 @@ data Toplevel = TopDef Def
 data Def = Def Name Expr
   deriving (Show, Eq)
 
-data Expr = App Expr [Expr]
-          | Ref Name
-          | Num Integer
-          | Tup [Expr]
-          | Lam [Name] Expr
-          | Case Expr [(Pat, Expr)]
+data Expr = App Expr [Expr] (Maybe Type)
+          | Ref Name (Maybe Type)
+          | Num Integer (Maybe Type)
+          | Tup [Expr] (Maybe Type)
+          | Lam [Name] Expr (Maybe Type)
+          | Case Expr [(Pat, Expr)] (Maybe Type)
   deriving (Show, Eq)
 
 data Pat = PatAny
@@ -69,12 +69,12 @@ instance Pretty Def where
     pretty (Def n e) = Node (n ++ " =") [pretty e]
 
 instance Pretty Expr where
-    pretty (App e as) = Bracket "(" ")" "" (map pretty (e:as))
-    pretty (Ref n) = Leaf n
-    pretty (Num n) = Leaf (show n)
-    pretty (Tup es) = Bracket "(" ")" "," (map pretty es)
-    pretty (Lam as e) = Bracket "(" ")" "" [Node ("\\" ++ intercalate " " as ++ " ->") [pretty e]]
-    pretty (Case e arms) = Bracket "(" ")" "" [Node ("case " ++ pprintOneline e ++ " of") [Bracket "{" "}" ";" (map go arms)]]
+    pretty (App e as _) = Bracket "(" ")" "" (map pretty (e:as))
+    pretty (Ref n _) = Leaf n
+    pretty (Num n _) = Leaf (show n)
+    pretty (Tup es _) = Bracket "(" ")" "," (map pretty es)
+    pretty (Lam as e _) = Bracket "(" ")" "" [Node ("\\" ++ intercalate " " as ++ " ->") [pretty e]]
+    pretty (Case e arms _) = Bracket "(" ")" "" [Node ("case " ++ pprintOneline e ++ " of") [Bracket "{" "}" ";" (map go arms)]]
       where go (p, e') = Node (pprintOneline p ++ " ->") [pretty e']
 
 instance Pretty Pat where
@@ -122,12 +122,36 @@ instance AllRefs Def where
     allRefs (Def _ e) = allRefs e
 
 instance AllRefs Expr where
-    allRefs (App e es) = nub $ concatMap allRefs (e : es)
-    allRefs (Ref n) = [n]
-    allRefs (Num _) = []
-    allRefs (Tup es) = nub $ concatMap allRefs es
-    allRefs (Lam ns e) = allRefs e \\ ns
-    allRefs (Case e pairs) = nub $ allRefs e ++ concatMap (allRefs . snd) pairs
+    allRefs (App e es _) = nub $ concatMap allRefs (e : es)
+    allRefs (Ref n _) = [n]
+    allRefs (Num _ _) = []
+    allRefs (Tup es _) = nub $ concatMap allRefs es
+    allRefs (Lam ns e _) = allRefs e \\ ns
+    allRefs (Case e pairs _) = nub $ allRefs e ++ concatMap (allRefs . snd) pairs
 
 instance AllRefs Inst where
     allRefs (Inst _ _ ds) = nub $ concatMap allRefs ds
+
+
+typeOf :: Expr -> Type
+typeOf (App _ _ (Just ty)) = ty
+typeOf (Ref _ (Just ty)) = ty
+typeOf (Num _ (Just ty)) = ty
+typeOf (Tup _ (Just ty)) = ty
+typeOf (Lam _ _ (Just ty)) = ty
+typeOf (Case _ _ (Just ty)) = ty
+typeOf e = error $ "Unresolved type in typeOf in expression: " ++ show e
+
+typeApply :: Type -> Type -> Maybe Type
+typeApply (TyFun t1 t2) t3
+    | t1 == t3  = Just t2
+    | otherwise = Nothing
+typeApply _ _ = Nothing
+
+recurse :: (Pat -> Pat) -> (Expr -> Expr) -> Expr -> Expr
+recurse _  f (App e as ty) = App (f e) (map f as) ty
+recurse _  _ (Ref n ty) = Ref n ty
+recurse _  _ (Num k ty) = Num k ty
+recurse _  f (Tup es ty) = Tup (map f es) ty
+recurse _  f (Lam ns e ty) = Lam ns (f e) ty
+recurse fp f (Case e as ty) = Case (f e) (map (\(p, e') -> (fp p, f e')) as) ty
-- 
cgit v1.2.3-70-g09d2