aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ast/CC/AST/Source.hs5
-rw-r--r--ast/CC/AST/Typed.hs70
-rw-r--r--ast/CC/Context.hs2
-rw-r--r--backend/CC/Backend/Dumb.hs12
-rw-r--r--typecheck/CC/Typecheck.hs159
5 files changed, 127 insertions, 121 deletions
diff --git a/ast/CC/AST/Source.hs b/ast/CC/AST/Source.hs
index 3d7d5ea..11b7bc6 100644
--- a/ast/CC/AST/Source.hs
+++ b/ast/CC/AST/Source.hs
@@ -1,4 +1,7 @@
-module CC.AST.Source(module CC.AST.Source, module CC.Types) where
+module CC.AST.Source(
+ module CC.AST.Source,
+ module CC.Types
+) where
import Data.List
diff --git a/ast/CC/AST/Typed.hs b/ast/CC/AST/Typed.hs
index 537c7a4..26f7b5c 100644
--- a/ast/CC/AST/Typed.hs
+++ b/ast/CC/AST/Typed.hs
@@ -9,68 +9,68 @@ import CC.Pretty
import CC.Types
-data ProgramT = ProgramT [DefT]
+data Program = Program [Def]
deriving (Show, Read)
-data DefT = DefT Name ExprT
+data Def = Def Name Expr
deriving (Show, Read)
-data TypeT = TFunT TypeT TypeT
- | TIntT
- | TTupT [TypeT]
- | TyVar Int
+data Type = TFun Type Type
+ | TInt
+ | TTup [Type]
+ | TyVar Int
deriving (Show, Read)
-data TypeSchemeT = TypeSchemeT [Int] TypeT
+data TypeScheme = TypeScheme [Int] Type
deriving (Show, Read)
-data ExprT = LamT TypeT Occ ExprT
- | CallT TypeT ExprT ExprT
- | IntT Int
- | TupT [ExprT]
- | VarT Occ
+data Expr = Lam Type Occ Expr
+ | Call Type Expr Expr
+ | Int Int
+ | Tup [Expr]
+ | Var Occ
deriving (Show, Read)
-data Occ = Occ Name TypeT
+data Occ = Occ Name Type
deriving (Show, Read)
-exprType :: ExprT -> TypeT
-exprType (LamT typ _ _) = typ
-exprType (CallT typ _ _) = typ
-exprType (IntT _) = TIntT
-exprType (TupT es) = TTupT (map exprType es)
-exprType (VarT (Occ _ typ)) = typ
+exprType :: Expr -> Type
+exprType (Lam typ _ _) = typ
+exprType (Call typ _ _) = typ
+exprType (Int _) = TInt
+exprType (Tup es) = TTup (map exprType es)
+exprType (Var (Occ _ typ)) = typ
-instance Pretty TypeT where
- prettyPrec _ TIntT = "Int"
- prettyPrec p (TFunT a b) =
+instance Pretty Type where
+ prettyPrec _ TInt = "Int"
+ prettyPrec p (TFun a b) =
precParens p 2 (prettyPrec 3 a ++ " -> " ++ prettyPrec 2 b)
- prettyPrec _ (TTupT ts) =
+ prettyPrec _ (TTup ts) =
"(" ++ intercalate ", " (map pretty ts) ++ ")"
prettyPrec _ (TyVar i) = 't' : show i
-instance Pretty TypeSchemeT where
- prettyPrec p (TypeSchemeT bnds ty) =
+instance Pretty TypeScheme where
+ prettyPrec p (TypeScheme bnds ty) =
precParens p 2
("forall " ++ intercalate " " (map (pretty . TyVar) bnds) ++ ". " ++
prettyPrec 2 ty)
-instance Pretty ExprT where
- prettyPrec p (LamT ty (Occ n t) e) =
+instance Pretty Expr where
+ prettyPrec p (Lam ty (Occ n t) e) =
precParens p 2 $
"(\\(" ++ n ++ " :: " ++ pretty t ++ ") -> "
++ prettyPrec 2 e ++ ") :: " ++ pretty ty
- prettyPrec p (CallT ty e1 e2) =
+ prettyPrec p (Call ty e1 e2) =
precParens p 2 $
prettyPrec 3 e1 ++ " " ++ prettyPrec 3 e2 ++ " :: " ++ pretty ty
- prettyPrec _ (IntT i) = show i
- prettyPrec _ (TupT es) = "(" ++ intercalate ", " (map pretty es) ++ ")"
- prettyPrec p (VarT (Occ n t)) =
+ prettyPrec _ (Int i) = show i
+ prettyPrec _ (Tup es) = "(" ++ intercalate ", " (map pretty es) ++ ")"
+ prettyPrec p (Var (Occ n t)) =
precParens p 2 $
show n ++ " :: " ++ pretty t
-instance Pretty DefT where
- pretty (DefT n e) = n ++ " = " ++ pretty e
+instance Pretty Def where
+ pretty (Def n e) = n ++ " = " ++ pretty e
-instance Pretty ProgramT where
- pretty (ProgramT defs) = concatMap ((++ "\n") . pretty) defs
+instance Pretty Program where
+ pretty (Program defs) = concatMap ((++ "\n") . pretty) defs
diff --git a/ast/CC/Context.hs b/ast/CC/Context.hs
index 0a54392..b86685d 100644
--- a/ast/CC/Context.hs
+++ b/ast/CC/Context.hs
@@ -7,4 +7,4 @@ import CC.AST.Typed
data Context = Context FilePath Builtins
-- | Information about builtins supported by the enabled backend
-data Builtins = Builtins [(Name, TypeT)]
+data Builtins = Builtins [(Name, Type)]
diff --git a/backend/CC/Backend/Dumb.hs b/backend/CC/Backend/Dumb.hs
index 070fece..7982a06 100644
--- a/backend/CC/Backend/Dumb.hs
+++ b/backend/CC/Backend/Dumb.hs
@@ -6,9 +6,9 @@ import CC.Context
builtins :: Builtins
builtins = Builtins
- [ ("print", TFunT TIntT (TTupT []))
- , ("fst", TFunT (TTupT [TyVar 1, TyVar 2]) (TyVar 1))
- , ("snd", TFunT (TTupT [TyVar 1, TyVar 2]) (TyVar 2))
- , ("_add", TFunT TIntT (TFunT TIntT TIntT))
- , ("_sub", TFunT TIntT (TFunT TIntT TIntT))
- , ("_mul", TFunT TIntT (TFunT TIntT TIntT)) ]
+ [ ("print", TFun TInt (TTup []))
+ , ("fst", TFun (TTup [TyVar 1, TyVar 2]) (TyVar 1))
+ , ("snd", TFun (TTup [TyVar 1, TyVar 2]) (TyVar 2))
+ , ("_add", TFun TInt (TFun TInt TInt))
+ , ("_sub", TFun TInt (TFun TInt TInt))
+ , ("_mul", TFun TInt (TFun TInt TInt)) ]
diff --git a/typecheck/CC/Typecheck.hs b/typecheck/CC/Typecheck.hs
index bf1d17c..8678771 100644
--- a/typecheck/CC/Typecheck.hs
+++ b/typecheck/CC/Typecheck.hs
@@ -10,16 +10,17 @@ import Data.Maybe
import qualified Data.Set as Set
import Data.Set (Set)
-import CC.AST.Source
-import CC.AST.Typed
+import qualified CC.AST.Source as S
+import qualified CC.AST.Typed as T
import CC.Context
import CC.Pretty
+import CC.Types
-- Inspiration: https://github.com/kritzcreek/fby19
-data TCError = TypeError SourceRange TypeT TypeT
+data TCError = TypeError SourceRange T.Type T.Type
| RefError SourceRange Name
deriving (Show)
@@ -36,29 +37,29 @@ type TM a = ExceptT TCError (State Int) a
genId :: TM Int
genId = state (\idval -> (idval, idval + 1))
-genTyVar :: TM TypeT
-genTyVar = TyVar <$> genId
+genTyVar :: TM T.Type
+genTyVar = T.TyVar <$> genId
runTM :: TM a -> Either TCError a
runTM m = evalState (runExceptT m) 1
-newtype Env = Env (Map Name TypeSchemeT)
+newtype Env = Env (Map Name T.TypeScheme)
-newtype Subst = Subst (Map Int TypeT)
+newtype Subst = Subst (Map Int T.Type)
class FreeTypeVars a where
freeTypeVars :: a -> Set Int
-instance FreeTypeVars TypeT where
- freeTypeVars (TFunT t1 t2) = freeTypeVars t1 <> freeTypeVars t2
- freeTypeVars TIntT = mempty
- freeTypeVars (TTupT ts) = Set.unions (map freeTypeVars ts)
- freeTypeVars (TyVar var) = Set.singleton var
+instance FreeTypeVars T.Type where
+ freeTypeVars (T.TFun t1 t2) = freeTypeVars t1 <> freeTypeVars t2
+ freeTypeVars T.TInt = mempty
+ freeTypeVars (T.TTup ts) = Set.unions (map freeTypeVars ts)
+ freeTypeVars (T.TyVar var) = Set.singleton var
-instance FreeTypeVars TypeSchemeT where
- freeTypeVars (TypeSchemeT bnds ty) = foldr Set.delete (freeTypeVars ty) bnds
+instance FreeTypeVars T.TypeScheme where
+ freeTypeVars (T.TypeScheme bnds ty) = foldr Set.delete (freeTypeVars ty) bnds
instance FreeTypeVars Env where
freeTypeVars (Env mp) = foldMap freeTypeVars (Map.elems mp)
@@ -68,29 +69,29 @@ infixr >>!
class Substitute a where
(>>!) :: Subst -> a -> a
-instance Substitute TypeT where
+instance Substitute T.Type where
theta@(Subst mp) >>! ty = case ty of
- TFunT t1 t2 -> TFunT (theta >>! t1) (theta >>! t2)
- TIntT -> TIntT
- TTupT ts -> TTupT (map (theta >>!) ts)
- TyVar i -> fromMaybe ty (Map.lookup i mp)
+ T.TFun t1 t2 -> T.TFun (theta >>! t1) (theta >>! t2)
+ T.TInt -> T.TInt
+ T.TTup ts -> T.TTup (map (theta >>!) ts)
+ T.TyVar i -> fromMaybe ty (Map.lookup i mp)
-instance Substitute TypeSchemeT where
- Subst mp >>! TypeSchemeT bnds ty =
- TypeSchemeT bnds (Subst (foldr Map.delete mp bnds) >>! ty)
+instance Substitute T.TypeScheme where
+ Subst mp >>! T.TypeScheme bnds ty =
+ T.TypeScheme bnds (Subst (foldr Map.delete mp bnds) >>! ty)
instance Substitute Env where
theta >>! Env mp = Env (Map.map (theta >>!) mp)
-- TODO: make this instance unnecessary
-instance Substitute ExprT where
- theta >>! LamT ty (Occ name ty2) body =
- LamT (theta >>! ty) (Occ name (theta >>! ty2)) (theta >>! body)
- theta >>! CallT ty e1 e2 =
- CallT (theta >>! ty) (theta >>! e1) (theta >>! e2)
- _ >>! expr@(IntT _) = expr
- theta >>! TupT es = TupT (map (theta >>!) es)
- theta >>! VarT (Occ name ty) = VarT (Occ name (theta >>! ty))
+instance Substitute T.Expr where
+ theta >>! T.Lam ty (T.Occ name ty2) body =
+ T.Lam (theta >>! ty) (T.Occ name (theta >>! ty2)) (theta >>! body)
+ theta >>! T.Call ty e1 e2 =
+ T.Call (theta >>! ty) (theta >>! e1) (theta >>! e2)
+ _ >>! expr@(T.Int _) = expr
+ theta >>! T.Tup es = T.Tup (map (theta >>!) es)
+ theta >>! T.Var (T.Occ name ty) = T.Var (T.Occ name (theta >>! ty))
instance Semigroup Subst where
@@ -102,77 +103,79 @@ instance Monoid Subst where
emptyEnv :: Env
emptyEnv = Env mempty
-envAdd :: Name -> TypeSchemeT -> Env -> Env
+envAdd :: Name -> T.TypeScheme -> Env -> Env
envAdd name sty (Env mp) = Env (Map.insert name sty mp)
-envFind :: Name -> Env -> Maybe TypeSchemeT
+envFind :: Name -> Env -> Maybe T.TypeScheme
envFind name (Env mp) = Map.lookup name mp
-substVar :: Int -> TypeT -> Subst
+substVar :: Int -> T.Type -> Subst
substVar var ty = Subst (Map.singleton var ty)
-generalise :: Env -> TypeT -> TypeSchemeT
+generalise :: Env -> T.Type -> T.TypeScheme
generalise env ty =
- TypeSchemeT (Set.toList (freeTypeVars ty Set.\\ freeTypeVars env)) ty
+ T.TypeScheme (Set.toList (freeTypeVars ty Set.\\ freeTypeVars env)) ty
-instantiate :: TypeSchemeT -> TM TypeT
-instantiate (TypeSchemeT bnds ty) = do
+instantiate :: T.TypeScheme -> TM T.Type
+instantiate (T.TypeScheme bnds ty) = do
vars <- traverse (const genTyVar) bnds
let theta = Subst (Map.fromList (zip bnds vars))
return (theta >>! ty)
-data UnifyContext = UnifyContext SourceRange TypeT TypeT
+data UnifyContext = UnifyContext SourceRange T.Type T.Type
-unify :: SourceRange -> TypeT -> TypeT -> TM Subst
+unify :: SourceRange -> T.Type -> T.Type -> TM Subst
unify sr t1 t2 = unify' (UnifyContext sr t1 t2) t1 t2
-unify' :: UnifyContext -> TypeT -> TypeT -> TM Subst
-unify' _ TIntT TIntT = return mempty
-unify' ctx (TFunT t1 t2) (TFunT u1 u2) = (<>) <$> unify' ctx t1 u1 <*> unify' ctx t2 u2
-unify' ctx (TTupT ts) (TTupT us)
+unify' :: UnifyContext -> T.Type -> T.Type -> TM Subst
+unify' _ T.TInt T.TInt = return mempty
+unify' ctx (T.TFun t1 t2) (T.TFun u1 u2) = (<>) <$> unify' ctx t1 u1 <*> unify' ctx t2 u2
+unify' ctx (T.TTup ts) (T.TTup us)
| length ts == length us = mconcat <$> zipWithM (unify' ctx) ts us
-unify' _ (TyVar var) ty = return (substVar var ty)
-unify' _ ty (TyVar var) = return (substVar var ty)
+unify' _ (T.TyVar var) ty = return (substVar var ty)
+unify' _ ty (T.TyVar var) = return (substVar var ty)
unify' (UnifyContext sr t1 t2) _ _ = throwError (TypeError sr t1 t2)
-convertType :: Type -> TypeT
-convertType (TFun t1 t2) = TFunT (convertType t1) (convertType t2)
-convertType TInt = TIntT
-convertType (TTup ts) = TTupT (map convertType ts)
+convertType :: S.Type -> T.Type
+convertType (S.TFun t1 t2) = T.TFun (convertType t1) (convertType t2)
+convertType S.TInt = T.TInt
+convertType (S.TTup ts) = T.TTup (map convertType ts)
-infer :: Env -> Expr -> TM (Subst, ExprT)
+infer :: Env -> S.Expr -> TM (Subst, T.Expr)
infer env expr = case expr of
- Lam _ [] body -> infer env body
- Lam sr args@(_:_:_) body -> infer env (foldr (Lam sr . pure) body args)
- Lam _ [(arg, _)] body -> do
+ S.Lam _ [] body -> infer env body
+ S.Lam sr args@(_:_:_) body -> infer env (foldr (S.Lam sr . pure) body args)
+ S.Lam _ [(arg, _)] body -> do
argVar <- genTyVar
- let augEnv = envAdd arg (TypeSchemeT [] argVar) env
+ let augEnv = envAdd arg (T.TypeScheme [] argVar) env
(theta, body') <- infer augEnv body
let argType = theta >>! argVar
- return (theta, LamT (TFunT argType (exprType body')) (Occ arg argType) body')
- Call sr func arg -> do
+ return (theta, T.Lam (T.TFun argType (T.exprType body'))
+ (T.Occ arg argType) body')
+ S.Call sr func arg -> do
(theta1, func') <- infer env func
(theta2, arg') <- infer (theta1 >>! env) arg
resVar <- genTyVar
- theta3 <- unify sr (theta2 >>! exprType func') (TFunT (exprType arg') resVar)
+ theta3 <- unify sr (theta2 >>! T.exprType func')
+ (T.TFun (T.exprType arg') resVar)
return (theta3 <> theta2 <> theta1
- ,CallT (theta3 >>! resVar)
+ ,T.Call (theta3 >>! resVar)
((theta3 <> theta2) >>! func') -- TODO: quadratic complexity
(theta3 >>! arg')) -- TODO: quadratic complexity
- Int _ val -> return (mempty, IntT val)
- Tup _ es -> fmap TupT <$> inferList env es
- Var sr name
+ S.Int _ val -> return (mempty, T.Int val)
+ S.Tup _ es -> fmap T.Tup <$> inferList env es
+ S.Var sr name
| Just sty <- envFind name env -> do
ty <- instantiate sty
- return (mempty, VarT (Occ name ty))
+ return (mempty, T.Var (T.Occ name ty))
| otherwise ->
throwError (RefError sr name)
- Annot sr subex ty -> do
+ S.Annot sr subex ty -> do
(theta1, subex') <- infer env subex
- theta2 <- unify sr (exprType subex') (convertType ty)
+ theta2 <- unify sr (T.exprType subex') (convertType ty)
return (theta2 <> theta1, theta2 >>! subex') -- TODO: quadratic complexity
-inferList :: Env -> [Expr] -> TM (Subst, [ExprT])
+inferList :: Env -> [S.Expr] -> TM (Subst, [T.Expr])
inferList _ [] = return (mempty, [])
inferList env (expr : exprs) = do
(theta, expr') <- infer env expr
@@ -180,24 +183,24 @@ inferList env (expr : exprs) = do
return (theta <> theta', expr' : res)
-runPass :: Context -> Program -> Either TCError ProgramT
+runPass :: Context -> S.Program -> Either TCError T.Program
runPass (Context _ (Builtins builtins)) prog =
let env = Env (Map.fromList [(name, generalise emptyEnv ty) | (name, ty) <- builtins])
in runTM (typeCheck env prog)
-typeCheck :: Env -> Program -> TM ProgramT
-typeCheck startEnv (Program decls) =
+typeCheck :: Env -> S.Program -> TM T.Program
+typeCheck startEnv (S.Program decls) =
let defs = [(name, ty)
- | Def (Function (Just ty) (name, _) _ _) <- decls]
+ | S.Def (S.Function (Just ty) (name, _) _ _) <- decls]
env = foldl (\env' (name, ty) -> envAdd name (generalise env' (convertType ty)) env')
startEnv defs
- in ProgramT <$> mapM (typeCheckDef env . (\(Def def) -> def)) decls
-
-typeCheckDef :: Env -> Def -> TM DefT
-typeCheckDef env (Function mannot (name, sr) args@(_:_) body) =
- typeCheckDef env (Function mannot (name, sr) [] (Lam sr args body))
-typeCheckDef env (Function (Just annot) (name, sr) [] body) =
- typeCheckDef env (Function Nothing (name, sr) [] (Annot sr body annot))
-typeCheckDef env (Function Nothing (name, _) [] body) = do
+ in T.Program <$> mapM (typeCheckDef env . (\(S.Def def) -> def)) decls
+
+typeCheckDef :: Env -> S.Def -> TM T.Def
+typeCheckDef env (S.Function mannot (name, sr) args@(_:_) body) =
+ typeCheckDef env (S.Function mannot (name, sr) [] (S.Lam sr args body))
+typeCheckDef env (S.Function (Just annot) (name, sr) [] body) =
+ typeCheckDef env (S.Function Nothing (name, sr) [] (S.Annot sr body annot))
+typeCheckDef env (S.Function Nothing (name, _) [] body) = do
(_, body') <- infer env body
- return (DefT name body')
+ return (T.Def name body')
generated by cgit v1.2.3-70-g09d2 (git 2.47.0) at 2024-11-21 23:53:26 +0100