153 lines
4.2 KiB
Haskell
153 lines
4.2 KiB
Haskell
-- {-# LANGUAGE LambdaCase #-}
|
||
-- {-# LANGUAGE OverloadedRecordDot #-}
|
||
-- {-# LANGUAGE OverloadedStrings #-}
|
||
|
||
module TypeChecker.TypeChecker where
|
||
|
||
-- import Control.Monad (void)
|
||
-- import Control.Monad.Except (ExceptT, runExceptT, throwError)
|
||
-- import Control.Monad.State (StateT)
|
||
-- import qualified Control.Monad.State as St
|
||
-- import Data.Functor.Identity (Identity, runIdentity)
|
||
-- import Data.Map (Map)
|
||
-- import qualified Data.Map as M
|
||
|
||
-- import TypeChecker.TypeCheckerIr
|
||
|
||
-- data Ctx = Ctx
|
||
-- { vars :: Map Integer Type
|
||
-- , sigs :: Map Ident Type
|
||
-- , nextFresh :: Int
|
||
-- }
|
||
-- deriving (Show)
|
||
|
||
-- -- Perhaps swap over to reader monad instead for vars and sigs.
|
||
-- type Infer = StateT Ctx (ExceptT Error Identity)
|
||
|
||
-- {-
|
||
|
||
-- The type checker will assume we first rename all variables to unique name, as to not
|
||
-- have to care about scoping. It significantly improves the quality of life of the
|
||
-- programmer.
|
||
|
||
-- TODOs:
|
||
-- Add skolemization variables. i.e
|
||
-- { \x. 3 : forall a. a -> a }
|
||
-- should not type check
|
||
|
||
-- Generalize. Not really sure what that means though
|
||
|
||
-- -}
|
||
|
||
-- typecheck :: RProgram -> Either Error TProgram
|
||
-- typecheck = todo
|
||
|
||
-- run :: Infer a -> Either Error a
|
||
-- run = runIdentity . runExceptT . flip St.evalStateT (Ctx mempty mempty 0)
|
||
|
||
-- -- Have to figure out a way to coerce polymorphic types to monomorphic ones where necessary
|
||
-- -- { \x. \y. x + y } will have the type { a -> b -> Int }
|
||
-- inferExp :: RExp -> Infer Type
|
||
-- inferExp = \case
|
||
|
||
-- RAnn expr typ -> do
|
||
-- t <- inferExp expr
|
||
-- void $ t =:= typ
|
||
-- return t
|
||
|
||
-- RBound num name -> lookupVars num
|
||
|
||
-- RFree name -> lookupSigs name
|
||
|
||
-- RConst (CInt i) -> return $ TMono "Int"
|
||
|
||
-- RConst (CStr str) -> return $ TMono "Str"
|
||
|
||
-- RAdd expr1 expr2 -> do
|
||
-- let int = TMono "Int"
|
||
-- typ1 <- check expr1 int
|
||
-- typ2 <- check expr2 int
|
||
-- return int
|
||
|
||
-- RApp expr1 expr2 -> do
|
||
-- fn_t <- inferExp expr1
|
||
-- arg_t <- inferExp expr2
|
||
-- res <- fresh
|
||
-- new_t <- fn_t =:= TArrow arg_t res
|
||
-- return res
|
||
|
||
-- RAbs num name expr -> do
|
||
-- arg <- fresh
|
||
-- insertVars num arg
|
||
-- typ <- inferExp expr
|
||
-- return $ TArrow arg typ
|
||
|
||
-- check :: RExp -> Type -> Infer ()
|
||
-- check e t = do
|
||
-- t' <- inferExp e
|
||
-- t =:= t'
|
||
-- return ()
|
||
|
||
-- fresh :: Infer Type
|
||
-- fresh = do
|
||
-- var <- St.gets nextFresh
|
||
-- St.modify (\st -> st {nextFresh = succ var})
|
||
-- return (TPoly $ Ident (show var))
|
||
|
||
-- -- | Unify two types.
|
||
-- (=:=) :: Type -> Type -> Infer Type
|
||
-- (=:=) (TPoly _) b = return b
|
||
-- (=:=) a (TPoly _) = return a
|
||
-- (=:=) (TMono a) (TMono b) | a == b = return (TMono a)
|
||
-- (=:=) (TArrow a b) (TArrow c d) = do
|
||
-- t1 <- a =:= c
|
||
-- t2 <- b =:= d
|
||
-- return $ TArrow t1 t2
|
||
-- (=:=) a b = throwError (TypeMismatch $ unwords ["Can not unify type", show a, "with", show b])
|
||
|
||
-- lookupVars :: Integer -> Infer Type
|
||
-- lookupVars i = do
|
||
-- st <- St.gets vars
|
||
-- case M.lookup i st of
|
||
-- Just t -> return t
|
||
-- Nothing -> throwError $ UnboundVar "lookupVars"
|
||
|
||
-- insertVars :: Integer -> Type -> Infer ()
|
||
-- insertVars i t = do
|
||
-- st <- St.get
|
||
-- St.put (st {vars = M.insert i t st.vars})
|
||
|
||
-- lookupSigs :: Ident -> Infer Type
|
||
-- lookupSigs i = do
|
||
-- st <- St.gets sigs
|
||
-- case M.lookup i st of
|
||
-- Just t -> return t
|
||
-- Nothing -> throwError $ UnboundVar "lookupSigs"
|
||
|
||
-- insertSigs :: Ident -> Type -> Infer ()
|
||
-- insertSigs i t = do
|
||
-- st <- St.get
|
||
-- St.put (st {sigs = M.insert i t st.sigs})
|
||
|
||
-- {-# WARNING todo "TODO IN CODE" #-}
|
||
-- todo :: a
|
||
-- todo = error "TODO in code"
|
||
|
||
-- data Error
|
||
-- = TypeMismatch String
|
||
-- | NotNumber String
|
||
-- | FunctionTypeMismatch String
|
||
-- | NotFunction String
|
||
-- | UnboundVar String
|
||
-- | AnnotatedMismatch String
|
||
-- | Default String
|
||
-- deriving (Show)
|
||
|
||
|
||
-- {-
|
||
|
||
-- The procedure inst(σ) specializes the polytype
|
||
-- σ by copying the term and replacing the bound type variables
|
||
-- consistently by new monotype variables.
|
||
|
||
-- -}
|