@@ -154,7 +154,8 @@ let check_stmt (cx:Semant.ctxt) : (fn_ctx -> Ast.stmt -> unit) =
154
154
| ty -> type_error " record" ty
155
155
in
156
156
let demand_fn
157
- ?param_handler :(param_handler = demand)
157
+ ?param_handler :(param_handler =
158
+ fun a idx effect -> demand a (Ast. TY_param (idx, effect)))
158
159
(arg_tys:Ast.ty option array )
159
160
(actual:Ast.ty )
160
161
: Ast. ty =
@@ -179,7 +180,8 @@ let check_stmt (cx:Semant.ctxt) : (fn_ctx -> Ast.stmt -> unit) =
179
180
let maybe_demand a_opt b =
180
181
match a_opt, b with
181
182
None , _ -> ()
182
- | Some a , Ast. TY_param _ -> param_handler a b
183
+ | Some a , Ast. TY_param (idx , effect ) ->
184
+ param_handler a idx effect
183
185
| Some a , _ -> demand a b
184
186
in
185
187
Common. arr_iter2 maybe_demand arg_tys in_slot_tys;
@@ -504,12 +506,33 @@ let check_stmt (cx:Semant.ctxt) : (fn_ctx -> Ast.stmt -> unit) =
504
506
| TYPAT_fn arg_tys , LTYPE_mono actual ->
505
507
ignore (demand_fn (Array. map (fun ty -> Some ty) arg_tys) actual);
506
508
yield_ty actual
507
- | TYPAT_fn _ , LTYPE_poly (_ , _ ) ->
508
- (* FIXME: auto-instantiate *)
509
- Common. unimpl
510
- None
511
- " instantiation of polymorphic function types; please supply type \
512
- parameters explicitly, sorry"
509
+ | TYPAT_fn arg_tys , (LTYPE_poly (ty_params , ty ) as lty ) ->
510
+ (* Perform automatic instantiation of polymorphic types. *)
511
+ let ty = fundamental_ty ty in
512
+ let substs = Array. make (Array. length ty_params) None in
513
+ let param_handler substituted_ty idx _ =
514
+ match substs.(idx) with
515
+ | None -> substs.(idx) < - Some substituted_ty
516
+ | Some substituted_ty' -> demand substituted_ty substituted_ty'
517
+ in
518
+ let arg_ty_opts = Array. map (fun ty -> Some ty) arg_tys in
519
+ ignore (demand_fn ~param_handler: param_handler arg_ty_opts ty);
520
+ let get_subst subst_opt =
521
+ match subst_opt with
522
+ Some subst -> subst
523
+ | None ->
524
+ Common. bug ()
525
+ " internal_check_outer_lval: subst not found"
526
+ in
527
+ let substs = Array. map get_subst substs in
528
+ begin
529
+ match beta_reduce (Semant. lval_base_id lval) lty substs with
530
+ LTYPE_mono ty -> yield_ty ty
531
+ | _ ->
532
+ Common. bug ()
533
+ " internal_check_outer_lval: beta reduction didn't yield \
534
+ a monotype"
535
+ end
513
536
| TYPAT_wild , (LTYPE_poly _ as lty ) ->
514
537
Common. err
515
538
None
0 commit comments