Rakarake/churf
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

typechecker is compatible with one extra addition to the spec

Browse source
This commit is contained in:
sebastianselander 2023-03-23 11:13:48 +01:00
parent 3335ab7a57
commit 8d1330ad42
7 changed files with 63 additions and 66 deletions
Download patch file Download diff file Expand all files Collapse all files

17
src/Renamer/Renamer.hs
View file

@ -16,12 +16,12 @@ import Control.Monad.State (
gets,
modify,
)
import Data.Coerce (coerce)
import Data.Function (on)
import Data.Map (Map)
import Data.Map qualified as Map
import Data.Maybe (fromMaybe)
import Data.Tuple.Extra (dupe)
import Data.Coerce (coerce)
import Grammar.Abs
-- | Rename all variables and local binds
@ -91,11 +91,12 @@ newtype Rn a = Rn {runRn :: StateT Cxt (ExceptT String Identity) a}
deriving (Functor, Applicative, Monad, MonadState Cxt)
-- | Maps old to new name
type Names = Map Ident Ident
type Names = Map LIdent LIdent
renameExp :: Names -> Exp -> Rn (Names, Exp)
renameExp old_names = \case
EId n -> pure (coerce old_names, EId . fromMaybe n $ Map.lookup n (coerce old_names))
EVar n -> pure (coerce old_names, EVar . fromMaybe n $ Map.lookup n old_names)
ECons n -> pure (old_names, ECons n)
ELit lit -> pure (old_names, ELit lit)
EApp e1 e2 -> do
(env1, e1') <- renameExp old_names e1
@ -170,20 +171,20 @@ substitute tvar1 tvar2 typ = case typ of
substitute' = substitute tvar1 tvar2
-- | Create a new name and add it to name environment.
newName :: Names -> Ident -> Rn (Names, Ident)
newName :: Names -> LIdent -> Rn (Names, LIdent)
newName env old_name = do
new_name <- makeName old_name
pure (Map.insert old_name new_name env, new_name)
-- | Create multiple names and add them to the name environment
newNames :: Names -> [Ident] -> Rn (Names, [Ident])
newNames :: Names -> [LIdent] -> Rn (Names, [LIdent])
newNames = mapAccumM newName
-- | Annotate name with number and increment the number @prefix ⇒ prefix_number@.
makeName :: Ident -> Rn Ident
makeName (Ident prefix) = do
makeName :: LIdent -> Rn LIdent
makeName (LIdent prefix) = do
i <- gets var_counter
let name = Ident $ prefix ++ "_" ++ show i
let name = LIdent $ prefix ++ "_" ++ show i
modify $ \cxt -> cxt{var_counter = succ cxt.var_counter}
pure name

42
src/TypeChecker/TypeChecker.hs
View file

@ -134,6 +134,7 @@ isMoreSpecificOrEq a b = a == b
isPoly :: Type -> Bool
isPoly (TAll _ _) = True
isPoly (TVar _) = True
isPoly _ = False
inferExp :: Exp -> Infer T.ExpT
@ -193,21 +194,20 @@ algoW = \case
-- \| ----------------------
-- \| Γ ⊢ x : τ, ∅
EId i -> do
EVar i -> do
var <- asks vars
case M.lookup i var of
Just t -> inst t >>= \(x) -> return (nullSubst, (T.EId (i, x), x))
case M.lookup (coerce i) var of
Just t -> inst t >>= \x -> return (nullSubst, (T.EId (coerce i, x), x))
Nothing -> do
sig <- gets sigs
case M.lookup i sig of
Just t -> return (nullSubst, (T.EId (i, t), t))
Nothing -> do
constr <- gets constructors
case M.lookup i constr of
Just t -> return (nullSubst, (T.EId (i, t), t))
Nothing ->
throwError $
"Unbound variable: " ++ show i
case M.lookup (coerce i) sig of
Just t -> return (nullSubst, (T.EId (coerce i, t), t))
Nothing -> throwError $ "Unbound variable: " ++ show i
ECons i -> do
constr <- gets constructors
case M.lookup (coerce i) constr of
Just t -> return (nullSubst, (T.EId (coerce i, t), t))
Nothing -> throwError $ "Constructor: '" ++ printTree i ++ "' is not defined"
-- \| τ = newvar Γ, x : τ ⊢ e : τ', S
-- \| ---------------------------------
@ -219,7 +219,7 @@ algoW = \case
(s1, (e', t')) <- algoW e
let varType = apply s1 fr
let newArr = T.TFun varType t'
return (s1, apply s1 $ (T.EAbs (coerce name, varType) (e', newArr), newArr))
return (s1, apply s1 (T.EAbs (coerce name, varType) (e', newArr), newArr))
-- \| Γ ⊢ e₀ : τ₀, S₀ S₀Γ ⊢ e₁ : τ₁, S₁
-- \| s₂ = mgu(s₁τ₀, Int) s₃ = mgu(s₂τ₁, Int)
@ -237,7 +237,7 @@ algoW = \case
let comp = s4 `compose` s3 `compose` s2 `compose` s1
return
( comp
, apply comp $ (T.EAdd (e0', t0) (e1', t1), int)
, apply comp (T.EAdd (e0', t0) (e1', t1), int)
)
-- \| Γ ⊢ e₀ : τ₀, S₀ S₀Γ ⊢ e₁ : τ₁, S1
@ -384,7 +384,7 @@ class FreeVars t where
instance FreeVars T.Type where
free :: T.Type -> Set Ident
free (T.TVar (T.MkTVar a)) = S.singleton a
free (T.TAll (T.MkTVar bound) t) = (S.singleton bound) `S.intersection` free t
free (T.TAll (T.MkTVar bound) t) = S.singleton bound `S.intersection` free t
free (T.TLit _) = mempty
free (T.TFun a b) = free a `S.union` free b
-- \| Not guaranteed to be correct
@ -398,7 +398,9 @@ instance FreeVars T.Type where
T.TVar (T.MkTVar a) -> case M.lookup a sub of
Nothing -> T.TVar (T.MkTVar $ coerce a)
Just t -> t
T.TAll bound t -> undefined
T.TAll (T.MkTVar i) t -> case M.lookup i sub of
Nothing -> T.TAll (T.MkTVar i) (apply sub t)
Just _ -> apply sub t
T.TFun a b -> T.TFun (apply sub a) (apply sub b)
T.TIndexed (T.Indexed name a) -> T.TIndexed (T.Indexed name (map (apply sub) a))
@ -416,10 +418,10 @@ instance FreeVars T.ExpT where
(T.EId (i, innerT), outerT) -> (T.EId (i, apply s innerT), apply s outerT)
(T.ELit lit, t) -> (T.ELit lit, apply s t)
(T.ELet (T.Bind (ident, t1) args e1) e2, t2) -> (T.ELet (T.Bind (ident, apply s t1) args (apply s e1)) (apply s e2), apply s t2)
(T.EApp e1 e2, t) -> (T.EApp (apply s e1) (apply s e2), (apply s t))
(T.EAdd e1 e2, t) -> (T.EAdd (apply s e1) (apply s e2), (apply s t))
(T.EAbs (ident, t2) e, t1) -> (T.EAbs (ident, apply s t2) (apply s e), (apply s t1))
(T.ECase e injs, t) -> (T.ECase (apply s e) (apply s injs), (apply s t))
(T.EApp e1 e2, t) -> (T.EApp (apply s e1) (apply s e2), apply s t)
(T.EAdd e1 e2, t) -> (T.EAdd (apply s e1) (apply s e2), apply s t)
(T.EAbs (ident, t2) e, t1) -> (T.EAbs (ident, apply s t2) (apply s e), apply s t1)
(T.ECase e injs, t) -> (T.ECase (apply s e) (apply s injs), apply s t)
instance FreeVars T.Inj where
free :: T.Inj -> Set Ident