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

Add some boiler plate for warnings

Browse source
This commit is contained in:
sebastian 2023-04-02 00:42:42 +02:00
parent 6c180554ec
commit aaaff776e0
2 changed files with 9 additions and 5 deletions
Download patch file Download diff file Expand all files Collapse all files

2
src/TypeChecker/TypeChecker.hs
View file

@ -15,4 +15,4 @@ typecheck tc = rmTEVar <=< f
where where
f = case tc of f = case tc of
Bi -> Bi.typecheck Bi -> Bi.typecheck
Hm -> Hm.typecheck Hm -> fmap fst . Hm.typecheck

12
src/TypeChecker/TypeCheckerHm.hs
View file

@ -12,6 +12,7 @@ import Control.Monad.Except
import Control.Monad.Identity (Identity, runIdentity) import Control.Monad.Identity (Identity, runIdentity)
import Control.Monad.Reader import Control.Monad.Reader
import Control.Monad.State import Control.Monad.State
import Control.Monad.Writer
import Data.Coerce (coerce) import Data.Coerce (coerce)
import Data.Function (on) import Data.Function (on)
import Data.List (foldl', nub, sortOn) import Data.List (foldl', nub, sortOn)
@ -29,7 +30,7 @@ import TypeChecker.TypeCheckerIr qualified as T
-- TODO: Disallow mutual recursion -- TODO: Disallow mutual recursion
-- | Type check a program -- | Type check a program
typecheck :: Program -> Either String (T.Program' Type) typecheck :: Program -> Either String (T.Program' Type, [Warning])
typecheck = onLeft msg . run . checkPrg typecheck = onLeft msg . run . checkPrg
where where
onLeft :: (Error -> String) -> Either Error a -> Either String a onLeft :: (Error -> String) -> Either Error a -> Either String a
@ -863,13 +864,14 @@ dataErr ma d =
initCtx = Ctx mempty initCtx = Ctx mempty
initEnv = Env 0 'a' mempty mempty mempty mempty initEnv = Env 0 'a' mempty mempty mempty mempty
run :: Infer a -> Either Error a run :: Infer a -> Either Error (a, [Warning])
run = run' initEnv initCtx run = run' initEnv initCtx
run' :: Env -> Ctx -> Infer a -> Either Error a run' :: Env -> Ctx -> Infer a -> Either Error (a, [Warning])
run' e c = run' e c =
runIdentity runIdentity
. runExceptT . runExceptT
. runWriterT
. flip runReaderT c . flip runReaderT c
. flip evalStateT e . flip evalStateT e
. runInfer . runInfer
@ -891,7 +893,9 @@ data Error = Error {msg :: String, catchable :: Bool}
deriving (Show) deriving (Show)
type Subst = Map T.Ident Type type Subst = Map T.Ident Type
newtype Infer a = Infer {runInfer :: StateT Env (ReaderT Ctx (ExceptT Error Identity)) a} newtype Warning = NonExhaustive String
newtype Infer a = Infer {runInfer :: StateT Env (ReaderT Ctx (WriterT [Warning] (ExceptT Error Identity))) a}
deriving (Functor, Applicative, Monad, MonadReader Ctx, MonadError Error, MonadState Env) deriving (Functor, Applicative, Monad, MonadReader Ctx, MonadError Error, MonadState Env)
catchableErr :: MonadError Error m => String -> m a catchableErr :: MonadError Error m => String -> m a