11 changed files with 287 additions and 160 deletions
@ -1,22 +1,28 @@
|
||||
-- simple test |
||||
(data Bool ([Bool] True) |
||||
([Bool] False)) |
||||
(data 𝔹 ([𝔹] 𝕋) |
||||
([𝔹] 𝔽)) |
||||
|
||||
[Bool -> Bool] |
||||
(def (((not True) False) |
||||
((not False) True))) |
||||
[𝔹 → 𝔹] |
||||
(def (((not 𝕋) 𝔽) |
||||
((not 𝔽) 𝕋))) |
||||
|
||||
|
||||
[Integer -> Bool] |
||||
(def (((is1 1) True) |
||||
((is1 _) False))) |
||||
[ℤ → 𝔹] |
||||
(def (((is1 1) 𝕋) |
||||
((is1 _) 𝔽))) |
||||
|
||||
(data IntList ([IntList] IEmpty) |
||||
([Integer -> IntList -> IntList] ICons)) |
||||
(data ℤList ([ℤList] IEmpty) |
||||
([ℤ → ℤList → ℤList] ICons)) |
||||
|
||||
(data BoolList ([BoolList] BEmpty) |
||||
([Bool -> BoolList -> BoolList] BCons)) |
||||
(data 𝔹List ([𝔹List] BEmpty) |
||||
([𝔹 → 𝔹List → 𝔹List] BCons)) |
||||
|
||||
[IntList -> BoolList] |
||||
[ℤList → 𝔹List] |
||||
(def (((is1l IEmpty) BEmpty) |
||||
((is1l (ICons x xs)) (BCons (is1 x) (is1l xs))))) |
||||
|
||||
[ℤList → 𝔹List] |
||||
(def is1l2 is1l) |
||||
|
||||
[𝔹 → ℤList → 𝔹List] |
||||
(def is1l3 (lambda [𝔹] x is1l)) |
||||
|
@ -0,0 +1,94 @@
|
||||
{-| |
||||
Module: Simple.TC.TypeOps |
||||
Description: Defines operations used on typechecker types |
||||
|
||||
This module defines a lot of useful operation over our typechecker monad |
||||
-} |
||||
module Simple.TC.TypeOps where |
||||
|
||||
import Control.Monad.State hiding (guard) |
||||
import Control.Monad.Except hiding (guard) |
||||
import Data.Set (Set) |
||||
import qualified Data.Map as M |
||||
import qualified Data.Set as S |
||||
|
||||
import Lens.Micro |
||||
|
||||
import Simple.TC.Types |
||||
import Simple.AST |
||||
import Types |
||||
import Misc |
||||
|
||||
-- | Change state only for some computation |
||||
local :: (CheckEnv -> CheckEnv) -> Check a -> Check a |
||||
local f ca = get >>= \s -> put (f s) >> ca >>= \r -> put s >> pure r |
||||
|
||||
-- | Change the state somehow |
||||
modState :: (CheckEnv -> CheckEnv) -> Check () |
||||
modState f = get >>= put . f |
||||
|
||||
-- | Get the value level enviornment |
||||
getEnv :: Check (Env Type) |
||||
getEnv = (^. defs) <$> get |
||||
|
||||
-- | Change value environment only for some computation. |
||||
localEnv :: (Env Type -> Env Type) -> Check a -> Check a |
||||
localEnv f = local (\env -> env & defs %~ f) |
||||
|
||||
-- | Modify the value environment |
||||
modifyEnv :: (Env Type -> Env Type) -> Check () |
||||
modifyEnv f = modState (\env -> env & defs %~ f) |
||||
|
||||
-- | Modify the type environment |
||||
modifyTypeEnv :: (Set Identifier -> Set Identifier) -> Check () |
||||
modifyTypeEnv f = modState (\env -> env & types %~ f) |
||||
|
||||
-- | Modify the record environment |
||||
modifyRecEnv :: (Env (Env Type) -> Env (Env Type)) -> Check () |
||||
modifyRecEnv f = modState (\env -> env & rec %~ f) |
||||
|
||||
-- | Return the type environment |
||||
getTypeEnv :: Check (Set Identifier) |
||||
getTypeEnv = (^. types) <$> get |
||||
|
||||
-- | Return the record environment |
||||
getRecEnv :: Check (Env (Env Type)) |
||||
getRecEnv = (^. rec) <$> get |
||||
|
||||
-- | Change type environment only for some computation. |
||||
localTypeEnv :: (Set Identifier -> Set Identifier) -> Check a -> Check a |
||||
localTypeEnv f = local (\env -> env & types %~ f) |
||||
|
||||
-- | Used to bind local variables. |
||||
withBindings :: [(Type, Identifier)] -> Check a -> Check a |
||||
withBindings = localEnv . (flip insertMapBindings) |
||||
|
||||
-- | Used to permanently bind variables. |
||||
insertBindings :: [(Type, Identifier)] -> Check () |
||||
insertBindings = modifyEnv . (flip insertMapBindings) |
||||
|
||||
-- | Bind some variables and make sure the names were not taken |
||||
insertUniqueBindings :: PN -> [(Type, Identifier)] -> Check () |
||||
insertUniqueBindings p ais = getEnv >>= \env -> foldM go env ais >>= modifyEnv . const |
||||
where |
||||
go :: Env Type -> (Type, Identifier) -> Check (Env Type) |
||||
go e (a, i) | M.member i e = throwError (AlreadyBound p i) |
||||
| otherwise = pure (M.insert i a e) |
||||
|
||||
-- | Bind some type names and make sure the names were not taken |
||||
insertUniqueTypes :: PN -> [Identifier] -> Check () |
||||
insertUniqueTypes p is = getTypeEnv >>= \env -> foldM go env is >>= modifyTypeEnv . const |
||||
where |
||||
go :: Set Identifier -> Identifier -> Check (Set Identifier) |
||||
go s i | S.member i s = throwError (TypeAlreadyBound p i) |
||||
| otherwise = pure (S.insert i s) |
||||
|
||||
-- | Insert some stuff into an environment |
||||
insertMapBindings :: Env a -> [(a, Identifier)] -> Env a |
||||
insertMapBindings = foldr (uncurry (flip M.insert)) |
||||
|
||||
-- | Insert record constructors into the environment |
||||
insertRecCons :: PN -> Identifier -> [(Type, Identifier)] -> Check () |
||||
insertRecCons p i tis = getRecEnv >>= \renv -> if M.member i renv |
||||
then throwError (TypeAlreadyBound p i) |
||||
else (modifyRecEnv . M.insert i . M.fromList . map swap) tis |
@ -0,0 +1,71 @@
|
||||
{-| |
||||
Module: Simple.TC.Types |
||||
Description: Types for the simple typechecker. |
||||
|
||||
Types for the simple typechecker. |
||||
-} |
||||
{-# LANGUAGE GeneralizedNewtypeDeriving, TemplateHaskell, LambdaCase #-} |
||||
module Simple.TC.Types where |
||||
|
||||
import Simple.AST |
||||
import Types |
||||
import Error |
||||
|
||||
import Control.Monad.State |
||||
import Control.Monad.Except |
||||
|
||||
import Data.Map (Map) |
||||
import Data.Set (Set) |
||||
import qualified Data.Map as M |
||||
import qualified Data.Set as S |
||||
|
||||
import Lens.Micro.TH |
||||
|
||||
-- | The different kinds of errors which can occur during checking |
||||
data TypeError |
||||
= Urk |
||||
| TypeMismatch PN Type Type -- ^ expected, got |
||||
| ArityMismatch PN |
||||
| UnboundVar PN Identifier |
||||
| AlreadyBound PN Identifier |
||||
| TypeAlreadyBound PN Identifier |
||||
| NoCase PN |
||||
| UnknownPattern PN |
||||
| UndefinedType PN Identifier |
||||
| InvalidRecordField PN Identifier |
||||
| IncompleteInstance PN |
||||
deriving (Show) |
||||
|
||||
-- | Generates a fancy error string from a TypeError |
||||
errorStr :: FilePath -> String -> TypeError -> String |
||||
errorStr fp tx = \case |
||||
Urk -> "urk" |
||||
TypeMismatch p e g -> errorMessage p fp tx ("Type mismatch, expected '" <> pretty e <> "' got '" <> pretty g <> "'") |
||||
ArityMismatch p -> errorMessage p fp tx "Arity mismatch" |
||||
UnboundVar p i -> errorMessage p fp tx ("Unbound variable '" <> unId i <> "'") |
||||
AlreadyBound p i -> errorMessage p fp tx ("Identifier '" <> unId i <> "' already bound") |
||||
TypeAlreadyBound p i -> errorMessage p fp tx ("A type of name'" <> unId i <> "' already exists") |
||||
NoCase p -> errorMessage p fp tx "No case" |
||||
UnknownPattern p -> errorMessage p fp tx "Unknown pattern" |
||||
UndefinedType p i -> errorMessage p fp tx ("Undefined type '" <> unId i <> "'") |
||||
InvalidRecordField p i -> errorMessage p fp tx ("Invalid record field '" <> unId i <> "'") |
||||
IncompleteInstance p -> errorMessage p fp tx "Incomplete instance" |
||||
|
||||
-- | An enviornment simply maps an identifier to something |
||||
type Env a = Map Identifier a |
||||
|
||||
-- | The complete enviornment of the checker |
||||
data CheckEnv = CheckEnv { _defs :: Env Type |
||||
, _types :: Set Identifier |
||||
, _rec :: Env (Env Type) |
||||
} deriving Show |
||||
|
||||
makeLenses ''CheckEnv |
||||
|
||||
-- | The initial enviornment of the checker |
||||
initialState :: CheckEnv |
||||
initialState = CheckEnv M.empty S.empty M.empty |
||||
|
||||
-- | The monad which checking is performed in |
||||
newtype Check a = Check { runCheck :: StateT CheckEnv (ExceptT TypeError IO) a } |
||||
deriving (Functor, Applicative, Monad, MonadError TypeError, MonadState CheckEnv) |
Loading…
Reference in new issue