typing architecture

lib/common/ident.ml

@@ -27,3 +27,5 @@ let create ~(hint : string) =
   (!index, hint)
 
 let rename (_, name) = create ~hint:name
+
+let to_string x = Printf.sprintf "%s/%d" (snd x) (fst x)

lib/common/ident.mli

@@ -7,3 +7,5 @@ val from : string -> t
 val create : hint:string -> t
 
 val rename : t -> t
+
+val to_string : t -> string

lib/syntax/parsetree.ml

@@ -61,6 +61,7 @@ and type_paras = string list [@@deriving sexp]
 and type_def =
   | TDAdt of string * type_paras * variant list
   | TDAlias of string * type_expr
+  | TDRecord of string * type_paras * (string * type_expr) list
 [@@deriving sexp]
 
 and mod_body = top_level list [@@deriving sexp]

lib/typing/check.ml

@@ -1,10 +1,74 @@
 [@@@warning "-27"]
 
-type ty = Syntax.Parsetree.type_expr
+open Types
+module T = Tree
+module U = Unify
+open Typedtree
+
+let tv_index = ref 0
+
+let make_tv () =
+  tv_index := !tv_index + 1;
+  let name = Printf.sprintf "'_t_%d" !tv_index in
+  T.TVar (Printf.sprintf "'_%s__%d" name !tv_index)
+
+let make_tv_of hint =
+  tv_index := !tv_index + 1;
+  let name = Printf.sprintf "'_%s_%d" hint !tv_index in
+  T.TVar (Printf.sprintf "'_%s__%d" name !tv_index)
 
 let dealias (t : ty) env : ty = raise Not_found
 
 let normalize t env = dealias t env
 
 let eq (t1 : ty) (t2 : ty) env =
   if t1 == t2 then true else normalize t1 env = normalize t2 env
+
+let inst (t : bind_ty) : ty =
+  let qvs, te = t in
+  let new_tvs = List.map make_tv_of qvs in
+  te |> U.make_subst_lst qvs new_tvs
+
+let generalize (t : ty) : bind_ty = failwith "todo"
+
+let rec type_check (e : T.expr) (env : Env.t) : expr * U.t =
+  match e with
+  | T.EConst c -> tc_const c
+  | T.EVar x -> tc_var x env
+  | T.ELet (x, e0, e1) -> tc_let x e0 e1
+  | T.ELetrec (binds, body) -> tc_letrec binds body
+  | T.ELam (para, body) -> tc_lambda para body
+  | T.EIf (c, e0, e1) -> tc_if_else c e0 e1
+  | T.ECase (e, bs) -> tc_cases e bs
+  | T.EApp (e0, e1) -> tc_app e0 e1
+  | T.EAnn (e, te) -> tc_ann e te
+  | T.ETuple es -> tc_tuple es
+  | T.EField (p, x) -> tc_field p x
+
+and tc_const c =
+  match c with
+  | T.CBool _ -> (EConst (c, bool_ty), U.identity)
+  | T.CInt _ -> (EConst (c, int_ty), U.identity)
+  | T.CString _ -> (EConst (c, string_ty), U.identity)
+
+and tc_var x env =
+  let t = Env.get_value_type x env |> inst in
+  (EVar (x, t), U.identity)
+
+and tc_let x e0 e1 = failwith ""
+
+and tc_letrec binds body = failwith ""
+
+and tc_lambda para body = failwith ""
+
+and tc_if_else c e1 e2 = failwith ""
+
+and tc_cases e bs = failwith ""
+
+and tc_app e0 e1 = failwith ""
+
+and tc_ann e te = failwith ""
+
+and tc_tuple es = failwith ""
+
+and tc_field p x = failwith ""

lib/typing/dune

@@ -1,6 +1,6 @@
 (library
  (name typing)
- (libraries sexplib syntax)
+ (libraries sexplib syntax common)
  (preprocess
   (pps ppx_sexp_conv)))
 

lib/typing/env.ml

@@ -1,7 +1,7 @@
 open Types
 
 type t = {
-  values : (string * ty) list;
+  values : (string * bind_ty) list;
   types : ty_def list;
   modules : (string * mod_ty) list;
 }
@@ -20,6 +20,7 @@ let get_type_def tn env =
   List.find
     (function
       | Syntax.Parsetree.TDAdt (x, _, _)
-      | TDAlias (x, _) ->
+      | TDAlias (x, _)
+      | TDRecord (x, _, _) ->
           x = tn)
     env.types

lib/typing/typedtree.ml

@@ -0,0 +1,40 @@
+open Types
+module T = Tree
+
+type constant = T.constant
+
+type pattern =
+  | PVal of constant
+  | PCons of string * pattern list
+  | PVar of string
+
+type path = T.path
+
+type expr =
+  | EConst of constant * ty
+  | EVar of string * ty
+  | ELet of pattern * expr * expr * ty
+  | ELetrec of (string * lambda_typed) list * expr * ty
+  | ELam of lambda_typed
+  | EIf of expr * expr * expr * ty
+  | ECase of expr * (pattern * expr) list * ty
+  | EApp of expr * expr * ty
+  | EAnn of expr * ty
+  | ETuple of expr list * ty
+  | EField of path * ty
+
+and lambda_typed = string * expr * ty
+
+let get_ty = function
+  | EConst (_, ty)
+  | EVar (_, ty)
+  | ELet (_, _, _, ty)
+  | ELetrec (_, _, ty)
+  | ELam (_, _, ty)
+  | EIf (_, _, _, ty)
+  | ECase (_, _, ty)
+  | EApp (_, _, ty)
+  | EAnn (_, ty)
+  | ETuple (_, ty)
+  | EField (_, ty) ->
+      ty

lib/typing/types.ml

@@ -1,5 +1,15 @@
-type ty = Syntax.Parsetree.type_expr
+module Tree = Syntax.Parsetree
 
-type mod_ty = Syntax.Parsetree.mod_type
+type ty = Tree.type_expr
 
-type ty_def = Syntax.Parsetree.type_def
+type mod_ty = Tree.mod_type
+
+type ty_def = Tree.type_def
+
+type bind_ty = string list * ty
+
+let int_ty = Tree.TCons ("int", [])
+
+let string_ty = Tree.TCons ("string", [])
+
+let bool_ty = Tree.TCons ("bool", [])

lib/typing/unify.ml

@@ -0,0 +1,24 @@
+open Types
+
+type t = ty -> ty
+
+let compose (u0 : t) (u1 : t) : t = fun t -> t |> u0 |> u1
+
+let identity x = x
+
+let ( <$> ) = compose
+
+let apply_lst : t -> ty list -> ty list = List.map
+
+let apply_env u (env : Env.t) : Env.t =
+  {
+    values = List.map (fun (x, te) -> (x, u te)) env.values;
+    (* types and modules have no space for inference *)
+    types = env.types;
+    modules = env.modules;
+  }
+
+let[@warning "-27"] unify (t0 : ty) (t1 : ty) : t = failwith "todo"
+
+let[@warning "-27"] make_subst x t : t = failwith "todo"
+let [@warning "-27"] make_subst_lst xs ts: t = failwith "todo"