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

Added back return instead of ok.

Browse Source
This commit is contained in:
Christian Rinderknecht 2020-06-22 16:29:32 +02:00
parent 8f4ed11539
commit 94039c4d65
1 changed files with 97 additions and 100 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

95
src/passes/02-concrete_to_imperative/pascaligo.ml
View File

@ -16,8 +16,9 @@ open Operators.Concrete_to_imperative.Pascaligo
let r_split = Location.r_split
let return = ok
let rec compile_type_expression : CST.type_expr -> _ result = fun te ->
let return te = ok @@ te in
match te with
TSum sum ->
let (nsepseq, loc) = r_split sum in
@ -36,7 +37,7 @@ let rec compile_type_expression : CST.type_expr -> _ result = fun te ->
let aux (field : CST.field_decl CST.reg) =
let (f, _) = r_split field in
let%bind type_expr = compile_type_expression f.field_type in
ok @@ (f.field_name.value,type_expr)
return @@ (f.field_name.value,type_expr)
in
let%bind record = bind_map_list aux lst in
return @@ t_record_ez ~loc record
@ -66,7 +67,7 @@ let rec compile_type_expression : CST.type_expr -> _ result = fun te ->
get_t_string_singleton_opt d in
let%bind a' = compile_type_expression a in
let%bind c' = compile_type_expression c in
ok @@ t_michelson_or ~loc a' b' c' d'
return @@ t_michelson_or ~loc a' b' c' d'
)
| _ -> fail @@ michelson_type_wrong_arity loc operator.value)
| "michelson_pair" ->
@ -81,7 +82,7 @@ let rec compile_type_expression : CST.type_expr -> _ result = fun te ->
get_t_string_singleton_opt d in
let%bind a' = compile_type_expression a in
let%bind c' = compile_type_expression c in
ok @@ t_michelson_pair ~loc a' b' c' d'
return @@ t_michelson_pair ~loc a' b' c' d'
)
| _ -> fail @@ michelson_type_wrong_arity loc operator.value)
| _ ->
@ -119,12 +120,11 @@ let compile_selection (selection : CST.selection) =
(Access_tuple index, loc)
let rec compile_expression : CST.expr -> (AST.expr , Errors_pascaligo.abs_error) result = fun e ->
let return e = ok @@ e in
let compile_tuple_expression (tuple_expr : CST.tuple_expr) =
let (lst, loc) = r_split tuple_expr in
let%bind lst = bind_map_list compile_expression @@ npseq_to_list lst.inside in
match lst with
hd::[] -> return @@ hd
hd::[] -> return hd
| lst -> return @@ e_tuple ~loc lst
in
let compile_path (path : CST.path) =
@ -245,7 +245,7 @@ let rec compile_expression : CST.expr -> (AST.expr , Errors_pascaligo.abs_error)
let (fa, _) = r_split fa in
let (name, _) = r_split fa.field_name in
let%bind expr = compile_expression fa.field_expr in
ok @@ (name, expr)
return (name, expr)
in
let%bind record = bind_map_list aux @@ npseq_to_list record.ne_elements in
return @@ e_record_ez ~loc record
@ -271,7 +271,7 @@ let rec compile_expression : CST.expr -> (AST.expr , Errors_pascaligo.abs_error)
(Access_record proj.struct_name.value)::path
)
in
ok @@ (path, expr, loc)
return (path, expr, loc)
in
let%bind updates = bind_map_list aux @@ npseq_to_list updates.ne_elements in
let aux e (path, update, loc) = e_update ~loc e path update in
@ -283,12 +283,12 @@ let rec compile_expression : CST.expr -> (AST.expr , Errors_pascaligo.abs_error)
let (p, _) = r_split p in
let (var, _loc) = r_split p.var in
let%bind p_type = bind_map_option (compile_type_expression <@ snd) p.param_type in
ok @@ (var, p_type)
return (var, p_type)
| ParamVar p ->
let (p, _) = r_split p in
let (var, _loc) = r_split p.var in
let%bind p_type = bind_map_option (compile_type_expression <@ snd) p.param_type in
ok @@ (var, p_type)
return (var, p_type)
in
let (func, loc) = r_split func in
let (param, loc_par) = r_split func.param in
@ -394,7 +394,7 @@ let rec compile_expression : CST.expr -> (AST.expr , Errors_pascaligo.abs_error)
let (binding, _) = r_split binding in
let%bind key = compile_expression binding.source in
let%bind value = compile_expression binding.image in
ok @@ (key,value)
return (key,value)
in
let%bind map = bind_map_list aux lst in
return @@ e_map ~loc map
@ -406,7 +406,7 @@ let rec compile_expression : CST.expr -> (AST.expr , Errors_pascaligo.abs_error)
let (binding, _) = r_split binding in
let%bind key = compile_expression binding.source in
let%bind value = compile_expression binding.image in
ok @@ (key,value)
return (key,value)
in
let%bind map = bind_map_list aux lst in
return @@ e_big_map ~loc map
@ -420,14 +420,12 @@ let rec compile_expression : CST.expr -> (AST.expr , Errors_pascaligo.abs_error)
and compile_matching_expr : type a.(a -> _ result) -> a CST.case_clause CST.reg List.Ne.t -> _ =
fun compiler cases ->
let compile_pattern pattern = ok @@ pattern
in
let return e = ok @@ e in
let compile_pattern pattern = return pattern in
let compile_simple_pattern (pattern : CST.pattern) =
match pattern with
PVar var ->
let (var, _) = r_split var in
ok @@ Var.of_name var
return @@ Var.of_name var
| _ -> fail @@ unsupported_non_var_pattern pattern
in
let compile_list_pattern (cases : (CST.pattern * _) list) =
@ -436,12 +434,12 @@ fun compiler cases ->
| [(PList PCons cons, econs);(PList PNil _, match_nil)] ->
let (cons,_) = r_split cons in
let%bind (hd,tl) = match snd @@ List.split (snd cons) with
tl::[] -> ok @@ (fst cons,tl)
tl::[] -> return (fst cons,tl)
| _ -> fail @@ unsupported_deep_list_patterns @@ fst cons
in
let%bind (hd,tl) = bind_map_pair compile_simple_pattern (hd,tl) in
let match_cons = (hd,tl,econs) in
ok @@ (match_nil,match_cons)
return (match_nil,match_cons)
| _ -> fail @@ unsupported_deep_list_patterns @@ fst @@ List.hd cases
in
let compile_simple_tuple_pattern (tuple : CST.tuple_pattern) =
@ -456,22 +454,22 @@ fun compiler cases ->
( match c with
PUnit _ ->
fail @@ unsupported_pattern_type constr
| PFalse _ -> ok @@ (Constructor "false", Var.of_name "_")
| PTrue _ -> ok @@ (Constructor "true", Var.of_name "_")
| PNone _ -> ok @@ (Constructor "None", Var.of_name "_")
| PFalse _ -> return (Constructor "false", Var.of_name "_")
| PTrue _ -> return (Constructor "true", Var.of_name "_")
| PNone _ -> return (Constructor "None", Var.of_name "_")
| PSomeApp some ->
let (some,_) = r_split some in
let (_, pattern) = some in
let (pattern,_) = r_split pattern in
let%bind pattern = compile_simple_pattern pattern.inside in
ok @@ (Constructor "Some", pattern)
return (Constructor "Some", pattern)
| PConstrApp constr ->
let (constr, _) = r_split constr in
let (constr, patterns) = constr in
let (constr, _) = r_split constr in
let%bind pattern = bind_map_option compile_simple_tuple_pattern patterns in
let pattern = Option.unopt ~default:(Var.of_name "_") pattern in
ok (Constructor constr, pattern)
return (Constructor constr, pattern)
)
| _ -> fail @@ unsupported_pattern_type constr
in
@ -479,7 +477,7 @@ fun compiler cases ->
let (case, _loc) = r_split case in
let%bind pattern = compile_pattern case.pattern in
let%bind expr = compiler case.rhs in
ok (pattern, expr)
return (pattern, expr)
in
let%bind cases = bind_map_ne_list aux cases in
match cases with
@ -498,10 +496,9 @@ fun compiler cases ->
return @@ AST.Match_variant (List.combine constrs lst)
| (p, _), _ -> fail @@ unsupported_pattern_type p
let compile_attribute_declaration attributes =
match attributes with
None -> ok @@ false
| Some _ -> ok @@ true
let compile_attribute_declaration = function
None -> return false
| Some _ -> return true
let compile_parameters (params : CST.parameters) =
let compile_param_decl (param : CST.param_decl) =
@ -510,12 +507,12 @@ let compile_parameters (params : CST.parameters) =
let (pc, _loc) = r_split pc in
let (var, _) = r_split pc.var in
let%bind param_type = bind_map_option (compile_type_expression <@ snd) pc.param_type in
ok @@ (var, param_type)
return (var, param_type)
| ParamVar pv ->
let (pv, _loc) = r_split pv in
let (var, _) = r_split pv.var in
let%bind param_type = bind_map_option (compile_type_expression <@ snd) pv.param_type in
ok @@ (var, param_type)
return (var, param_type)
in
let (params, _loc) = r_split params in
let params = npseq_to_list params.inside in
@ -523,15 +520,15 @@ let compile_parameters (params : CST.parameters) =
let rec compile_instruction : ?next: AST.expression -> CST.instruction -> _ result = fun ?next instruction ->
let return expr = match next with
Some e -> ok @@ e_sequence expr e
| None -> ok @@ expr
Some e -> return @@ e_sequence expr e
| None -> return expr
in
let compile_tuple_expression (tuple_expr : CST.tuple_expr) =
let (lst, loc) = r_split tuple_expr in
let%bind lst = bind_map_list compile_expression @@ npseq_to_list lst.inside in
match lst with
hd::[] -> ok @@ hd
| lst -> ok @@ e_tuple ~loc lst
hd::[] -> return hd
| lst -> return @@ e_tuple ~loc lst
in
let compile_if_clause : ?next:AST.expression -> CST.if_clause -> _ = fun ?next if_clause ->
match if_clause with
@ -553,14 +550,14 @@ let rec compile_instruction : ?next: AST.expression -> CST.instruction -> _ resu
Name var ->
let (var,loc) = r_split var in
let str = e_variable_ez ~loc var in
ok @@ (str, var, [])
ok (str, var, [])
| Path proj ->
let (proj, loc) = r_split proj in
let (var, loc_var) = r_split proj.struct_name in
let path = List.map compile_selection @@ npseq_to_list proj.field_path in
let (path, _) = List.split path in
let str = e_accessor ~loc (e_variable_ez ~loc:loc_var var) path in
ok @@ (str, var, path)
ok (str, var, path)
in
let compile_lhs : CST.lhs -> _ = fun lhs ->
match lhs with
@ -717,24 +714,23 @@ and compile_statement : ?next:AST.expression -> CST.attr_decl option -> CST.stat
match statement with
Instr i ->
let%bind i = compile_instruction ?next i in
ok @@ (Some i, None)
return (Some i, None)
| Data dd ->
let next = Option.unopt ~default:(e_skip ()) next in
let%bind dd = compile_data_declaration ~next ?attr dd in
ok @@ (Some dd, None)
| Attr at -> ok @@ (next, Some at)
return (Some dd, None)
| Attr at -> return (next, Some at)
and compile_block : ?next:AST.expression -> CST.block CST.reg -> _ result = fun ?next block ->
let (block', _loc) = r_split block in
let statements = npseq_to_list block'.statements in
let aux (next,attr) statement =
let%bind (statement, attr) = compile_statement ?next attr statement in
ok @@ (statement,attr)
return (statement,attr)
in
let%bind (block', _) = bind_fold_right_list aux (next,None) statements in
match block' with
Some block -> ok @@ block
Some block -> return block
| None -> fail @@ block_start_with_attribute block
and compile_fun_decl ({kwd_recursive; fun_name; param; ret_type; block_with; return=r; attributes}: CST.fun_decl) =
@ -744,7 +740,7 @@ and compile_fun_decl ({kwd_recursive; fun_name; param; ret_type; block_with; ret
let%bind param = compile_parameters param in
let%bind r = compile_expression r in
let (param, param_type) = List.split param in
let%bind body = Option.unopt ~default:(ok @@ r) @@
let%bind body = Option.unopt ~default:(return r) @@
Option.map (compile_block ~next:r <@ fst) block_with
in
(* This handle the parameter case *)
@ -774,16 +770,17 @@ and compile_fun_decl ({kwd_recursive; fun_name; param; ret_type; block_with; ret
let%bind func = match kwd_recursive with
Some reg ->
let%bind fun_type = trace_option (untyped_recursive_fun loc) @@ fun_type in
ok @@ e_recursive_ez ~loc:(Location.lift reg) fun_name fun_type lambda
return @@ e_recursive_ez ~loc:(Location.lift reg) fun_name fun_type lambda
| None ->
ok @@ make_e ~loc @@ E_lambda lambda
return @@ make_e ~loc @@ E_lambda lambda
in
ok @@ (fun_name,fun_type, attr, func)
return (fun_name,fun_type, attr, func)
(* Currently attributes are badly proccess, some adaptation are made to accomodate this
maked as ATR *)
let compile_declaration : (CST.attr_decl option * _) -> CST.declaration -> _ = fun (attr, lst) decl ->
let return ?attr reg decl = ok @@ (attr, (Location.wrap ~loc:(Location.lift reg) decl)::lst) in (*ATR*)
let return ?attr reg decl =
return (attr, (Location.wrap ~loc:(Location.lift reg) decl)::lst) in (*ATR*)
match decl with
TypeDecl {value={name; type_expr; _};region} ->
(* Todo : if attr isn't none, send warning *)
@ -801,7 +798,7 @@ let compile_declaration : (CST.attr_decl option * _) -> CST.declaration -> _ = f
let value = {value with attributes = attr} in (*ATR*)
let%bind (fun_name,fun_type,attr,lambda) = compile_fun_decl value in
return region @@ AST.Declaration_constant (Var.of_name fun_name, fun_type, attr, lambda)
| AttrDecl decl -> ok @@ (Some decl, lst) (*ATR*)
| AttrDecl decl -> ok (Some decl, lst) (*ATR*)
(* This should be change to the commented function when attributes are fixed
let compile_program : CST.ast -> _ result = fun t ->
@ -812,4 +809,4 @@ let compile_program : CST.ast -> _ result =
let declarations = List.rev @@ nseq_to_list t.decl in
let attr = (None, []) in
let%bind (_, declarations) = bind_fold_list compile_declaration attr declarations in
ok @@ declarations
return declarations