bugfix: new typer did not check a lambda's result' type against its annotation.
This commit is contained in:
parent
2633d732a3
commit
4cb34a1d7e
@ -420,8 +420,7 @@ and type_lambda e state {
|
|||||||
let e' = Environment.add_ez_binder (binder) fresh e in
|
let e' = Environment.add_ez_binder (binder) fresh e in
|
||||||
|
|
||||||
let%bind (result , state') = type_expression e' state result in
|
let%bind (result , state') = type_expression e' state result in
|
||||||
let () = Printf.printf "this does not make use of the typed body, this code sounds buggy." in
|
let wrapped = Solver.Wrap.lambda fresh input_type' output_type' result.type_expression in
|
||||||
let wrapped = Solver.Wrap.lambda fresh input_type' output_type' in
|
|
||||||
ok (({binder;result}:O.lambda),state',wrapped)
|
ok (({binder;result}:O.lambda),state',wrapped)
|
||||||
|
|
||||||
and type_constant (name:I.constant') (lst:O.type_expression list) (tv_opt:O.type_expression option) : (O.constant' * O.type_expression) result =
|
and type_constant (name:I.constant') (lst:O.type_expression list) (tv_opt:O.type_expression option) : (O.constant' * O.type_expression) result =
|
||||||
|
@ -339,23 +339,26 @@ let lambda
|
|||||||
: T.type_expression ->
|
: T.type_expression ->
|
||||||
T.type_expression option ->
|
T.type_expression option ->
|
||||||
T.type_expression option ->
|
T.type_expression option ->
|
||||||
|
T.type_expression ->
|
||||||
(constraints * T.type_variable) =
|
(constraints * T.type_variable) =
|
||||||
fun fresh arg body ->
|
fun fresh arg output result ->
|
||||||
let whole_expr = Core.fresh_type_variable () in
|
let whole_expr = Core.fresh_type_variable () in
|
||||||
let unification_arg = T.{ tsrc = "wrap: lambda: arg" ; t = P_variable (Core.fresh_type_variable ()) } in
|
let unification_arg = T.{ tsrc = "wrap: lambda: arg" ; t = P_variable (Core.fresh_type_variable ()) } in
|
||||||
let unification_body = T.{ tsrc = "wrap: lambda: whole" ; t = P_variable (Core.fresh_type_variable ()) } in
|
let unification_output = T.{ tsrc = "wrap: lambda: whole" ; t = P_variable (Core.fresh_type_variable ()) } in
|
||||||
|
let result' = type_expression_to_type_value result in
|
||||||
let arg' = match arg with
|
let arg' = match arg with
|
||||||
None -> []
|
None -> []
|
||||||
| Some arg -> [c_equation unification_arg (type_expression_to_type_value arg) "wrap: lambda: arg annot"] in
|
| Some arg -> [c_equation unification_arg (type_expression_to_type_value arg) "wrap: lambda: arg annot"] in
|
||||||
let body' = match body with
|
let output' = match output with
|
||||||
None -> []
|
None -> []
|
||||||
| Some body -> [c_equation unification_body (type_expression_to_type_value body) "wrap: lambda: body annot"]
|
| Some output -> [c_equation unification_output (type_expression_to_type_value output) "wrap: lambda: output annot"]
|
||||||
in [
|
in [
|
||||||
|
c_equation unification_output result' "wrap: lambda: result" ;
|
||||||
c_equation (type_expression_to_type_value fresh) unification_arg "wrap: lambda: arg" ;
|
c_equation (type_expression_to_type_value fresh) unification_arg "wrap: lambda: arg" ;
|
||||||
c_equation ({ tsrc = "wrap: lambda: whole" ; t = P_variable whole_expr })
|
c_equation ({ tsrc = "wrap: lambda: whole" ; t = P_variable whole_expr })
|
||||||
(p_constant C_arrow ([unification_arg ; unification_body]))
|
(p_constant C_arrow ([unification_arg ; unification_output]))
|
||||||
"wrap: lambda: arrow (whole)"
|
"wrap: lambda: arrow (whole)"
|
||||||
] @ arg' @ body' , whole_expr
|
] @ arg' @ output' , whole_expr
|
||||||
|
|
||||||
(* This is pretty much a wrapper for an n-ary function. *)
|
(* This is pretty much a wrapper for an n-ary function. *)
|
||||||
let constant : O.type_value -> T.type_expression list -> (constraints * T.type_variable) =
|
let constant : O.type_value -> T.type_expression list -> (constraints * T.type_variable) =
|
||||||
|
Loading…
Reference in New Issue
Block a user