64 lines
1.4 KiB
Haskell
64 lines
1.4 KiB
Haskell
module Toplevel (check) where
|
|
|
|
import Control.Monad.Except hiding (guard)
|
|
import Control.Monad.RWS hiding (guard)
|
|
|
|
import Data.Map (Map)
|
|
import qualified Data.Map as M
|
|
import qualified Data.Set as S
|
|
|
|
import TC
|
|
import TC.Helpers
|
|
import Solve
|
|
import Type
|
|
|
|
import PostProcess
|
|
|
|
import qualified Hm.Abs as H
|
|
|
|
check :: [H.Def] -> Either TypeError [TL]
|
|
check defs = case runInfer M.empty (traverseInfer defs) of
|
|
Left err -> throwError err
|
|
Right (tls,_,cs) -> case runSolve (emptySubst, cs) of
|
|
Left err -> throwError err
|
|
Right sub -> pure tls
|
|
|
|
|
|
traverseInfer :: [H.Def] -> Infer [TL]
|
|
traverseInfer defs = do
|
|
tls <- preprocess defs
|
|
|
|
env <- accumulateEnv tls
|
|
|
|
local (const env) $ do
|
|
mapM checkVar tls
|
|
|
|
checkVar :: TL -> Infer TL
|
|
checkVar t@TypeDef{} = pure t
|
|
checkVar v@(VarDef _ _ t exp) = do
|
|
t1 <- instantiate t
|
|
t2 <- infer exp
|
|
uniR t2 t1
|
|
pure v
|
|
|
|
preprocess :: [H.Def] -> Infer [TL]
|
|
preprocess = (flip runProcess) S.empty . postprocess
|
|
|
|
accumulateEnv :: [TL] -> Infer TypeEnv
|
|
accumulateEnv [] = ask
|
|
accumulateEnv (t:ts) = case t of
|
|
-- make sure none of the bindings already exist and go ahead
|
|
TypeDef p i [] env -> do
|
|
alreadyDef <- M.keysSet . M.intersection env <$> ask
|
|
mapM_ (throwError . AlreadyDefined p) alreadyDef
|
|
|
|
local (M.union env) (accumulateEnv ts)
|
|
|
|
VarDef p i t exp -> do
|
|
env <- ask
|
|
guard (throwError (AlreadyDefined p i)) (not (M.member i env))
|
|
local (M.insert i t) (accumulateEnv ts)
|
|
|
|
|
|
_ -> throwError Oop
|