From 5b15f056d1a52d6d05f9441d44bf0b50ae480229 Mon Sep 17 00:00:00 2001 From: Tom Smeding Date: Sat, 25 Jul 2020 10:34:17 +0200 Subject: Namespacing of AST's, not suffix-disambiguation --- ast/CC/AST/Source.hs | 5 +- ast/CC/AST/Typed.hs | 70 ++++++++++---------- ast/CC/Context.hs | 2 +- backend/CC/Backend/Dumb.hs | 12 ++-- typecheck/CC/Typecheck.hs | 159 +++++++++++++++++++++++---------------------- 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') -- cgit v1.2.3