Introduce "type patterns" to the typechecker in preparation for function type-param inference

1 files changed, 51 insertions, 36 deletions

diff --git a/src/boot/me/type.ml b/src/boot/me/type.ml
index 25ae22b3..046b17ea 100644
--- a/src/boot/me/type.ml
+++ b/src/boot/me/type.ml
@@ -11,6 +11,12 @@ type ltype =
   | LTYPE_poly of Ast.ty_param array * Ast.ty   (* "big lambda" *)
   | LTYPE_module of Ast.mod_items               (* type of a module *)
 
+(* A "type pattern" used for inference. *)
+type ty_pat =
+    TYPAT_wild                (* matches any type *)
+  | TYPAT_ty of Ast.ty        (* matches only the given type *)
+  | TYPAT_fn of Ast.ty array  (* matches a function with some arg types *)
+
 type fn_ctx = {
   fnctx_return_type: Ast.ty;
   fnctx_is_iter: bool;
@@ -231,7 +237,7 @@ let check_stmt (cx:Semant.ctxt) : (fn_ctx -> Ast.stmt -> unit) =
 
   (* Here the actual inference happens. *)
   let internal_check_slot
-      (infer:Ast.ty option)
+      (infer:ty_pat)
       (defn_id:Common.node_id)
       : Ast.ty =
     let slot =
@@ -243,10 +249,10 @@ let check_stmt (cx:Semant.ctxt) : (fn_ctx -> Ast.stmt -> unit) =
             "internal_check_slot: supplied defn wasn't a slot at all"
     in
     match infer, slot.Ast.slot_ty with
-        Some expected, Some actual ->
+        TYPAT_ty expected, Some actual ->
           demand expected actual;
           actual
-      | Some inferred, None ->
+      | TYPAT_ty inferred, None ->
           iflog cx
             (fun _ ->
                log cx "setting auto slot #%d = %a to type %a"
@@ -258,9 +264,11 @@ let check_stmt (cx:Semant.ctxt) : (fn_ctx -> Ast.stmt -> unit) =
           Hashtbl.replace cx.Semant.ctxt_all_defns defn_id
             (Semant.DEFN_slot new_slot);
           inferred
-      | None, Some actual -> actual
-      | None, None ->
+      | TYPAT_wild, Some actual -> actual
+      | TYPAT_wild, None ->
           Common.err None "can't infer any type for this slot"
+      | TYPAT_fn _, _ ->
+          Common.unimpl None "sorry, fn type patterns aren't implemented"
   in
 
   let internal_check_mod_item_decl
@@ -281,7 +289,7 @@ let check_stmt (cx:Semant.ctxt) : (fn_ctx -> Ast.stmt -> unit) =
   in
 
   let rec internal_check_base_lval
-      (infer:Ast.ty option)
+      (infer:ty_pat)
       (nbi:Ast.name_base Common.identified)
       : ltype =
     let lval_id = nbi.Common.id in
@@ -302,7 +310,7 @@ let check_stmt (cx:Semant.ctxt) : (fn_ctx -> Ast.stmt -> unit) =
       (comp:Ast.lval_component)
       : ltype =
     let base_ity =
-      match internal_check_lval None base with
+      match internal_check_lval TYPAT_wild base with
           LTYPE_poly (_, ty) ->
             Common.err None "can't index the polymorphic type '%a'"
               Ast.sprintf_ty ty
@@ -459,7 +467,7 @@ let check_stmt (cx:Semant.ctxt) : (fn_ctx -> Ast.stmt -> unit) =
     in
     typecheck base_ity
 
-  and internal_check_lval (infer:Ast.ty option) (lval:Ast.lval) : ltype =
+  and internal_check_lval (infer:ty_pat) (lval:Ast.lval) : ltype =
     match lval with
         Ast.LVAL_base nbi -> internal_check_base_lval infer nbi
       | Ast.LVAL_ext (base, comp) -> internal_check_ext_lval base comp
@@ -473,8 +481,7 @@ let check_stmt (cx:Semant.ctxt) : (fn_ctx -> Ast.stmt -> unit) =
   and internal_check_outer_lval
       ~mut:(mut:Ast.mutability)
       ~deref:(deref:bool)
-      ~fn_args:(fn_args:(Ast.ty array) option)
-      (infer:Ast.ty option)
+      (infer:ty_pat)
       (lval:Ast.lval)
       : (Ast.ty * int) =
     let yield_ty ty =
@@ -482,34 +489,42 @@ let check_stmt (cx:Semant.ctxt) : (fn_ctx -> Ast.stmt -> unit) =
         (maybe_mutable mut ty, n_boxes)
     in
     match infer, internal_check_lval infer lval with
-      | None, LTYPE_mono ty -> yield_ty ty
-      | Some expected, LTYPE_mono actual ->
+      | TYPAT_wild, LTYPE_mono ty -> yield_ty ty
+      | TYPAT_ty expected, LTYPE_mono actual ->
           demand expected actual;
           yield_ty actual
-      | None, (LTYPE_poly _ as lty) ->
-          begin
-            match fn_args with
-                None ->
-                  Common.err None
-                    "can't auto-instantiate %a" sprintf_ltype lty
-              | Some args ->
-                  Common.err None "can't auto-instantiate %a on %d args"
-                    sprintf_ltype lty (Array.length args)
-          end
-      | Some _, (LTYPE_poly _) ->
+      | TYPAT_fn _, LTYPE_mono _ ->
+          (* FIXME: typecheck *)
+          Common.unimpl
+            None
+            "sorry, function type patterns aren't typechecked yet"
+      | TYPAT_wild, (LTYPE_poly _ as lty) ->
+          Common.err
+            None
+            "not enough context to automatically instantiate the polymorphic \
+              type '%a'; supply type parameters explicitly"
+            sprintf_ltype lty
+      | TYPAT_ty expected, (LTYPE_poly _ as lty) ->
+          (* FIXME: auto-instantiate *)
+          Common.unimpl
+            None
+            "sorry, automatic polymorphic instantiation of %a to %a isn't \
+            supported yet; please supply type parameters explicitly"
+            sprintf_ltype lty
+            Ast.sprintf_ty expected
+      | TYPAT_fn _, (LTYPE_poly _) ->
           (* FIXME: auto-instantiate *)
           Common.unimpl
             None
-            "sorry, automatic polymorphic instantiation isn't supported yet; \
-              please supply type parameters explicitly"
+            "sorry, automatic polymorphic instantiation of function types \
+            isn't supported yet; please supply type parameters explicitly"
       | _, LTYPE_module _ ->
           Common.err None "can't refer to a module as a first-class value"
 
   and generic_check_lval
       ~mut:(mut:Ast.mutability)
       ~deref:(deref:bool)
-      ~fn_args:(fn_args:(Ast.ty array) option)
-      (infer:Ast.ty option)
+      (infer:ty_pat)
       (lval:Ast.lval)
       : Ast.ty =
     (* The lval we got is an impostor (it may contain unresolved TY_nameds).
@@ -524,11 +539,12 @@ let check_stmt (cx:Semant.ctxt) : (fn_ctx -> Ast.stmt -> unit) =
              (if mut = Ast.MUT_mutable then "mutable" else "immutable")
              (if deref then "true" else "false")
              (match infer with
-                  None -> "<none>"
-                | Some t -> Fmt.fmt_to_str Ast.fmt_ty t))
+                  TYPAT_wild -> "_"
+                | TYPAT_ty t -> Fmt.fmt_to_str Ast.fmt_ty t
+                | TYPAT_fn _ -> "<fn>" (* FIXME *)))
     in
     let (lval_ty, n_boxes) =
-      internal_check_outer_lval ~mut ~deref ~fn_args infer lval
+      internal_check_outer_lval ~mut:mut ~deref:deref infer lval
     in
     let _ =
       iflog cx
@@ -570,10 +586,9 @@ let check_stmt (cx:Semant.ctxt) : (fn_ctx -> Ast.stmt -> unit) =
   and check_lval
       ?mut:(mut=Ast.MUT_immutable)
       ?deref:(deref=false)
-      ?fn_args:(fn_args=None)
       (lval:Ast.lval)
       : Ast.ty =
-    generic_check_lval ~fn_args ~mut ~deref None lval
+    generic_check_lval ~mut:mut ~deref:deref TYPAT_wild lval
 
   and check_atom ?deref:(deref=false) (atom:Ast.atom) : Ast.ty =
     match atom with
@@ -582,7 +597,7 @@ let check_stmt (cx:Semant.ctxt) : (fn_ctx -> Ast.stmt -> unit) =
   in
 
   let infer_slot (ty:Ast.ty) (slot_id:Common.node_id) : unit =
-    ignore (internal_check_slot (Some ty) slot_id)
+    ignore (internal_check_slot (TYPAT_ty ty) slot_id)
   in
 
   let infer_lval
@@ -590,8 +605,8 @@ let check_stmt (cx:Semant.ctxt) : (fn_ctx -> Ast.stmt -> unit) =
       (ty:Ast.ty)
       (lval:Ast.lval)
       : unit =
-    ignore (generic_check_lval ~mut ~deref:false ~fn_args:None
-              (Some (Ast.TY_mutable ty)) lval)
+    ignore (generic_check_lval ?mut:mut ~deref:false
+              (TYPAT_ty (Ast.TY_mutable ty)) lval)
   in
 
   (*
@@ -646,7 +661,7 @@ let check_stmt (cx:Semant.ctxt) : (fn_ctx -> Ast.stmt -> unit) =
    * returns the return type. *)
   let check_fn (callee:Ast.lval) (args:Ast.atom array) : Ast.ty =
     let arg_tys = Array.map check_atom args in
-    let callee_ty = check_lval callee ~fn_args:(Some arg_tys) in
+    let callee_ty = check_lval callee in
     demand_fn (Array.map (fun ty -> Some ty) arg_tys) callee_ty
   in