Namespacing of AST's, not suffix-disambiguation

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')