Document and fix code style

This commit is contained in:
Martin Fredin 2023-02-18 13:26:41 +01:00
parent a3e57dde7b
commit ad615cc9d8

View file

@ -14,7 +14,6 @@ import Grammar.Print (Print (prt), concatD, doc, printTree,
import Prelude hiding (exp, id) import Prelude hiding (exp, id)
import qualified TypeCheckerIr as T import qualified TypeCheckerIr as T
-- NOTE: this type checker is poorly tested -- NOTE: this type checker is poorly tested
-- TODO -- TODO
@ -22,8 +21,8 @@ import qualified TypeCheckerIr as T
-- Type inference -- Type inference
data Cxt = Cxt data Cxt = Cxt
{ env :: Map Ident Type { env :: Map Ident Type -- ^ Local scope signature
, sig :: Map Ident Type , sig :: Map Ident Type -- ^ Top-level signatures
} }
initCxt :: [Bind] -> Cxt initCxt :: [Bind] -> Cxt
@ -34,30 +33,27 @@ initCxt sc = Cxt { env = mempty
typecheck :: Program -> Err T.Program typecheck :: Program -> Err T.Program
typecheck (Program sc) = T.Program <$> mapM (checkBind $ initCxt sc) sc typecheck (Program sc) = T.Program <$> mapM (checkBind $ initCxt sc) sc
-- | Check if infered rhs type matches type signature.
checkBind :: Cxt -> Bind -> Err T.Bind checkBind :: Cxt -> Bind -> Err T.Bind
checkBind cxt b = checkBind cxt b =
case expandLambdas b of case expandLambdas b of
Bind name t _ parms rhs -> do Bind name t _ parms rhs -> do
(rhs', t_rhs) <- infer cxt rhs (rhs', t_rhs) <- infer cxt rhs
unless (typeEq t_rhs t) . throwError $ typeErr name t t_rhs unless (typeEq t_rhs t) . throwError $ typeErr name t t_rhs
pure $ T.Bind (name, t) (zip parms ts_parms) rhs' pure $ T.Bind (name, t) (zip parms ts_parms) rhs'
where where
ts_parms = fst $ partitionType (length parms) t ts_parms = fst $ partitionType (length parms) t
-- | @ f x y = rhs ⇒ f = \x.\y. rhs @
expandLambdas :: Bind -> Bind expandLambdas :: Bind -> Bind
expandLambdas (Bind name t _ parms rhs) = Bind name t name [] rhs' expandLambdas (Bind name t _ parms rhs) = Bind name t name [] rhs'
where where
rhs' = foldr ($) rhs $ zipWith EAbs parms ts_parms rhs' = foldr ($) rhs $ zipWith EAbs parms ts_parms
ts_parms = fst $ partitionType (length parms) t ts_parms = fst $ partitionType (length parms) t
-- | Infer type of expression.
infer :: Cxt -> Exp -> Err (T.Exp, Type) infer :: Cxt -> Exp -> Err (T.Exp, Type)
infer cxt = \case infer cxt = \case
EId x -> EId x ->
case lookupEnv x cxt of case lookupEnv x cxt of
Nothing -> Nothing ->
@ -99,6 +95,7 @@ infer cxt = \case
throwError "Inferred type and type annotation doesn't match" throwError "Inferred type and type annotation doesn't match"
pure (e', t1) pure (e', t1)
-- | Check infered type matches the supplied type.
check :: Cxt -> Exp -> Type -> Err T.Exp check :: Cxt -> Exp -> Type -> Err T.Exp
check cxt exp typ = case exp of check cxt exp typ = case exp of
@ -108,9 +105,7 @@ check cxt exp typ = case exp of
("Unbound variable:" ++ printTree x) ("Unbound variable:" ++ printTree x)
(lookupSig x cxt) (lookupSig x cxt)
Just t -> pure t Just t -> pure t
unless (typeEq t typ) . throwError $ typeErr x typ t unless (typeEq t typ) . throwError $ typeErr x typ t
pure $ T.EId (x, t) pure $ T.EId (x, t)
EInt i -> do EInt i -> do
@ -147,14 +142,15 @@ check cxt exp typ = case exp of
throwError "Inferred type and type annotation doesn't match" throwError "Inferred type and type annotation doesn't match"
check cxt e t check cxt e t
insertBind :: Bind -> Cxt -> Cxt -- | Check if types are equivalent. Doesn't handle coercion or polymorphism.
insertBind (Bind n t _ _ _) = insertEnv n t
typeEq :: Type -> Type -> Bool typeEq :: Type -> Type -> Bool
typeEq (TFun t t1) (TFun q q1) = typeEq t q && typeEq t1 q1 typeEq (TFun t t1) (TFun q q1) = typeEq t q && typeEq t1 q1
typeEq t t1 = t == t1 typeEq t t1 = t == t1
partitionType :: Int -> Type -> ([Type], Type) -- | Partion type into types of parameters and return type.
partitionType :: Int -- Number of parameters to apply
-> Type
-> ([Type], Type)
partitionType = go [] partitionType = go []
where where
go acc 0 t = (acc, t) go acc 0 t = (acc, t)
@ -162,6 +158,9 @@ partitionType = go []
TFun t1 t2 -> go (snoc t1 acc) (i - 1) t2 TFun t1 t2 -> go (snoc t1 acc) (i - 1) t2
_ -> error "Number of parameters and type doesn't match" _ -> error "Number of parameters and type doesn't match"
insertBind :: Bind -> Cxt -> Cxt
insertBind (Bind n t _ _ _) = insertEnv n t
lookupEnv :: Ident -> Cxt -> Maybe Type lookupEnv :: Ident -> Cxt -> Maybe Type
lookupEnv x = Map.lookup x . env lookupEnv x = Map.lookup x . env