balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

fix annotation for funciton in ReasonLigo

Browse Source
This commit is contained in:
Pierre-Emmanuel Wulfman 2020-03-07 02:00:29 +01:00
parent efc06be1f6
commit 558f3f5e80
2 changed files with 18 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
src/passes/1-parser/reasonligo/Parser.mly
View File

@ -558,9 +558,13 @@ fun_expr:
in raise (Error (WrongFunctionArguments e)) in raise (Error (WrongFunctionArguments e))
in in
let binders = fun_args_to_pattern $1 in let binders = fun_args_to_pattern $1 in
let lhs_type = match $1 with
EAnnot {value = {inside = _ , _, t; _}; region = r} -> Some (r,t)
| _ -> None
in
let f = {kwd_fun; let f = {kwd_fun;
binders; binders;
lhs_type=None; lhs_type;
arrow; arrow;
body body
} }

27
src/passes/2-simplify/cameligo.ml
View File

@ -176,11 +176,6 @@ let rec pattern_to_typed_var : Raw.pattern -> _ = fun p ->
| Raw.PWild r -> ok (({ region = r ; value = "_" } : Raw.variable) , None) | Raw.PWild r -> ok (({ region = r ; value = "_" } : Raw.variable) , None)
| _ -> fail @@ wrong_pattern "single typed variable" p | _ -> fail @@ wrong_pattern "single typed variable" p
let rec expr_to_typed_expr : Raw.expr -> _ = function
EPar e -> expr_to_typed_expr e.value.inside
| EAnnot {value={inside=e,_,t; _}; _} -> ok (e, Some t)
| e -> ok (e , None)
let rec tuple_pattern_to_typed_vars : Raw.pattern -> _ = fun pattern -> let rec tuple_pattern_to_typed_vars : Raw.pattern -> _ = fun pattern ->
match pattern with match pattern with
| Raw.PPar pp -> tuple_pattern_to_typed_vars pp.value.inside | Raw.PPar pp -> tuple_pattern_to_typed_vars pp.value.inside
@ -646,9 +641,8 @@ and simpl_fun lamb' : expr result =
| _ -> ok lamb.body) | _ -> ok lamb.body)
| _ -> ok lamb.body | _ -> ok lamb.body
in in
let%bind (body , body_type) = expr_to_typed_expr body in
let%bind output_type = let%bind output_type =
bind_map_option simpl_type_expression body_type in bind_map_option (fun x -> simpl_type_expression @@ snd x) lamb.lhs_type in
let%bind body = simpl_expression body in let%bind body = simpl_expression body in
let rec layer_arguments (arguments: (Raw.variable * type_expression) list) = let rec layer_arguments (arguments: (Raw.variable * type_expression) list) =
match arguments with match arguments with
@ -811,9 +805,8 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap list result
let%bind var = pattern_to_var hd in let%bind var = pattern_to_var hd in
ok (var , tl) ok (var , tl)
in in
let%bind lhs_type' = bind_map_option (fun x -> simpl_type_expression (snd x)) lhs_type in let%bind let_rhs = match args with
let%bind let_rhs,lhs_type = match args with | [] -> ok (let_rhs)
| [] -> ok (let_rhs, lhs_type')
| param1::others -> | param1::others ->
let fun_ = { let fun_ = {
kwd_fun = Region.ghost; kwd_fun = Region.ghost;
@ -822,12 +815,18 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap list result
arrow = Region.ghost; arrow = Region.ghost;
body = let_rhs body = let_rhs
} in } in
let f_args = nseq_to_list (param1,others) in ok (Raw.EFun {region=Region.ghost ; value=fun_})
let%bind ty = bind_map_list typed_pattern_to_typed_vars f_args in
let aux acc ty = Option.map (t_function (snd ty)) acc in
ok (Raw.EFun {region=Region.ghost ; value=fun_},List.fold_right' aux lhs_type' ty)
in in
let%bind rhs' = simpl_expression let_rhs in let%bind rhs' = simpl_expression let_rhs in
let%bind lhs_type = match let_rhs with
| Raw.EFun {value={binders;lhs_type};_} ->
let f_args = nseq_to_list (binders) in
let%bind ty = bind_map_list typed_pattern_to_typed_vars f_args in
let aux acc ty = Option.map (t_function (snd ty)) acc in
let%bind lhs_type' = bind_map_option (fun x -> simpl_type_expression (snd x)) lhs_type in
ok @@ List.fold_right' aux lhs_type' ty
| _ -> bind_map_option (fun x -> simpl_type_expression (snd x)) lhs_type
in
ok @@ [loc x @@ (Declaration_constant (Var.of_name var.value , lhs_type , inline, rhs'))] ok @@ [loc x @@ (Declaration_constant (Var.of_name var.value , lhs_type , inline, rhs'))]
) )