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

This commit is contained in:
Patrick Walton 2010-08-25 10:50:55 -07:00
parent 2b9a48b9c9
commit a48c382549

View File

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