+21 -24

typing/ctype.ml

reviewed

··· 3416 3416 } 3417 3417 | Not_a_function 3418 3418 3419 3419 - exception Filter_arrow_failed of filter_arrow_failure 3420 3420 - 3421 3419 type filtered_arrow = 3422 3420 { ty_param : type_expr; 3423 3421 ty_ret : type_expr; ··· 3444 3442 let t' = newty2 ~level (Tarrow (l, t1, t2, commu_ok)) in 3445 3443 t', t1, t2 3446 3444 in 3447 3447 - let t = 3448 3448 - try expand_head_trace env t 3449 3449 - with Unify_trace trace -> 3445 3445 + match expand_head_trace env t with 3446 3446 + | t -> 3447 3447 + begin 3448 3448 + match get_desc t with 3449 3449 + | Tvar _ -> 3450 3450 + let t', ty_param, ty_ret = function_type (get_level t) in 3451 3451 + link_type t t'; 3452 3452 + Ok { ty_param; ty_ret } 3453 3453 + | Tarrow(l', ty_param, ty_ret, _) -> 3454 3454 + if l = l' || !Clflags.classic && l = Nolabel && not (is_optional l') 3455 3455 + then Ok { ty_param; ty_ret } 3456 3456 + else Error (Label_mismatch 3457 3457 + { got = l; expected = l'; expected_type = t }) 3458 3458 + | _ -> 3459 3459 + Error Not_a_function 3460 3460 + end 3461 3461 + | exception Unify_trace trace -> 3450 3462 let t', _, _ = function_type (get_level t) in 3451 3451 - raise (Filter_arrow_failed 3452 3452 - (Unification_error 3453 3453 - (expand_to_unification_error 3454 3454 - env 3455 3455 - (Diff { got = t'; expected = t } :: trace)))) 3456 3456 - in 3457 3457 - match get_desc t with 3458 3458 - | Tvar _ -> 3459 3459 - let t', ty_param, ty_ret = function_type (get_level t) in 3460 3460 - link_type t t'; 3461 3461 - { ty_param; ty_ret } 3462 3462 - | Tarrow(l', ty_param, ty_ret, _) -> 3463 3463 - if l = l' || !Clflags.classic && l = Nolabel && not (is_optional l') 3464 3464 - then { ty_param; ty_ret } 3465 3465 - else raise (Filter_arrow_failed 3466 3466 - (Label_mismatch 3467 3467 - { got = l; expected = l'; expected_type = t })) 3468 3468 - | _ -> 3469 3469 - raise (Filter_arrow_failed Not_a_function) 3463 3463 + Error (Unification_error 3464 3464 + (expand_to_unification_error 3465 3465 + env 3466 3466 + (Diff { got = t'; expected = t } :: trace))) 3470 3467 3471 3468 let is_really_poly env ty = 3472 3469 let snap = Btype.snapshot () in

+10 -12

typing/ctype.mli

reviewed

··· 308 308 ty_ret : type_expr; 309 309 } 310 310 311 311 + type filter_arrow_failure = 312 312 + | Unification_error of Errortrace.unification_error 313 313 + | Label_mismatch of 314 314 + { got : arg_label 315 315 + ; expected : arg_label 316 316 + ; expected_type : type_expr 317 317 + } 318 318 + | Not_a_function 319 319 + 311 320 val filter_arrow: Env.t -> type_expr -> arg_label -> param_hole:bool -> 312 312 - filtered_arrow 321 321 + (filtered_arrow, filter_arrow_failure) result 313 322 (* A special case of unification with [l:'a -> 'b]. If [param_hole] is 314 323 true then ['a] might be initialized with a [Tvar _] hole to be filled 315 324 later by a [Tpoly _]. ··· 340 349 (* Replaces all the variables of a type by a univar. *) 341 350 342 351 (* Exceptions for special cases of unify *) 343 343 - 344 344 - type filter_arrow_failure = 345 345 - | Unification_error of Errortrace.unification_error 346 346 - | Label_mismatch of 347 347 - { got : arg_label 348 348 - ; expected : arg_label 349 349 - ; expected_type : type_expr 350 350 - } 351 351 - | Not_a_function 352 352 - 353 353 - exception Filter_arrow_failed of filter_arrow_failure 354 352 355 353 type filter_method_failure = 356 354 | Unification_error of Errortrace.unification_error

+16 -12

typing/typecore.ml

reviewed

··· 3322 3322 | Some spat -> check_poly_constraint spat env label 3323 3323 in 3324 3324 let { ty_param; ty_ret } = 3325 3325 - try filter_arrow env ty_expected label ~param_hole:has_poly 3326 3326 - with Filter_arrow_failed err -> 3325 3325 + match filter_arrow env ty_expected label ~param_hole:has_poly with 3326 3326 + | Ok filtered_arrow -> filtered_arrow 3327 3327 + | Error err -> 3327 3328 let loc_fun, ty_fun = in_function in 3328 3329 let err = 3329 3330 error_of_filter_arrow_failure ~explanation:None ty_fun err ~first ··· 4085 4086 (* Assert that [ty] is a function, and return its return type. *) 4086 4087 let filter_ty_ret_exn ty arg_label ~param_hole = 4087 4088 match filter_arrow env ty arg_label ~param_hole with 4088 4088 - | { ty_ret; _ } -> ty_ret 4089 4089 - | exception (Filter_arrow_failed error) -> 4089 4089 + | Ok { ty_ret; _ } -> ty_ret 4090 4090 + | Error error -> 4090 4091 let trace = 4091 4092 match error with 4092 4093 | Unification_error trace -> trace ··· 5256 5257 with_local_level_generalize_structure_if separate begin fun () -> 5257 5258 (* If [has_poly] is true then we rely on the later call to type_pat to 5258 5259 enforce the invariant that the parameter type be a [Tpoly] node *) 5259 5259 - try filter_arrow env (instance ty_expected) arg_label ~param_hole:has_poly 5260 5260 - with Filter_arrow_failed err -> 5261 5261 - let err = 5262 5262 - error_of_filter_arrow_failure ~explanation ty_fun err ~first 5263 5263 - in 5264 5264 - raise (Error(loc, env, err)) 5260 5260 + match 5261 5261 + filter_arrow env (instance ty_expected) arg_label ~param_hole:has_poly 5262 5262 + with 5263 5263 + | Ok filtered_arrow -> filtered_arrow 5264 5264 + | Error err -> 5265 5265 + let err = 5266 5266 + error_of_filter_arrow_failure ~explanation ty_fun err ~first 5267 5267 + in 5268 5268 + raise (Error(loc, env, err)) 5265 5269 end 5266 5270 in 5267 5271 if !Clflags.principal ··· 6008 6012 let exception Filter_arrow_mono_failed in 6009 6013 let filter_arrow_mono env t l = 6010 6014 match filter_arrow env t l ~param_hole:false with 6011 6011 - | exception Filter_arrow_failed _ -> raise Filter_arrow_mono_failed 6012 6012 - | {ty_param; _} as farr -> 6015 6015 + | Error _ -> raise Filter_arrow_mono_failed 6016 6016 + | Ok ({ty_param; _} as farr) -> 6013 6017 match tpoly_get_mono_opt ty_param with 6014 6018 | None -> raise Filter_arrow_mono_failed 6015 6019 | Some ty_param -> { farr with ty_param }