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

197
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 r_split = Location.r_split
let return = ok
let rec compile_type_expression : CST.type_expr -> _ result = fun te -> let rec compile_type_expression : CST.type_expr -> _ result = fun te ->
let return te = ok @@ te in
match te with match te with
TSum sum -> TSum sum ->
let (nsepseq, loc) = r_split sum in 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 aux (field : CST.field_decl CST.reg) =
let (f, _) = r_split field in let (f, _) = r_split field in
let%bind type_expr = compile_type_expression f.field_type 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 in
let%bind record = bind_map_list aux lst in let%bind record = bind_map_list aux lst in
return @@ t_record_ez ~loc record return @@ t_record_ez ~loc record
@ -51,7 +52,7 @@ let rec compile_type_expression : CST.type_expr -> _ result = fun te ->
| _ -> None | _ -> None
in in
let ((operator,args), loc) = r_split app in let ((operator,args), loc) = r_split app in
(* this is a bad design, michelson_or and pair should be an operator (* this is a bad design, michelson_or and pair should be an operator
see AnnotType *) see AnnotType *)
(match operator.value with (match operator.value with
| "michelson_or" -> | "michelson_or" ->
@ -66,7 +67,7 @@ let rec compile_type_expression : CST.type_expr -> _ result = fun te ->
get_t_string_singleton_opt d in get_t_string_singleton_opt d in
let%bind a' = compile_type_expression a in let%bind a' = compile_type_expression a in
let%bind c' = compile_type_expression c 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) | _ -> fail @@ michelson_type_wrong_arity loc operator.value)
| "michelson_pair" -> | "michelson_pair" ->
@ -81,7 +82,7 @@ let rec compile_type_expression : CST.type_expr -> _ result = fun te ->
get_t_string_singleton_opt d in get_t_string_singleton_opt d in
let%bind a' = compile_type_expression a in let%bind a' = compile_type_expression a in
let%bind c' = compile_type_expression c 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) | _ -> fail @@ michelson_type_wrong_arity loc operator.value)
| _ -> | _ ->
@ -104,14 +105,14 @@ let rec compile_type_expression : CST.type_expr -> _ result = fun te ->
| TVar var -> | TVar var ->
let (name,loc) = r_split var in let (name,loc) = r_split var in
(match type_constants name with (match type_constants name with
Some const -> return @@ t_constant ~loc const Some const -> return @@ t_constant ~loc const
| None -> return @@ t_variable_ez ~loc name | None -> return @@ t_variable_ez ~loc name
) )
| TString _s -> fail @@ unsupported_string_singleton te | TString _s -> fail @@ unsupported_string_singleton te
let compile_selection (selection : CST.selection) = let compile_selection (selection : CST.selection) =
match selection with match selection with
FieldName name -> FieldName name ->
let (name, loc) = r_split name in let (name, loc) = r_split name in
(Access_record name, loc) (Access_record name, loc)
| Component comp -> | Component comp ->
@ -119,12 +120,11 @@ let compile_selection (selection : CST.selection) =
(Access_tuple index, loc) (Access_tuple index, loc)
let rec compile_expression : CST.expr -> (AST.expr , Errors_pascaligo.abs_error) result = fun e -> 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 compile_tuple_expression (tuple_expr : CST.tuple_expr) =
let (lst, loc) = r_split tuple_expr in let (lst, loc) = r_split tuple_expr in
let%bind lst = bind_map_list compile_expression @@ npseq_to_list lst.inside in let%bind lst = bind_map_list compile_expression @@ npseq_to_list lst.inside in
match lst with match lst with
hd::[] -> return @@ hd hd::[] -> return hd
| lst -> return @@ e_tuple ~loc lst | lst -> return @@ e_tuple ~loc lst
in in
let compile_path (path : CST.path) = let compile_path (path : CST.path) =
@ -153,7 +153,7 @@ let rec compile_expression : CST.expr -> (AST.expr , Errors_pascaligo.abs_error)
match e with match e with
EVar var -> EVar var ->
let (var, loc) = r_split var in let (var, loc) = r_split var in
(match constants var with (match constants var with
Some const -> return @@ e_constant ~loc const [] Some const -> return @@ e_constant ~loc const []
| None -> return @@ e_variable_ez ~loc var | None -> return @@ e_variable_ez ~loc var
) )
@ -187,7 +187,7 @@ let rec compile_expression : CST.expr -> (AST.expr , Errors_pascaligo.abs_error)
| Div slash -> compile_bin_op C_DIV slash | Div slash -> compile_bin_op C_DIV slash
| Mod mod_ -> compile_bin_op C_MOD mod_ | Mod mod_ -> compile_bin_op C_MOD mod_
| Neg minus -> compile_un_op C_NEG minus | Neg minus -> compile_un_op C_NEG minus
| Int i -> | Int i ->
let ((_,i), loc) = r_split i in let ((_,i), loc) = r_split i in
return @@ e_int_z ~loc i return @@ e_int_z ~loc i
| Nat n -> | Nat n ->
@ -208,7 +208,7 @@ let rec compile_expression : CST.expr -> (AST.expr , Errors_pascaligo.abs_error)
| False reg -> let loc = Location.lift reg in return @@ e_false ~loc () | False reg -> let loc = Location.lift reg in return @@ e_false ~loc ()
) )
| CompExpr ce -> ( | CompExpr ce -> (
match ce with match ce with
Lt lt -> compile_bin_op C_LT lt Lt lt -> compile_bin_op C_LT lt
| Leq le -> compile_bin_op C_LE le | Leq le -> compile_bin_op C_LE le
| Gt gt -> compile_bin_op C_GT gt | Gt gt -> compile_bin_op C_GT gt
@ -222,7 +222,7 @@ let rec compile_expression : CST.expr -> (AST.expr , Errors_pascaligo.abs_error)
| ECall {value=(EVar var,args);region} -> | ECall {value=(EVar var,args);region} ->
let loc = Location.lift region in let loc = Location.lift region in
let (var, loc_var) = r_split var in let (var, loc_var) = r_split var in
(match constants var with (match constants var with
Some const -> Some const ->
let (args, _) = r_split args in let (args, _) = r_split args in
let%bind args = bind_map_list compile_expression @@ npseq_to_list args.inside in let%bind args = bind_map_list compile_expression @@ npseq_to_list args.inside in
@ -241,15 +241,15 @@ let rec compile_expression : CST.expr -> (AST.expr , Errors_pascaligo.abs_error)
compile_tuple_expression lst compile_tuple_expression lst
| ERecord record -> | ERecord record ->
let (record, loc) = r_split record in let (record, loc) = r_split record in
let aux (fa : CST.field_assignment CST.reg) = let aux (fa : CST.field_assignment CST.reg) =
let (fa, _) = r_split fa in let (fa, _) = r_split fa in
let (name, _) = r_split fa.field_name in let (name, _) = r_split fa.field_name in
let%bind expr = compile_expression fa.field_expr in let%bind expr = compile_expression fa.field_expr in
ok @@ (name, expr) return (name, expr)
in in
let%bind record = bind_map_list aux @@ npseq_to_list record.ne_elements in let%bind record = bind_map_list aux @@ npseq_to_list record.ne_elements in
return @@ e_record_ez ~loc record return @@ e_record_ez ~loc record
| EProj proj -> | EProj proj ->
let (proj, loc) = r_split proj in let (proj, loc) = r_split proj in
let (var, _loc_var) = r_split proj.struct_name in let (var, _loc_var) = r_split proj.struct_name in
let var = e_variable_ez ~loc var in let var = e_variable_ez ~loc var in
@ -270,11 +270,11 @@ let rec compile_expression : CST.expr -> (AST.expr , Errors_pascaligo.abs_error)
let (path, _) = List.split @@ List.map compile_selection @@ npseq_to_list proj.field_path in let (path, _) = List.split @@ List.map compile_selection @@ npseq_to_list proj.field_path in
(Access_record proj.struct_name.value)::path (Access_record proj.struct_name.value)::path
) )
in in
ok @@ (path, expr, loc) return (path, expr, loc)
in in
let%bind updates = bind_map_list aux @@ npseq_to_list updates.ne_elements 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 let aux e (path, update, loc) = e_update ~loc e path update in
return @@ List.fold_left aux record updates return @@ List.fold_left aux record updates
| EFun func -> | EFun func ->
let compile_param (param : CST.param_decl) = let compile_param (param : CST.param_decl) =
@ -283,12 +283,12 @@ let rec compile_expression : CST.expr -> (AST.expr , Errors_pascaligo.abs_error)
let (p, _) = r_split p in let (p, _) = r_split p in
let (var, _loc) = r_split p.var in let (var, _loc) = r_split p.var in
let%bind p_type = bind_map_option (compile_type_expression <@ snd) p.param_type 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 -> | ParamVar p ->
let (p, _) = r_split p in let (p, _) = r_split p in
let (var, _loc) = r_split p.var in let (var, _loc) = r_split p.var in
let%bind p_type = bind_map_option (compile_type_expression <@ snd) p.param_type 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 in
let (func, loc) = r_split func in let (func, loc) = r_split func in
let (param, loc_par) = r_split func.param in let (param, loc_par) = r_split func.param in
@ -297,7 +297,7 @@ let rec compile_expression : CST.expr -> (AST.expr , Errors_pascaligo.abs_error)
let%bind ret_type = bind_map_option (compile_type_expression <@ snd )func.ret_type in let%bind ret_type = bind_map_option (compile_type_expression <@ snd )func.ret_type in
let%bind body = compile_expression func.return in let%bind body = compile_expression func.return in
let (lambda, fun_type) = match param_type with let (lambda, fun_type) = match param_type with
ty::[] -> ty::[] ->
e_lambda ~loc (Var.of_name @@ List.hd param) ty ret_type body, e_lambda ~loc (Var.of_name @@ List.hd param) ty ret_type body,
Option.map (fun (a,b) -> t_function a b)@@ Option.bind_pair (ty,ret_type) Option.map (fun (a,b) -> t_function a b)@@ Option.bind_pair (ty,ret_type)
(* Cannot be empty *) (* Cannot be empty *)
@ -305,7 +305,7 @@ let rec compile_expression : CST.expr -> (AST.expr , Errors_pascaligo.abs_error)
let lst = Option.bind_list lst in let lst = Option.bind_list lst in
let input_type = Option.map t_tuple lst in let input_type = Option.map t_tuple lst in
let binder = Var.fresh ~name:"parameter" () in let binder = Var.fresh ~name:"parameter" () in
e_lambda ~loc binder input_type (ret_type) @@ e_lambda ~loc binder input_type (ret_type) @@
e_matching_tuple_ez ~loc:loc_par (e_variable binder) param lst body, e_matching_tuple_ez ~loc:loc_par (e_variable binder) param lst body,
Option.map (fun (a,b) -> t_function a b)@@ Option.bind_pair (input_type,ret_type) Option.map (fun (a,b) -> t_function a b)@@ Option.bind_pair (input_type,ret_type)
in in
@ -317,7 +317,7 @@ let rec compile_expression : CST.expr -> (AST.expr , Errors_pascaligo.abs_error)
return @@ e_some ~loc args return @@ e_some ~loc args
| EConstr (NoneExpr reg) -> | EConstr (NoneExpr reg) ->
let loc = Location.lift reg in let loc = Location.lift reg in
return @@ e_none ~loc () return @@ e_none ~loc ()
| EConstr (ConstrApp constr) -> | EConstr (ConstrApp constr) ->
let ((constr,args_o), loc) = r_split constr in let ((constr,args_o), loc) = r_split constr in
let%bind args_o = bind_map_option compile_tuple_expression args_o in let%bind args_o = bind_map_option compile_tuple_expression args_o in
@ -341,8 +341,8 @@ let rec compile_expression : CST.expr -> (AST.expr , Errors_pascaligo.abs_error)
let%bind then_clause = compile_expression cond.ifso in let%bind then_clause = compile_expression cond.ifso in
let%bind else_clause = compile_expression cond.ifnot in let%bind else_clause = compile_expression cond.ifnot in
return @@ e_cond ~loc test then_clause else_clause return @@ e_cond ~loc test then_clause else_clause
| EList lst -> ( | EList lst -> (
match lst with match lst with
ECons cons -> ECons cons ->
let (cons, loc) = r_split cons in let (cons, loc) = r_split cons in
let%bind a = compile_expression cons.arg1 in let%bind a = compile_expression cons.arg1 in
@ -356,7 +356,7 @@ let rec compile_expression : CST.expr -> (AST.expr , Errors_pascaligo.abs_error)
in in
let%bind lst = bind_map_list compile_expression lst in let%bind lst = bind_map_list compile_expression lst in
return @@ e_list ~loc lst return @@ e_list ~loc lst
| ENil nil -> | ENil nil ->
let loc = Location.lift nil in let loc = Location.lift nil in
return @@ e_list ~loc [] return @@ e_list ~loc []
(* Is seems that either ENil is redondant or EListComp should be an nsepseq and not a sepseq *) (* Is seems that either ENil is redondant or EListComp should be an nsepseq and not a sepseq *)
@ -368,7 +368,7 @@ let rec compile_expression : CST.expr -> (AST.expr , Errors_pascaligo.abs_error)
let set = let set =
Option.unopt ~default:[] @@ Option.unopt ~default:[] @@
Option.map npseq_to_list si.elements Option.map npseq_to_list si.elements
in in
let%bind set = bind_map_list compile_expression set in let%bind set = bind_map_list compile_expression set in
return @@ e_set ~loc set return @@ e_set ~loc set
| SetMem sm -> | SetMem sm ->
@ -394,7 +394,7 @@ let rec compile_expression : CST.expr -> (AST.expr , Errors_pascaligo.abs_error)
let (binding, _) = r_split binding in let (binding, _) = r_split binding in
let%bind key = compile_expression binding.source in let%bind key = compile_expression binding.source in
let%bind value = compile_expression binding.image in let%bind value = compile_expression binding.image in
ok @@ (key,value) return (key,value)
in in
let%bind map = bind_map_list aux lst in let%bind map = bind_map_list aux lst in
return @@ e_map ~loc map 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 (binding, _) = r_split binding in
let%bind key = compile_expression binding.source in let%bind key = compile_expression binding.source in
let%bind value = compile_expression binding.image in let%bind value = compile_expression binding.image in
ok @@ (key,value) return (key,value)
in in
let%bind map = bind_map_list aux lst in let%bind map = bind_map_list aux lst in
return @@ e_big_map ~loc map return @@ e_big_map ~loc map
@ -420,58 +420,56 @@ 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 -> _ = and compile_matching_expr : type a.(a -> _ result) -> a CST.case_clause CST.reg List.Ne.t -> _ =
fun compiler cases -> fun compiler cases ->
let compile_pattern pattern = ok @@ pattern let compile_pattern pattern = return pattern in
in
let return e = ok @@ e in
let compile_simple_pattern (pattern : CST.pattern) = let compile_simple_pattern (pattern : CST.pattern) =
match pattern with match pattern with
PVar var -> PVar var ->
let (var, _) = r_split var in let (var, _) = r_split var in
ok @@ Var.of_name var return @@ Var.of_name var
| _ -> fail @@ unsupported_non_var_pattern pattern | _ -> fail @@ unsupported_non_var_pattern pattern
in in
let compile_list_pattern (cases : (CST.pattern * _) list) = let compile_list_pattern (cases : (CST.pattern * _) list) =
match cases with match cases with
[(PList PNil _, match_nil);(PList PCons cons, econs)] [(PList PNil _, match_nil);(PList PCons cons, econs)]
| [(PList PCons cons, econs);(PList PNil _, match_nil)] -> | [(PList PCons cons, econs);(PList PNil _, match_nil)] ->
let (cons,_) = r_split cons in let (cons,_) = r_split cons in
let%bind (hd,tl) = match snd @@ List.split (snd cons) with 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 | _ -> fail @@ unsupported_deep_list_patterns @@ fst cons
in in
let%bind (hd,tl) = bind_map_pair compile_simple_pattern (hd,tl) in let%bind (hd,tl) = bind_map_pair compile_simple_pattern (hd,tl) in
let match_cons = (hd,tl,econs) 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 | _ -> fail @@ unsupported_deep_list_patterns @@ fst @@ List.hd cases
in in
let compile_simple_tuple_pattern (tuple : CST.tuple_pattern) = let compile_simple_tuple_pattern (tuple : CST.tuple_pattern) =
let (lst, _) = r_split tuple in let (lst, _) = r_split tuple in
match lst.inside with match lst.inside with
hd,[] -> compile_simple_pattern hd hd,[] -> compile_simple_pattern hd
| _ -> fail @@ unsupported_deep_tuple_patterns tuple | _ -> fail @@ unsupported_deep_tuple_patterns tuple
in in
let compile_constr_pattern (constr : CST.pattern) = let compile_constr_pattern (constr : CST.pattern) =
match constr with match constr with
PConstr c -> PConstr c ->
( match c with ( match c with
PUnit _ -> PUnit _ ->
fail @@ unsupported_pattern_type constr fail @@ unsupported_pattern_type constr
| PFalse _ -> ok @@ (Constructor "false", Var.of_name "_") | PFalse _ -> return (Constructor "false", Var.of_name "_")
| PTrue _ -> ok @@ (Constructor "true", Var.of_name "_") | PTrue _ -> return (Constructor "true", Var.of_name "_")
| PNone _ -> ok @@ (Constructor "None", Var.of_name "_") | PNone _ -> return (Constructor "None", Var.of_name "_")
| PSomeApp some -> | PSomeApp some ->
let (some,_) = r_split some in let (some,_) = r_split some in
let (_, pattern) = some in let (_, pattern) = some in
let (pattern,_) = r_split pattern in let (pattern,_) = r_split pattern in
let%bind pattern = compile_simple_pattern pattern.inside in let%bind pattern = compile_simple_pattern pattern.inside in
ok @@ (Constructor "Some", pattern) return (Constructor "Some", pattern)
| PConstrApp constr -> | PConstrApp constr ->
let (constr, _) = r_split constr in let (constr, _) = r_split constr in
let (constr, patterns) = constr in let (constr, patterns) = constr in
let (constr, _) = r_split constr in let (constr, _) = r_split constr in
let%bind pattern = bind_map_option compile_simple_tuple_pattern patterns in let%bind pattern = bind_map_option compile_simple_tuple_pattern patterns in
let pattern = Option.unopt ~default:(Var.of_name "_") pattern in let pattern = Option.unopt ~default:(Var.of_name "_") pattern in
ok (Constructor constr, pattern) return (Constructor constr, pattern)
) )
| _ -> fail @@ unsupported_pattern_type constr | _ -> fail @@ unsupported_pattern_type constr
in in
@ -479,7 +477,7 @@ fun compiler cases ->
let (case, _loc) = r_split case in let (case, _loc) = r_split case in
let%bind pattern = compile_pattern case.pattern in let%bind pattern = compile_pattern case.pattern in
let%bind expr = compiler case.rhs in let%bind expr = compiler case.rhs in
ok (pattern, expr) return (pattern, expr)
in in
let%bind cases = bind_map_ne_list aux cases in let%bind cases = bind_map_ne_list aux cases in
match cases with match cases with
@ -489,19 +487,18 @@ fun compiler cases ->
return @@ AST.Match_variable (var, None, expr) return @@ AST.Match_variable (var, None, expr)
| (PTuple tuple, _expr), [] -> | (PTuple tuple, _expr), [] ->
fail @@ unsupported_tuple_pattern @@ CST.PTuple tuple fail @@ unsupported_tuple_pattern @@ CST.PTuple tuple
| (PList _, _), _ -> | (PList _, _), _ ->
let%bind (match_nil,match_cons) = compile_list_pattern @@ List.Ne.to_list cases in let%bind (match_nil,match_cons) = compile_list_pattern @@ List.Ne.to_list cases in
return @@ AST.Match_list {match_nil;match_cons} return @@ AST.Match_list {match_nil;match_cons}
| (PConstr _,_), _ -> | (PConstr _,_), _ ->
let (pattern, lst) = List.split @@ List.Ne.to_list cases in let (pattern, lst) = List.split @@ List.Ne.to_list cases in
let%bind constrs = bind_map_list compile_constr_pattern pattern in let%bind constrs = bind_map_list compile_constr_pattern pattern in
return @@ AST.Match_variant (List.combine constrs lst) return @@ AST.Match_variant (List.combine constrs lst)
| (p, _), _ -> fail @@ unsupported_pattern_type p | (p, _), _ -> fail @@ unsupported_pattern_type p
let compile_attribute_declaration attributes = let compile_attribute_declaration = function
match attributes with None -> return false
None -> ok @@ false | Some _ -> return true
| Some _ -> ok @@ true
let compile_parameters (params : CST.parameters) = let compile_parameters (params : CST.parameters) =
let compile_param_decl (param : CST.param_decl) = let compile_param_decl (param : CST.param_decl) =
@ -510,38 +507,38 @@ let compile_parameters (params : CST.parameters) =
let (pc, _loc) = r_split pc in let (pc, _loc) = r_split pc in
let (var, _) = r_split pc.var in let (var, _) = r_split pc.var in
let%bind param_type = bind_map_option (compile_type_expression <@ snd) pc.param_type 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 -> | ParamVar pv ->
let (pv, _loc) = r_split pv in let (pv, _loc) = r_split pv in
let (var, _) = r_split pv.var in let (var, _) = r_split pv.var in
let%bind param_type = bind_map_option (compile_type_expression <@ snd) pv.param_type 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 in
let (params, _loc) = r_split params in let (params, _loc) = r_split params in
let params = npseq_to_list params.inside in let params = npseq_to_list params.inside in
bind_map_list compile_param_decl params bind_map_list compile_param_decl params
let rec compile_instruction : ?next: AST.expression -> CST.instruction -> _ result = fun ?next instruction -> let rec compile_instruction : ?next: AST.expression -> CST.instruction -> _ result = fun ?next instruction ->
let return expr = match next with let return expr = match next with
Some e -> ok @@ e_sequence expr e Some e -> return @@ e_sequence expr e
| None -> ok @@ expr | None -> return expr
in in
let compile_tuple_expression (tuple_expr : CST.tuple_expr) = let compile_tuple_expression (tuple_expr : CST.tuple_expr) =
let (lst, loc) = r_split tuple_expr in let (lst, loc) = r_split tuple_expr in
let%bind lst = bind_map_list compile_expression @@ npseq_to_list lst.inside in let%bind lst = bind_map_list compile_expression @@ npseq_to_list lst.inside in
match lst with match lst with
hd::[] -> ok @@ hd hd::[] -> return hd
| lst -> ok @@ e_tuple ~loc lst | lst -> return @@ e_tuple ~loc lst
in in
let compile_if_clause : ?next:AST.expression -> CST.if_clause -> _ = fun ?next if_clause -> let compile_if_clause : ?next:AST.expression -> CST.if_clause -> _ = fun ?next if_clause ->
match if_clause with match if_clause with
ClauseInstr i -> compile_instruction ?next i ClauseInstr i -> compile_instruction ?next i
| ClauseBlock (LongBlock block) -> compile_block ?next block | ClauseBlock (LongBlock block) -> compile_block ?next block
| ClauseBlock (ShortBlock block) -> | ClauseBlock (ShortBlock block) ->
(* This looks like it should be the job of the parser *) (* This looks like it should be the job of the parser *)
let CST.{lbrace; inside; rbrace} = block.value in let CST.{lbrace; inside; rbrace} = block.value in
let region = block.region in let region = block.region in
let enclosing = CST.Block (Region.ghost, lbrace, rbrace) let enclosing = CST.Block (Region.ghost, lbrace, rbrace)
and (statements,terminator) = inside in and (statements,terminator) = inside in
let value = CST.{enclosing;statements;terminator} in let value = CST.{enclosing;statements;terminator} in
let block : _ CST.reg = {value; region} in let block : _ CST.reg = {value; region} in
@ -549,18 +546,18 @@ let rec compile_instruction : ?next: AST.expression -> CST.instruction -> _ resu
in in
let compile_path : CST.path -> _ = fun path -> let compile_path : CST.path -> _ = fun path ->
match path with match path with
Name var -> Name var ->
let (var,loc) = r_split var in let (var,loc) = r_split var in
let str = e_variable_ez ~loc var in let str = e_variable_ez ~loc var in
ok @@ (str, var, []) ok (str, var, [])
| Path proj -> | Path proj ->
let (proj, loc) = r_split proj in let (proj, loc) = r_split proj in
let (var, loc_var) = r_split proj.struct_name 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.map compile_selection @@ npseq_to_list proj.field_path in
let (path, _) = List.split path in let (path, _) = List.split path in
let str = e_accessor ~loc (e_variable_ez ~loc:loc_var var) 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 in
let compile_lhs : CST.lhs -> _ = fun lhs -> let compile_lhs : CST.lhs -> _ = fun lhs ->
match lhs with match lhs with
@ -601,20 +598,20 @@ let rec compile_instruction : ?next: AST.expression -> CST.instruction -> _ resu
let (binder, _) = r_split fl.binder in let (binder, _) = r_split fl.binder in
let%bind start = compile_expression fl.init in let%bind start = compile_expression fl.init in
let%bind bound = compile_expression fl.bound in let%bind bound = compile_expression fl.bound in
let%bind increment = Option.unopt ~default:(ok @@ e_int_z Z.one) @@ let%bind increment = Option.unopt ~default:(ok @@ e_int_z Z.one) @@
Option.map (compile_expression <@ snd) fl.step Option.map (compile_expression <@ snd) fl.step
in in
let%bind body = compile_block fl.block in let%bind body = compile_block fl.block in
return @@ e_for_ez ~loc binder start bound increment body return @@ e_for_ez ~loc binder start bound increment body
| Loop (For (ForCollect el)) -> | Loop (For (ForCollect el)) ->
let (el, loc) = r_split el in let (el, loc) = r_split el in
let binder = let binder =
let (key, _) = r_split el.var in let (key, _) = r_split el.var in
let value = Option.map (fun x -> fst (r_split (snd x))) el.bind_to in let value = Option.map (fun x -> fst (r_split (snd x))) el.bind_to in
(key,value) (key,value)
in in
let%bind collection = compile_expression el.expr in let%bind collection = compile_expression el.expr in
let (collection_type, _) = match el.collection with let (collection_type, _) = match el.collection with
Map loc -> (Map, loc) | Set loc -> (Set, loc) | List loc -> (List, loc) Map loc -> (Map, loc) | Set loc -> (Set, loc) | List loc -> (List, loc)
in in
let%bind body = compile_block el.block in let%bind body = compile_block el.block in
@ -622,7 +619,7 @@ let rec compile_instruction : ?next: AST.expression -> CST.instruction -> _ resu
| ProcCall {value=(EVar var,args);region} -> | ProcCall {value=(EVar var,args);region} ->
let loc = Location.lift region in let loc = Location.lift region in
let (var, loc_var) = r_split var in let (var, loc_var) = r_split var in
(match constants var with (match constants var with
Some const -> Some const ->
let (args, _) = r_split args in let (args, _) = r_split args in
let%bind args = bind_map_list compile_expression @@ npseq_to_list args.inside in let%bind args = bind_map_list compile_expression @@ npseq_to_list args.inside in
@ -638,7 +635,7 @@ let rec compile_instruction : ?next: AST.expression -> CST.instruction -> _ resu
let%bind func = compile_expression func in let%bind func = compile_expression func in
let%bind args = compile_tuple_expression args in let%bind args = compile_tuple_expression args in
return @@ e_application ~loc func args return @@ e_application ~loc func args
| Skip s -> | Skip s ->
let loc = Location.lift s in let loc = Location.lift s in
return @@ e_skip ~loc () return @@ e_skip ~loc ()
| RecordPatch rp -> | RecordPatch rp ->
@ -697,7 +694,7 @@ and compile_data_declaration : next:AST.expression -> ?attr:CST.attr_decl -> CST
ok @@ e_let_in_ez ~loc name type_ attr init next in ok @@ e_let_in_ez ~loc name type_ attr init next in
match data_decl with match data_decl with
LocalConst const_decl -> LocalConst const_decl ->
let (cd, loc) = r_split const_decl in let (cd, loc) = r_split const_decl in
let (name, _) = r_split cd.name in let (name, _) = r_split cd.name in
let%bind type_ = bind_map_option (compile_type_expression <@ snd)cd.const_type in let%bind type_ = bind_map_option (compile_type_expression <@ snd)cd.const_type in
let%bind init = compile_expression cd.init in let%bind init = compile_expression cd.init in
@ -715,41 +712,40 @@ and compile_data_declaration : next:AST.expression -> ?attr:CST.attr_decl -> CST
and compile_statement : ?next:AST.expression -> CST.attr_decl option -> CST.statement -> _ result = fun ?next attr statement -> and compile_statement : ?next:AST.expression -> CST.attr_decl option -> CST.statement -> _ result = fun ?next attr statement ->
match statement with match statement with
Instr i -> Instr i ->
let%bind i = compile_instruction ?next i in let%bind i = compile_instruction ?next i in
ok @@ (Some i, None) return (Some i, None)
| Data dd -> | Data dd ->
let next = Option.unopt ~default:(e_skip ()) next in let next = Option.unopt ~default:(e_skip ()) next in
let%bind dd = compile_data_declaration ~next ?attr dd in let%bind dd = compile_data_declaration ~next ?attr dd in
ok @@ (Some dd, None) return (Some dd, None)
| Attr at -> ok @@ (next, Some at) | Attr at -> return (next, Some at)
and compile_block : ?next:AST.expression -> CST.block CST.reg -> _ result = fun ?next block -> and compile_block : ?next:AST.expression -> CST.block CST.reg -> _ result = fun ?next block ->
let (block', _loc) = r_split block in let (block', _loc) = r_split block in
let statements = npseq_to_list block'.statements in let statements = npseq_to_list block'.statements in
let aux (next,attr) statement = let aux (next,attr) statement =
let%bind (statement, attr) = compile_statement ?next attr statement in let%bind (statement, attr) = compile_statement ?next attr statement in
ok @@ (statement,attr) return (statement,attr)
in in
let%bind (block', _) = bind_fold_right_list aux (next,None) statements in let%bind (block', _) = bind_fold_right_list aux (next,None) statements in
match block' with match block' with
Some block -> ok @@ block Some block -> return block
| None -> fail @@ block_start_with_attribute 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) = and compile_fun_decl ({kwd_recursive; fun_name; param; ret_type; block_with; return=r; attributes}: CST.fun_decl) =
let%bind attr = compile_attribute_declaration attributes in let%bind attr = compile_attribute_declaration attributes in
let (fun_name, loc) = r_split fun_name in let (fun_name, loc) = r_split fun_name in
let%bind ret_type = bind_map_option (compile_type_expression <@ snd) ret_type in let%bind ret_type = bind_map_option (compile_type_expression <@ snd) ret_type in
let%bind param = compile_parameters param in let%bind param = compile_parameters param in
let%bind r = compile_expression r in let%bind r = compile_expression r in
let (param, param_type) = List.split param 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 Option.map (compile_block ~next:r <@ fst) block_with
in in
(* This handle the parameter case *) (* This handle the parameter case *)
let (lambda,fun_type) = (match param_type with let (lambda,fun_type) = (match param_type with
ty::[] -> ty::[] ->
let lambda : AST.lambda = { let lambda : AST.lambda = {
binder = (Var.of_name @@ List.hd param); binder = (Var.of_name @@ List.hd param);
input_type = ty ; input_type = ty ;
@ -772,18 +768,19 @@ and compile_fun_decl ({kwd_recursive; fun_name; param; ret_type; block_with; ret
in in
(* This handle the recursion *) (* This handle the recursion *)
let%bind func = match kwd_recursive with let%bind func = match kwd_recursive with
Some reg -> Some reg ->
let%bind fun_type = trace_option (untyped_recursive_fun loc) @@ fun_type in 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 -> | None ->
ok @@ make_e ~loc @@ E_lambda lambda return @@ make_e ~loc @@ E_lambda lambda
in 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 (* Currently attributes are badly proccess, some adaptation are made to accomodate this
maked as ATR *) maked as ATR *)
let compile_declaration : (CST.attr_decl option * _) -> CST.declaration -> _ = fun (attr, lst) decl -> 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 match decl with
TypeDecl {value={name; type_expr; _};region} -> TypeDecl {value={name; type_expr; _};region} ->
(* Todo : if attr isn't none, send warning *) (* Todo : if attr isn't none, send warning *)
@ -801,8 +798,8 @@ let compile_declaration : (CST.attr_decl option * _) -> CST.declaration -> _ = f
let value = {value with attributes = attr} in (*ATR*) let value = {value with attributes = attr} in (*ATR*)
let%bind (fun_name,fun_type,attr,lambda) = compile_fun_decl value in 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) 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 (* This should be change to the commented function when attributes are fixed
let compile_program : CST.ast -> _ result = fun t -> let compile_program : CST.ast -> _ result = fun t ->
bind_map_list compile_declaration @@ nseq_to_list t.decl bind_map_list compile_declaration @@ nseq_to_list t.decl
@ -812,4 +809,4 @@ let compile_program : CST.ast -> _ result =
let declarations = List.rev @@ nseq_to_list t.decl in let declarations = List.rev @@ nseq_to_list t.decl in
let attr = (None, []) in let attr = (None, []) in
let%bind (_, declarations) = bind_fold_list compile_declaration attr declarations in let%bind (_, declarations) = bind_fold_list compile_declaration attr declarations in
ok @@ declarations return declarations