From f7c3b21c0a10b11730bdce64e7e895bd1eb65fd0 Mon Sep 17 00:00:00 2001
From: Tom Smeding <tom.smeding@gmail.com>
Date: Fri, 24 Jul 2020 22:25:50 +0200
Subject: Lift TypeScheme to AST.Typed

---
 typecheck/CC/Typecheck.hs | 28 +++++++++++++---------------
 1 file changed, 13 insertions(+), 15 deletions(-)

(limited to 'typecheck')

diff --git a/typecheck/CC/Typecheck.hs b/typecheck/CC/Typecheck.hs
index 195fc19..0c926f3 100644
--- a/typecheck/CC/Typecheck.hs
+++ b/typecheck/CC/Typecheck.hs
@@ -42,9 +42,7 @@ runTM :: TM a -> Either TCError a
 runTM m = evalState (runExceptT m) 1
 
 
-data Scheme = Scheme [Int] TypeT
-
-newtype Env = Env (Map Name Scheme)
+newtype Env = Env (Map Name TypeSchemeT)
 
 newtype Subst = Subst (Map Int TypeT)
 
@@ -58,8 +56,8 @@ instance FreeTypeVars TypeT where
     freeTypeVars (TTupT ts) = Set.unions (map freeTypeVars ts)
     freeTypeVars (TyVar var) = Set.singleton var
 
-instance FreeTypeVars Scheme where
-    freeTypeVars (Scheme bnds ty) = foldr Set.delete (freeTypeVars ty) bnds
+instance FreeTypeVars TypeSchemeT where
+    freeTypeVars (TypeSchemeT bnds ty) = foldr Set.delete (freeTypeVars ty) bnds
 
 instance FreeTypeVars Env where
     freeTypeVars (Env mp) = foldMap freeTypeVars (Map.elems mp)
@@ -76,9 +74,9 @@ instance Substitute TypeT where
         TTupT ts -> TTupT (map (theta >>!) ts)
         TyVar i -> fromMaybe ty (Map.lookup i mp)
 
-instance Substitute Scheme where
-    Subst mp >>! Scheme bnds ty =
-        Scheme bnds (Subst (foldr Map.delete mp bnds) >>! ty)
+instance Substitute TypeSchemeT where
+    Subst mp >>! TypeSchemeT bnds ty =
+        TypeSchemeT bnds (Subst (foldr Map.delete mp bnds) >>! ty)
 
 instance Substitute Env where
     theta >>! Env mp = Env (Map.map (theta >>!) mp)
@@ -103,21 +101,21 @@ instance Monoid Subst where
 emptyEnv :: Env
 emptyEnv = Env mempty
 
-envAdd :: Name -> Scheme -> Env -> Env
+envAdd :: Name -> TypeSchemeT -> Env -> Env
 envAdd name sty (Env mp) = Env (Map.insert name sty mp)
 
-envFind :: Name -> Env -> Maybe Scheme
+envFind :: Name -> Env -> Maybe TypeSchemeT
 envFind name (Env mp) = Map.lookup name mp
 
 substVar :: Int -> TypeT -> Subst
 substVar var ty = Subst (Map.singleton var ty)
 
-generalise :: Env -> TypeT -> Scheme
+generalise :: Env -> TypeT -> TypeSchemeT
 generalise env ty =
-    Scheme (Set.toList (freeTypeVars ty Set.\\ freeTypeVars env)) ty
+    TypeSchemeT (Set.toList (freeTypeVars ty Set.\\ freeTypeVars env)) ty
 
-instantiate :: Scheme -> TM TypeT
-instantiate (Scheme bnds ty) = do
+instantiate :: TypeSchemeT -> TM TypeT
+instantiate (TypeSchemeT bnds ty) = do
     vars <- traverse (const genTyVar) bnds
     let theta = Subst (Map.fromList (zip bnds vars))
     return (theta >>! ty)
@@ -147,7 +145,7 @@ infer env expr = case expr of
     Lam sr args@(_:_:_) body -> infer env (foldr (Lam sr . pure) body args)
     Lam _ [(arg, _)] body -> do
         argVar <- genTyVar
-        let augEnv = envAdd arg (Scheme [] argVar) env
+        let augEnv = envAdd arg (TypeSchemeT [] argVar) env
         (theta, body') <- infer augEnv body
         let argType = theta >>! argVar
         return (theta, LamT (TFunT argType (exprType body')) (Occ arg argType) body')
-- 
cgit v1.2.3-70-g09d2