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

Refactor updates and accessors

Browse Source
This commit is contained in:
Pierre-Emmanuel Wulfman 2020-06-05 17:45:11 +02:00
parent 5896b2a63a
commit be9478bec1
24 changed files with 2756 additions and 2815 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/passes/01-parser/cameligo/AST.ml
View File

@ -344,7 +344,7 @@ and update = {
} }
and field_path_assign = { and field_path_assign = {
field_path : (field_name, dot) nsepseq; field_path : (selection, dot) nsepseq;
assignment : equal; assignment : equal;
field_expr : expr field_expr : expr
} }

4
src/passes/01-parser/cameligo/Parser.mly
View File

@ -650,8 +650,8 @@ update_record:
in {region; value} } in {region; value} }
field_path_assignment : field_path_assignment :
nsepseq(field_name,".") "=" expr { nsepseq(selection,".") "=" expr {
let start = nsepseq_to_region (fun x -> x.region) $1 in let start = nsepseq_to_region selection_to_region $1 in
let region = cover start (expr_to_region $3) in let region = cover start (expr_to_region $3) in
let value = {field_path = $1; let value = {field_path = $1;
assignment = $2; assignment = $2;

4
src/passes/01-parser/cameligo/ParserLog.ml
View File

@ -527,7 +527,7 @@ and print_field_assign state {value; _} =
and print_field_path_assign state {value; _} = and print_field_path_assign state {value; _} =
let {field_path; assignment; field_expr} = value in let {field_path; assignment; field_expr} = value in
print_nsepseq state "." print_var field_path; print_nsepseq state "." print_selection field_path;
print_token state assignment "="; print_token state assignment "=";
print_expr state field_expr print_expr state field_expr
@ -965,7 +965,7 @@ and pp_field_assign state {value; _} =
and pp_field_path_assign state {value; _} = and pp_field_path_assign state {value; _} =
pp_node state "<field path for update>"; pp_node state "<field path for update>";
let path = Utils.nsepseq_to_list value.field_path in let path = Utils.nsepseq_to_list value.field_path in
List.iter (pp_ident (state#pad 2 0)) path; List.iter (pp_selection (state#pad 2 0)) path;
pp_expr (state#pad 2 1) value.field_expr pp_expr (state#pad 2 1) value.field_expr
and pp_constr_expr state = function and pp_constr_expr state = function

2315
src/passes/01-parser/cameligo/error.messages.checked-in
View File

File diff suppressed because it is too large Load Diff

2
src/passes/01-parser/pascaligo/AST.ml
View File

@ -590,7 +590,7 @@ and update = {
} }
and field_path_assign = { and field_path_assign = {
field_path : (field_name, dot) nsepseq; field_path : (selection, dot) nsepseq;
equal : equal; equal : equal;
field_expr : expr field_expr : expr
} }

4
src/passes/01-parser/pascaligo/Parser.mly
View File

@ -987,8 +987,8 @@ field_assignment:
in {region; value} } in {region; value} }
field_path_assignment: field_path_assignment:
nsepseq(field_name,".") "=" expr { nsepseq(selection,".") "=" expr {
let start = nsepseq_to_region (fun x -> x.region) $1 let start = nsepseq_to_region selection_to_region $1
and stop = expr_to_region $3 in and stop = expr_to_region $3 in
let region = cover start stop let region = cover start stop
and value = {field_path=$1; equal=$2; field_expr=$3} and value = {field_path=$1; equal=$2; field_expr=$3}

4
src/passes/01-parser/pascaligo/ParserLog.ml
View File

@ -619,7 +619,7 @@ and print_field_assign state {value; _} =
and print_field_path_assign state {value; _} = and print_field_path_assign state {value; _} =
let {field_path; equal; field_expr} = value in let {field_path; equal; field_expr} = value in
print_nsepseq state "field_path" print_var field_path; print_nsepseq state "field_path" print_selection field_path;
print_token state equal "="; print_token state equal "=";
print_expr state field_expr print_expr state field_expr
@ -1353,7 +1353,7 @@ and pp_field_assign state {value; _} =
and pp_field_path_assign state {value; _} = and pp_field_path_assign state {value; _} =
pp_node state "<field path for update>"; pp_node state "<field path for update>";
let path = Utils.nsepseq_to_list value.field_path in let path = Utils.nsepseq_to_list value.field_path in
List.iter (pp_ident (state#pad 2 0)) path; List.iter (pp_selection (state#pad 2 0)) path;
pp_expr (state#pad 2 1) value.field_expr pp_expr (state#pad 2 1) value.field_expr
and pp_map_patch state patch = and pp_map_patch state patch =

2479
src/passes/01-parser/pascaligo/error.messages.checked-in
View File

File diff suppressed because it is too large Load Diff

27
src/passes/01-parser/reasonligo/Parser.mly
View File

@ -1012,19 +1012,28 @@ field_assignment:
field_expr = $3} field_expr = $3}
in {region; value} } in {region; value} }
real_selection:
field_name { FieldName $1 }
| "<int>" { Component $1 }
field_path_assignment: field_path_assignment:
field_name { real_selection {
let value = { let region = selection_to_region $1
and value = {
field_path = ($1,[]); field_path = ($1,[]);
assignment = ghost; assignment = ghost;
field_expr = EVar $1 } field_expr = match $1 with
in {$1 with value} FieldName var -> EVar var
| Component {value;region} ->
let value = Z.to_string (snd value) in
EVar {value;region} }
in {region; value}
} }
| nsepseq(field_name,".") ":" expr { | nsepseq(real_selection,".") ":" expr {
let start = nsepseq_to_region (fun x -> x.region) $1 in let start = nsepseq_to_region selection_to_region $1
let stop = expr_to_region $3 in and stop = expr_to_region $3 in
let region = cover start stop in let region = cover start stop
let value = { and value = {
field_path = $1; field_path = $1;
assignment = $2; assignment = $2;
field_expr = $3} field_expr = $3}

24
src/passes/01-parser/reasonligo/error.messages.checked-in
View File

@ -2135,18 +2135,6 @@ interactive_expr: Switch WILD LBRACE VBAR WILD COMMA VBAR
<YOUR SYNTAX ERROR MESSAGE HERE> <YOUR SYNTAX ERROR MESSAGE HERE>
interactive_expr: Switch WILD LBRACE VBAR WILD COMMA WILD COMMA VBAR
##
## Ends in an error in state: 331.
##
## nsepseq(sub_pattern,COMMA) -> sub_pattern COMMA . nsepseq(sub_pattern,COMMA) [ RPAR ARROW ]
##
## The known suffix of the stack is as follows:
## sub_pattern COMMA
##
<YOUR SYNTAX ERROR MESSAGE HERE>
interactive_expr: Switch WILD LBRACE VBAR WILD COMMA WILD WILD interactive_expr: Switch WILD LBRACE VBAR WILD COMMA WILD WILD
## ##
## Ends in an error in state: 330. ## Ends in an error in state: 330.
@ -2160,6 +2148,18 @@ interactive_expr: Switch WILD LBRACE VBAR WILD COMMA WILD WILD
<YOUR SYNTAX ERROR MESSAGE HERE> <YOUR SYNTAX ERROR MESSAGE HERE>
interactive_expr: Switch WILD LBRACE VBAR WILD COMMA WILD COMMA VBAR
##
## Ends in an error in state: 336.
##
## nsepseq(sub_pattern,COMMA) -> sub_pattern COMMA . nsepseq(sub_pattern,COMMA) [ RPAR ARROW ]
##
## The known suffix of the stack is as follows:
## sub_pattern COMMA
##
<YOUR SYNTAX ERROR MESSAGE HERE>
interactive_expr: Switch WILD LBRACE VBAR WILD WILD interactive_expr: Switch WILD LBRACE VBAR WILD WILD
## ##
## Ends in an error in state: 430. ## Ends in an error in state: 430.

42
src/passes/02-concrete_to_imperative/cameligo.ml
View File

@ -343,26 +343,25 @@ let rec compile_expression :
let path' = let path' =
let aux (s:Raw.selection) = let aux (s:Raw.selection) =
match s with match s with
FieldName property -> property.value FieldName property -> Access_record property.value
| Component index -> Z.to_string (snd index.value) | Component index -> Access_tuple (snd index.value)
in in
List.map aux @@ npseq_to_list path in List.map aux @@ npseq_to_list path in
return @@ List.fold_left (e_record_accessor ~loc ) var path' return @@ e_accessor ~loc var path'
in in
let compile_path : Raw.path -> string * label list = fun p -> let compile_selection : Raw.selection -> access = fun s ->
match s with
| FieldName property -> Access_record property.value
| Component index -> (Access_tuple (snd index.value))
in
let compile_path : Raw.path -> string * access list = fun p ->
match p with match p with
| Raw.Name v -> (v.value , []) | Raw.Name v -> (v.value , [])
| Raw.Path p -> ( | Raw.Path p -> (
let p' = p.value in let p' = p.value in
let var = p'.struct_name.value in let var = p'.struct_name.value in
let path = p'.field_path in let path = p'.field_path in
let path' = let path' = List.map compile_selection @@ npseq_to_list path in
let aux (s:Raw.selection) =
match s with
| FieldName property -> Label property.value
| Component index -> Label (Z.to_string (snd index.value))
in
List.map aux @@ npseq_to_list path in
(var , path') (var , path')
) )
in in
@ -371,30 +370,19 @@ let rec compile_expression :
let (name, path) = compile_path u.record in let (name, path) = compile_path u.record in
let record = match path with let record = match path with
| [] -> e_variable (Var.of_name name) | [] -> e_variable (Var.of_name name)
| _ -> | _ -> e_accessor (e_variable (Var.of_name name)) path in
let aux expr (Label l) = e_record_accessor expr l in
List.fold_left aux (e_variable (Var.of_name name)) path in
let updates = u.updates.value.ne_elements in let updates = u.updates.value.ne_elements in
let%bind updates' = let%bind updates' =
let aux (f:Raw.field_path_assign Raw.reg) = let aux (f:Raw.field_path_assign Raw.reg) =
let (f,_) = r_split f in let (f,_) = r_split f in
let%bind expr = compile_expression f.field_expr in let%bind expr = compile_expression f.field_expr in
ok ( List.map (fun (x: _ Raw.reg) -> x.value) (npseq_to_list f.field_path), expr) ok ( List.map compile_selection (npseq_to_list f.field_path), expr)
in in
bind_map_list aux @@ npseq_to_list updates bind_map_list aux @@ npseq_to_list updates
in in
let aux ur (path, expr) = let aux ur (path, expr) = ok @@ e_update ~loc ur path expr in
let rec aux record = function
| [] -> failwith "error in parsing"
| hd :: [] -> ok @@ e_record_update ~loc record hd expr
| hd :: tl ->
let%bind expr = (aux (e_record_accessor ~loc record hd) tl) in
ok @@ e_record_update ~loc record hd expr
in
aux ur path in
bind_fold_list aux record updates' bind_fold_list aux record updates'
in in
trace (abstracting_expr t) @@ trace (abstracting_expr t) @@
match t with match t with
Raw.ELetIn e -> Raw.ELetIn e ->
@ -439,11 +427,11 @@ let rec compile_expression :
| hd :: [] -> | hd :: [] ->
if (List.length prep_vars = 1) if (List.length prep_vars = 1)
then e_let_in ~loc hd inline rhs_b_expr body then e_let_in ~loc hd inline rhs_b_expr body
else e_let_in ~loc hd inline (e_record_accessor ~loc rhs_b_expr (string_of_int ((List.length prep_vars) - 1))) body else e_let_in ~loc hd inline (e_accessor ~loc rhs_b_expr [Access_tuple (Z.of_int ((List.length prep_vars) - 1))]) body
| hd :: tl -> | hd :: tl ->
e_let_in ~loc hd e_let_in ~loc hd
inline inline
(e_record_accessor ~loc rhs_b_expr (string_of_int ((List.length prep_vars) - (List.length tl) - 1))) (e_accessor ~loc rhs_b_expr [Access_tuple (Z.of_int ((List.length prep_vars) - (List.length tl) - 1))])
(chain_let_in tl body) (chain_let_in tl body)
| [] -> body (* Precluded by corner case assertion above *) | [] -> body (* Precluded by corner case assertion above *)
in in

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

@ -271,11 +271,11 @@ let compile_projection : Raw.projection Region.reg -> _ = fun p ->
let path' = let path' =
let aux (s:Raw.selection) = let aux (s:Raw.selection) =
match s with match s with
| FieldName property -> property.value | FieldName property -> Access_record property.value
| Component index -> (Z.to_string (snd index.value)) | Component index -> (Access_tuple (snd index.value))
in in
List.map aux @@ npseq_to_list path in List.map aux @@ npseq_to_list path in
ok @@ List.fold_left (e_record_accessor ~loc) var path' ok @@ e_accessor ~loc var path'
let rec compile_expression (t:Raw.expr) : expr result = let rec compile_expression (t:Raw.expr) : expr result =
@ -451,7 +451,7 @@ let rec compile_expression (t:Raw.expr) : expr result =
| Path p -> compile_projection p | Path p -> compile_projection p
in in
let%bind index = compile_expression lu.index.value.inside in let%bind index = compile_expression lu.index.value.inside in
return @@ e_look_up ~loc path index return @@ e_accessor ~loc path [Access_map index]
) )
| EFun f -> | EFun f ->
let (f , loc) = r_split f in let (f , loc) = r_split f in
@ -464,25 +464,17 @@ and compile_update = fun (u:Raw.update Region.reg) ->
let (name, path) = compile_path u.record in let (name, path) = compile_path u.record in
let record = match path with let record = match path with
| [] -> e_variable (Var.of_name name) | [] -> e_variable (Var.of_name name)
| _ -> e_accessor_list (e_variable (Var.of_name name)) path in | _ -> e_accessor (e_variable (Var.of_name name)) path in
let updates = u.updates.value.ne_elements in let updates = u.updates.value.ne_elements in
let%bind updates' = let%bind updates' =
let aux (f:Raw.field_path_assign Raw.reg) = let aux (f:Raw.field_path_assign Raw.reg) =
let (f,_) = r_split f in let (f,_) = r_split f in
let%bind expr = compile_expression f.field_expr in let%bind expr = compile_expression f.field_expr in
ok ( List.map (fun (x: _ Raw.reg) -> x.value) (npseq_to_list f.field_path), expr) ok ( List.map compile_selection (npseq_to_list f.field_path), expr)
in in
bind_map_list aux @@ npseq_to_list updates bind_map_list aux @@ npseq_to_list updates
in in
let aux ur (path, expr) = let aux ur (path, expr) = ok @@ e_update ~loc ur path expr in
let rec aux record = function
| [] -> failwith "error in parsing"
| hd :: [] -> ok @@ e_record_update ~loc record hd expr
| hd :: tl ->
let%bind expr = (aux (e_record_accessor ~loc record hd) tl) in
ok @@ e_record_update ~loc record hd expr
in
aux ur path in
bind_fold_list aux record updates' bind_fold_list aux record updates'
and compile_logic_expression (t:Raw.logic_expr) : expression result = and compile_logic_expression (t:Raw.logic_expr) : expression result =
@ -668,7 +660,7 @@ and compile_fun_decl :
let%bind tpl_declarations = let%bind tpl_declarations =
let aux = fun i (param, type_expr) -> let aux = fun i (param, type_expr) ->
let expr = let expr =
e_record_accessor (e_variable arguments_name) (string_of_int i) in e_accessor (e_variable arguments_name) [Access_record (string_of_int i)] in
let type_variable = Some type_expr in let type_variable = Some type_expr in
let ass = return_let_in (Var.of_name param , type_variable) inline expr in let ass = return_let_in (Var.of_name param , type_variable) inline expr in
ass ass
@ -731,7 +723,7 @@ and compile_fun_expression :
(arguments_name , type_expression) in (arguments_name , type_expression) in
let%bind tpl_declarations = let%bind tpl_declarations =
let aux = fun i (param, param_type) -> let aux = fun i (param, param_type) ->
let expr = e_record_accessor (e_variable arguments_name) (string_of_int i) in let expr = e_accessor (e_variable arguments_name) [Access_tuple (Z.of_int i)] in
let type_variable = Some param_type in let type_variable = Some param_type in
let ass = return_let_in (Var.of_name param , type_variable) false expr in let ass = return_let_in (Var.of_name param , type_variable) false expr in
ass ass
@ -871,7 +863,8 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res
match a.lhs with match a.lhs with
| Path path -> ( | Path path -> (
let (name , path') = compile_path path in let (name , path') = compile_path path in
return_statement @@ e_ez_assign ~loc name path' value_expr let name = Var.of_name name in
return_statement @@ e_assign ~loc name path' value_expr
) )
| MapPath v -> ( | MapPath v -> (
let v' = v.value in let v' = v.value in
@ -884,7 +877,8 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res
in in
let%bind key_expr = compile_expression v'.index.value.inside in let%bind key_expr = compile_expression v'.index.value.inside in
let expr' = e_map_add key_expr value_expr map in let expr' = e_map_add key_expr value_expr map in
return_statement @@ e_ez_assign ~loc varname path expr' let varname = Var.of_name varname in
return_statement @@ e_assign ~loc varname path expr'
) )
) )
| CaseInstr c -> ( | CaseInstr c -> (
@ -914,7 +908,7 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res
let reg = r.region in let reg = r.region in
let (r,loc) = r_split r in let (r,loc) = r_split r in
let aux (fa :Raw.field_assign Raw.reg) : Raw.field_path_assign Raw.reg= let aux (fa :Raw.field_assign Raw.reg) : Raw.field_path_assign Raw.reg=
{value = {field_path = (fa.value.field_name, []); equal=fa.value.equal; field_expr = fa.value.field_expr}; {value = {field_path = (FieldName fa.value.field_name, []); equal=fa.value.equal; field_expr = fa.value.field_expr};
region = fa.region} region = fa.region}
in in
let update : Raw.field_path_assign Raw.reg Raw.ne_injection Raw.reg = { let update : Raw.field_path_assign Raw.reg Raw.ne_injection Raw.reg = {
@ -924,7 +918,8 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res
let u : Raw.update = {record=r.path;kwd_with=r.kwd_with; updates=update} in let u : Raw.update = {record=r.path;kwd_with=r.kwd_with; updates=update} in
let%bind expr = compile_update {value=u;region=reg} in let%bind expr = compile_update {value=u;region=reg} in
let (name , access_path) = compile_path r.path in let (name , access_path) = compile_path r.path in
return_statement @@ e_ez_assign ~loc name access_path expr let name = Var.of_name name in
return_statement @@ e_assign ~loc name access_path expr
) )
| MapPatch patch -> ( | MapPatch patch -> (
@ -945,9 +940,10 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res
let assigns = List.fold_right let assigns = List.fold_right
(fun (key, value) map -> (e_map_add key value map)) (fun (key, value) map -> (e_map_add key value map))
inj inj
(e_accessor_list ~loc (e_variable (Var.of_name name)) access_path) (e_accessor ~loc (e_variable (Var.of_name name)) access_path)
in in
return_statement @@ e_ez_assign ~loc name access_path assigns let name = Var.of_name name in
return_statement @@ e_assign ~loc name access_path assigns
) )
| SetPatch patch -> ( | SetPatch patch -> (
let (setp, loc) = r_split patch in let (setp, loc) = r_split patch in
@ -961,13 +957,14 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res
| _ :: _ -> | _ :: _ ->
let assigns = List.fold_right let assigns = List.fold_right
(fun hd s -> e_constant C_SET_ADD [hd ; s]) (fun hd s -> e_constant C_SET_ADD [hd ; s])
inj (e_accessor_list ~loc (e_variable (Var.of_name name)) access_path) in inj (e_accessor ~loc (e_variable (Var.of_name name)) access_path) in
return_statement @@ e_ez_assign ~loc name access_path assigns let name = Var.of_name name in
return_statement @@ e_assign ~loc name access_path assigns
) )
| MapRemove r -> ( | MapRemove r -> (
let (v , loc) = r_split r in let (v , loc) = r_split r in
let key = v.key in let key = v.key in
let%bind (varname,map,path) = match v.map with let%bind (name,map,path) = match v.map with
| Name v -> ok (v.value , e_variable (Var.of_name v.value) , []) | Name v -> ok (v.value , e_variable (Var.of_name v.value) , [])
| Path p -> | Path p ->
let (name,p') = compile_path v.map in let (name,p') = compile_path v.map in
@ -976,11 +973,12 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res
in in
let%bind key' = compile_expression key in let%bind key' = compile_expression key in
let expr = e_constant ~loc C_MAP_REMOVE [key' ; map] in let expr = e_constant ~loc C_MAP_REMOVE [key' ; map] in
return_statement @@ e_ez_assign ~loc varname path expr let name = Var.of_name name in
return_statement @@ e_assign ~loc name path expr
) )
| SetRemove r -> ( | SetRemove r -> (
let (set_rm, loc) = r_split r in let (set_rm, loc) = r_split r in
let%bind (varname, set, path) = match set_rm.set with let%bind (name, set, path) = match set_rm.set with
| Name v -> ok (v.value, e_variable (Var.of_name v.value), []) | Name v -> ok (v.value, e_variable (Var.of_name v.value), [])
| Path path -> | Path path ->
let(name, p') = compile_path set_rm.set in let(name, p') = compile_path set_rm.set in
@ -989,26 +987,26 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res
in in
let%bind removed' = compile_expression set_rm.element in let%bind removed' = compile_expression set_rm.element in
let expr = e_constant ~loc C_SET_REMOVE [removed' ; set] in let expr = e_constant ~loc C_SET_REMOVE [removed' ; set] in
return_statement @@ e_ez_assign ~loc varname path expr let name = Var.of_name name in
return_statement @@ e_assign ~loc name path expr
) )
and compile_path : Raw.path -> string * string list = fun p -> and compile_path : Raw.path -> string * access list = fun p ->
match p with match p with
| Raw.Name v -> (v.value , []) | Raw.Name v -> (v.value , [])
| Raw.Path p -> ( | Raw.Path p -> (
let p' = p.value in let p' = p.value in
let var = p'.struct_name.value in let var = p'.struct_name.value in
let path = p'.field_path in let path = p'.field_path in
let path' = let path' = List.map compile_selection @@ npseq_to_list path in
let aux (s:Raw.selection) =
match s with
| FieldName property -> property.value
| Component index -> (Z.to_string (snd index.value))
in
List.map aux @@ npseq_to_list path in
(var , path') (var , path')
) )
and compile_selection : Raw.selection -> access = fun s ->
match s with
| FieldName property -> Access_record property.value
| Component index -> (Access_tuple (snd index.value))
and compile_cases : (Raw.pattern * expression) list -> matching_expr result = fun t -> and compile_cases : (Raw.pattern * expression) list -> matching_expr result = fun t ->
let open Raw in let open Raw in
let get_var (t:Raw.pattern) = let get_var (t:Raw.pattern) =

104
src/passes/03-self_ast_imperative/helpers.ml
View File

@ -30,9 +30,6 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
let%bind res = bind_fold_list (bind_fold_pair self) init' lst in let%bind res = bind_fold_list (bind_fold_pair self) init' lst in
ok res ok res
) )
| E_look_up ab ->
let%bind res = bind_fold_pair self init' ab in
ok res
| E_application {lamb;args} -> ( | E_application {lamb;args} -> (
let ab = (lamb,args) in let ab = (lamb,args) in
let%bind res = bind_fold_pair self init' ab in let%bind res = bind_fold_pair self init' ab in
@ -56,13 +53,23 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
let%bind res = bind_fold_lmap aux (ok init') m in let%bind res = bind_fold_lmap aux (ok init') m in
ok res ok res
) )
| E_record_update {record;update} -> ( | E_update {record;path;update} -> (
let%bind res = self init' record in let%bind res = self init' record in
let aux res a = match a with
| Access_map e -> self res e
| _ -> ok res
in
let%bind res = bind_fold_list aux res path in
let%bind res = fold_expression self res update in let%bind res = fold_expression self res update in
ok res ok res
) )
| E_record_accessor {record} -> ( | E_accessor {record;path} -> (
let%bind res = self init' record in let%bind res = self init' record in
let aux res a = match a with
| Access_map e -> self res e
| _ -> ok res
in
let%bind res = bind_fold_list aux res path in
ok res ok res
) )
| E_tuple t -> ( | E_tuple t -> (
@ -73,15 +80,6 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
let%bind res = bind_fold_list aux (init') t in let%bind res = bind_fold_list aux (init') t in
ok res ok res
) )
| E_tuple_update {tuple;update} -> (
let%bind res = self init' tuple in
let%bind res = fold_expression self res update in
ok res
)
| E_tuple_accessor {tuple} -> (
let%bind res = self init' tuple in
ok res
)
| E_let_in { let_binder = _ ; rhs ; let_result } -> ( | E_let_in { let_binder = _ ; rhs ; let_result } -> (
let%bind res = self init' rhs in let%bind res = self init' rhs in
let%bind res = self res let_result in let%bind res = self res let_result in
@ -172,10 +170,6 @@ let rec map_expression : exp_mapper -> expression -> expression result = fun f e
let%bind lst' = bind_map_list (bind_map_pair self) lst in let%bind lst' = bind_map_list (bind_map_pair self) lst in
return @@ E_big_map lst' return @@ E_big_map lst'
) )
| E_look_up ab -> (
let%bind ab' = bind_map_pair self ab in
return @@ E_look_up ab'
)
| E_ascription ascr -> ( | E_ascription ascr -> (
let%bind e' = self ascr.anno_expr in let%bind e' = self ascr.anno_expr in
return @@ E_ascription {ascr with anno_expr=e'} return @@ E_ascription {ascr with anno_expr=e'}
@ -185,32 +179,37 @@ let rec map_expression : exp_mapper -> expression -> expression result = fun f e
let%bind cases' = map_cases f cases in let%bind cases' = map_cases f cases in
return @@ E_matching {matchee=e';cases=cases'} return @@ E_matching {matchee=e';cases=cases'}
) )
| E_record_accessor acc -> (
let%bind e' = self acc.record in
return @@ E_record_accessor {acc with record = e'}
)
| E_record m -> ( | E_record m -> (
let%bind m' = bind_map_lmap self m in let%bind m' = bind_map_lmap self m in
return @@ E_record m' return @@ E_record m'
) )
| E_record_update {record; path; update} -> ( | E_accessor {record; path} -> (
let%bind record = self record in let%bind record = self record in
let aux a = match a with
| Access_map e ->
let%bind e = self e in
ok @@ Access_map e
| e -> ok @@ e
in
let%bind path = bind_map_list aux path in
return @@ E_accessor {record; path}
)
| E_update {record; path; update} -> (
let%bind record = self record in
let aux a = match a with
| Access_map e ->
let%bind e = self e in
ok @@ Access_map e
| e -> ok @@ e
in
let%bind path = bind_map_list aux path in
let%bind update = self update in let%bind update = self update in
return @@ E_record_update {record;path;update} return @@ E_update {record;path;update}
) )
| E_tuple t -> ( | E_tuple t -> (
let%bind t' = bind_map_list self t in let%bind t' = bind_map_list self t in
return @@ E_tuple t' return @@ E_tuple t'
) )
| E_tuple_update {tuple; path; update} -> (
let%bind tuple = self tuple in
let%bind update = self update in
return @@ E_tuple_update {tuple; path; update}
)
| E_tuple_accessor {tuple;path} -> (
let%bind tuple = self tuple in
return @@ E_tuple_accessor {tuple;path}
)
| E_constructor c -> ( | E_constructor c -> (
let%bind e' = self c.element in let%bind e' = self c.element in
return @@ E_constructor {c with element = e'} return @@ E_constructor {c with element = e'}
@ -361,10 +360,6 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres
let%bind (res, lst') = bind_fold_map_list (bind_fold_map_pair self) init' lst in let%bind (res, lst') = bind_fold_map_list (bind_fold_map_pair self) init' lst in
ok (res, return @@ E_big_map lst') ok (res, return @@ E_big_map lst')
) )
| E_look_up ab -> (
let%bind (res, ab') = bind_fold_map_pair self init' ab in
ok (res, return @@ E_look_up ab')
)
| E_ascription ascr -> ( | E_ascription ascr -> (
let%bind (res,e') = self init' ascr.anno_expr in let%bind (res,e') = self init' ascr.anno_expr in
ok (res, return @@ E_ascription {ascr with anno_expr=e'}) ok (res, return @@ E_ascription {ascr with anno_expr=e'})
@ -374,33 +369,38 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres
let%bind (res,cases') = fold_map_cases f res cases in let%bind (res,cases') = fold_map_cases f res cases in
ok (res, return @@ E_matching {matchee=e';cases=cases'}) ok (res, return @@ E_matching {matchee=e';cases=cases'})
) )
| E_record_accessor acc -> (
let%bind (res, e') = self init' acc.record in
ok (res, return @@ E_record_accessor {acc with record = e'})
)
| E_record m -> ( | E_record m -> (
let%bind (res, lst') = bind_fold_map_list (fun res (k,e) -> let%bind (res,e) = self res e in ok (res,(k,e))) init' (LMap.to_kv_list m) in let%bind (res, lst') = bind_fold_map_list (fun res (k,e) -> let%bind (res,e) = self res e in ok (res,(k,e))) init' (LMap.to_kv_list m) in
let m' = LMap.of_list lst' in let m' = LMap.of_list lst' in
ok (res, return @@ E_record m') ok (res, return @@ E_record m')
) )
| E_record_update {record; path; update} -> ( | E_accessor {record;path} -> (
let%bind (res, record) = self init' record in let%bind (res, record) = self init' record in
let aux res a = match a with
| Access_map e ->
let%bind (res,e) = self res e in
ok @@ (res,Access_map e)
| e -> ok @@ (res,e)
in
let%bind (res, path) = bind_fold_map_list aux res path in
ok (res, return @@ E_accessor {record; path})
)
| E_update {record; path; update} -> (
let%bind (res, record) = self init' record in
let aux res a = match a with
| Access_map e ->
let%bind (res,e) = self res e in
ok @@ (res,Access_map e)
| e -> ok @@ (res,e)
in
let%bind (res, path) = bind_fold_map_list aux res path in
let%bind (res, update) = self res update in let%bind (res, update) = self res update in
ok (res, return @@ E_record_update {record;path;update}) ok (res, return @@ E_update {record;path;update})
) )
| E_tuple t -> ( | E_tuple t -> (
let%bind (res, t') = bind_fold_map_list self init' t in let%bind (res, t') = bind_fold_map_list self init' t in
ok (res, return @@ E_tuple t') ok (res, return @@ E_tuple t')
) )
| E_tuple_update {tuple; path; update} -> (
let%bind (res, tuple) = self init' tuple in
let%bind (res, update) = self res update in
ok (res, return @@ E_tuple_update {tuple;path;update})
)
| E_tuple_accessor {tuple; path} -> (
let%bind (res, tuple) = self init' tuple in
ok (res, return @@ E_tuple_accessor {tuple; path})
)
| E_constructor c -> ( | E_constructor c -> (
let%bind (res,e') = self init' c.element in let%bind (res,e') = self init' c.element in
ok (res, return @@ E_constructor {c with element = e'}) ok (res, return @@ E_constructor {c with element = e'})

195
src/passes/04-imperative_to_sugar/imperative_to_sugar.ml
View File

@ -46,7 +46,7 @@ let repair_mutable_variable_in_matching (match_body : O.expression) (element_nam
ok (true,(decl_var, free_var), O.e_let_in let_binder false false rhs let_result) ok (true,(decl_var, free_var), O.e_let_in let_binder false false rhs let_result)
else( else(
let free_var = if (List.mem name free_var) then free_var else name::free_var in let free_var = if (List.mem name free_var) then free_var else name::free_var in
let expr = O.e_let_in (env,None) false false (O.e_record_update (O.e_variable env) (O.Label (Var.to_name name)) (O.e_variable name)) let_result in let expr = O.e_let_in (env,None) false false (O.e_update (O.e_variable env) [O.Access_record (Var.to_name name)] (O.e_variable name)) let_result in
ok (true,(decl_var, free_var), O.e_let_in let_binder false false rhs expr) ok (true,(decl_var, free_var), O.e_let_in let_binder false false rhs expr)
) )
| E_constant {cons_name=C_MAP_FOLD;arguments= _} | E_constant {cons_name=C_MAP_FOLD;arguments= _}
@ -58,9 +58,9 @@ let repair_mutable_variable_in_matching (match_body : O.expression) (element_nam
| E_skip | E_skip
| E_literal _ | E_variable _ | E_literal _ | E_variable _
| E_application _ | E_lambda _| E_recursive _ | E_application _ | E_lambda _| E_recursive _
| E_constructor _ | E_record _| E_record_accessor _|E_record_update _ | E_constructor _ | E_record _| E_accessor _|E_update _
| E_ascription _ | E_sequence _ | E_tuple _ | E_tuple_accessor _ | E_tuple_update _ | E_ascription _ | E_sequence _ | E_tuple _
| E_map _ | E_big_map _ |E_list _ | E_set _ |E_look_up _ | E_map _ | E_big_map _ |E_list _ | E_set _
-> ok (true, (decl_var, free_var),ass_exp) -> ok (true, (decl_var, free_var),ass_exp)
) )
(element_names,[]) (element_names,[])
@ -87,8 +87,7 @@ and repair_mutable_variable_in_loops (for_body : O.expression) (element_names :
else( else(
let free_var = if (List.mem name free_var) then free_var else name::free_var in let free_var = if (List.mem name free_var) then free_var else name::free_var in
let expr = O.e_let_in (env,None) false false ( let expr = O.e_let_in (env,None) false false (
O.e_record_update (O.e_variable env) (Label "0") O.e_update (O.e_variable env) [O.Access_tuple Z.zero; O.Access_record (Var.to_name name)] (O.e_variable name)
(O.e_record_update (O.e_record_accessor (O.e_variable env) (Label "0")) (Label (Var.to_name name)) (O.e_variable name))
) )
let_result in let_result in
ok (true,(decl_var, free_var), O.e_let_in let_binder false false rhs expr) ok (true,(decl_var, free_var), O.e_let_in let_binder false false rhs expr)
@ -102,9 +101,9 @@ and repair_mutable_variable_in_loops (for_body : O.expression) (element_names :
| E_skip | E_skip
| E_literal _ | E_variable _ | E_literal _ | E_variable _
| E_application _ | E_lambda _| E_recursive _ | E_application _ | E_lambda _| E_recursive _
| E_constructor _ | E_record _| E_record_accessor _|E_record_update _ | E_constructor _ | E_record _| E_accessor _| E_update _
| E_ascription _ | E_sequence _ | E_tuple _ | E_tuple_accessor _ | E_tuple_update _ | E_ascription _ | E_sequence _ | E_tuple _
| E_map _ | E_big_map _ |E_list _ | E_set _ |E_look_up _ | E_map _ | E_big_map _ |E_list _ | E_set _
-> ok (true, (decl_var, free_var),ass_exp) -> ok (true, (decl_var, free_var),ass_exp)
) )
(element_names,[]) (element_names,[])
@ -120,7 +119,7 @@ and store_mutable_variable (free_vars : I.expression_variable list) =
and restore_mutable_variable (expr : O.expression->O.expression) (free_vars : O.expression_variable list) (env : O.expression_variable) = and restore_mutable_variable (expr : O.expression->O.expression) (free_vars : O.expression_variable list) (env : O.expression_variable) =
let aux (f: O.expression -> O.expression) (ev: O.expression_variable) = let aux (f: O.expression -> O.expression) (ev: O.expression_variable) =
fun expr -> f (O.e_let_in (ev,None) true false (O.e_record_accessor (O.e_variable env) (Label (Var.to_name ev))) expr) fun expr -> f (O.e_let_in (ev,None) true false (O.e_accessor (O.e_variable env) [O.Access_record (Var.to_name ev)]) expr)
in in
let ef = List.fold_left aux (fun e -> e) free_vars in let ef = List.fold_left aux (fun e -> e) free_vars in
fun e -> match e with fun e -> match e with
@ -234,13 +233,15 @@ and compile_expression' : I.expression -> (O.expression option -> O.expression)
) record ) record
in in
return @@ O.e_record ~loc (O.LMap.of_list record) return @@ O.e_record ~loc (O.LMap.of_list record)
| I.E_record_accessor {record;path} -> | I.E_accessor {record;path} ->
let%bind record = compile_expression record in let%bind record = compile_expression record in
return @@ O.e_record_accessor ~loc record path let%bind path = compile_path path in
| I.E_record_update {record;path;update} -> return @@ O.e_accessor ~loc record path
| I.E_update {record;path;update} ->
let%bind record = compile_expression record in let%bind record = compile_expression record in
let%bind path = compile_path path in
let%bind update = compile_expression update in let%bind update = compile_expression update in
return @@ O.e_record_update ~loc record path update return @@ O.e_update ~loc record path update
| I.E_map map -> | I.E_map map ->
let%bind map = bind_map_list ( let%bind map = bind_map_list (
bind_map_pair compile_expression bind_map_pair compile_expression
@ -259,9 +260,6 @@ and compile_expression' : I.expression -> (O.expression option -> O.expression)
| I.E_set set -> | I.E_set set ->
let%bind set = bind_map_list compile_expression set in let%bind set = bind_map_list compile_expression set in
return @@ O.e_set ~loc set return @@ O.e_set ~loc set
| I.E_look_up look_up ->
let%bind (a,b) = bind_map_pair compile_expression look_up in
return @@ O.e_look_up ~loc a b
| I.E_ascription {anno_expr; type_annotation} -> | I.E_ascription {anno_expr; type_annotation} ->
let%bind anno_expr = compile_expression anno_expr in let%bind anno_expr = compile_expression anno_expr in
let%bind type_annotation = compile_type_expression type_annotation in let%bind type_annotation = compile_type_expression type_annotation in
@ -298,41 +296,10 @@ and compile_expression' : I.expression -> (O.expression option -> O.expression)
| I.E_tuple tuple -> | I.E_tuple tuple ->
let%bind tuple = bind_map_list compile_expression tuple in let%bind tuple = bind_map_list compile_expression tuple in
return @@ O.e_tuple ~loc tuple return @@ O.e_tuple ~loc tuple
| I.E_tuple_accessor {tuple;path} ->
let%bind tuple = compile_expression tuple in
return @@ O.e_tuple_accessor ~loc tuple path
| I.E_tuple_update {tuple;path;update} ->
let%bind tuple = compile_expression tuple in
let%bind update = compile_expression update in
return @@ O.e_tuple_update ~loc tuple path update
| I.E_assign {variable; access_path; expression} -> | I.E_assign {variable; access_path; expression} ->
let accessor ?loc s a = let%bind access_path = compile_path access_path in
match a with
I.Access_tuple _i -> failwith "adding tuple soon"
| I.Access_record a -> ok @@ O.e_record_accessor ?loc s (Label a)
| I.Access_map k ->
let%bind k = compile_expression k in
ok @@ O.e_constant ?loc C_MAP_FIND_OPT [k;s]
in
let update ?loc (s:O.expression) a e =
match a with
I.Access_tuple _i -> failwith "adding tuple soon"
| I.Access_record a -> ok @@ O.e_record_update ?loc s (Label a) e
| I.Access_map k ->
let%bind k = compile_expression k in
ok @@ O.e_constant ?loc C_UPDATE [k;O.e_some (e);s]
in
let aux (s, e : O.expression * _) lst =
let%bind s' = accessor ~loc:s.location s lst in
let e' = fun expr ->
let%bind u = update ~loc:s.location s lst (expr)
in e u
in
ok @@ (s',e')
in
let%bind (_,rhs) = bind_fold_list aux (O.e_variable variable, fun e -> ok @@ e) access_path in
let%bind expression = compile_expression expression in let%bind expression = compile_expression expression in
let%bind rhs = rhs @@ expression in let rhs = O.e_update ~loc (O.e_variable ~loc variable) access_path expression in
ok @@ fun expr -> (match expr with ok @@ fun expr -> (match expr with
| None -> O.e_let_in ~loc (variable,None) true false rhs (O.e_skip ()) | None -> O.e_let_in ~loc (variable,None) true false rhs (O.e_skip ())
| Some e -> O.e_let_in ~loc (variable, None) true false rhs e | Some e -> O.e_let_in ~loc (variable, None) true false rhs e
@ -347,6 +314,16 @@ and compile_expression' : I.expression -> (O.expression option -> O.expression)
let%bind w = compile_while w in let%bind w = compile_while w in
ok @@ w ok @@ w
and compile_path : I.access list -> O.access list result =
fun path ->
let aux a = match a with
| I.Access_record s -> ok @@ O.Access_record s
| I.Access_tuple i -> ok @@ O.Access_tuple i
| I.Access_map e ->
let%bind e = compile_expression e in
ok @@ O.Access_map e
in
bind_map_list aux path
and compile_lambda : I.lambda -> O.lambda result = and compile_lambda : I.lambda -> O.lambda result =
fun {binder;input_type;output_type;result}-> fun {binder;input_type;output_type;result}->
@ -453,7 +430,7 @@ and compile_while I.{condition;body} =
let for_body = add_to_end for_body ctrl in let for_body = add_to_end for_body ctrl in
let aux name expr= let aux name expr=
O.e_let_in (name,None) false false (O.e_record_accessor (O.e_record_accessor (O.e_variable binder) (Label "0")) (Label (Var.to_name name))) expr O.e_let_in (name,None) false false (O.e_accessor (O.e_variable binder) [Access_tuple Z.zero; Access_record (Var.to_name name)]) expr
in in
let init_rec = O.e_tuple [store_mutable_variable @@ captured_name_list] in let init_rec = O.e_tuple [store_mutable_variable @@ captured_name_list] in
let restore = fun expr -> List.fold_right aux captured_name_list expr in let restore = fun expr -> List.fold_right aux captured_name_list expr in
@ -468,7 +445,7 @@ and compile_while I.{condition;body} =
let return_expr = fun expr -> let return_expr = fun expr ->
O.e_let_in let_binder false false init_rec @@ O.e_let_in let_binder false false init_rec @@
O.e_let_in let_binder false false loop @@ O.e_let_in let_binder false false loop @@
O.e_let_in let_binder false false (O.e_record_accessor (O.e_variable env_rec) (Label"0")) @@ O.e_let_in let_binder false false (O.e_accessor (O.e_variable env_rec) [Access_tuple Z.zero]) @@
expr expr
in in
ok @@ restore_mutable_variable return_expr captured_name_list env_rec ok @@ restore_mutable_variable return_expr captured_name_list env_rec
@ -483,7 +460,7 @@ and compile_for I.{binder;start;final;increment;body} =
let continue_expr = O.e_constant C_FOLD_CONTINUE [(O.e_variable env_rec)] in let continue_expr = O.e_constant C_FOLD_CONTINUE [(O.e_variable env_rec)] in
let ctrl = let ctrl =
O.e_let_in (binder,Some (O.t_int ())) false false (O.e_constant C_ADD [ O.e_variable binder ; step ]) @@ O.e_let_in (binder,Some (O.t_int ())) false false (O.e_constant C_ADD [ O.e_variable binder ; step ]) @@
O.e_let_in (env_rec, None) false false (O.e_record_update (O.e_variable env_rec) (Label "1") @@ O.e_variable binder)@@ O.e_let_in (env_rec, None) false false (O.e_update (O.e_variable env_rec) [Access_tuple Z.one] @@ O.e_variable binder)@@
continue_expr continue_expr
in in
(* Modify the body loop*) (* Modify the body loop*)
@ -492,7 +469,7 @@ and compile_for I.{binder;start;final;increment;body} =
let for_body = add_to_end for_body ctrl in let for_body = add_to_end for_body ctrl in
let aux name expr= let aux name expr=
O.e_let_in (name,None) false false (O.e_record_accessor (O.e_record_accessor (O.e_variable env_rec) (Label "0")) (Label (Var.to_name name))) expr O.e_let_in (name,None) false false (O.e_accessor (O.e_variable env_rec) [Access_tuple Z.zero; Access_record (Var.to_name name)]) expr
in in
(* restores the initial value of the free_var*) (* restores the initial value of the free_var*)
@ -501,7 +478,7 @@ and compile_for I.{binder;start;final;increment;body} =
(*Prep the lambda for the fold*) (*Prep the lambda for the fold*)
let stop_expr = O.e_constant C_FOLD_STOP [O.e_variable env_rec] in let stop_expr = O.e_constant C_FOLD_STOP [O.e_variable env_rec] in
let aux_func = O.e_lambda env_rec None None @@ let aux_func = O.e_lambda env_rec None None @@
O.e_let_in (binder,Some (O.t_int ())) false false (O.e_record_accessor (O.e_variable env_rec) (Label "1")) @@ O.e_let_in (binder,Some (O.t_int ())) false false (O.e_accessor (O.e_variable env_rec) [Access_tuple Z.one]) @@
O.e_cond cond (restore for_body) (stop_expr) in O.e_cond cond (restore for_body) (stop_expr) in
(* Make the fold_while en precharge the vakye *) (* Make the fold_while en precharge the vakye *)
@ -514,7 +491,7 @@ and compile_for I.{binder;start;final;increment;body} =
O.e_let_in (binder, Some (O.t_int ())) false false start @@ O.e_let_in (binder, Some (O.t_int ())) false false start @@
O.e_let_in let_binder false false init_rec @@ O.e_let_in let_binder false false init_rec @@
O.e_let_in let_binder false false loop @@ O.e_let_in let_binder false false loop @@
O.e_let_in let_binder false false (O.e_record_accessor (O.e_variable env_rec) (Label "0")) @@ O.e_let_in let_binder false false (O.e_accessor (O.e_variable env_rec) [Access_tuple Z.zero]) @@
expr expr
in in
ok @@ restore_mutable_variable return_expr captured_name_list env_rec ok @@ restore_mutable_variable return_expr captured_name_list env_rec
@ -530,21 +507,21 @@ and compile_for_each I.{binder;collection;collection_type; body} =
let%bind body = compile_expression body in let%bind body = compile_expression body in
let%bind ((_,free_vars), body) = repair_mutable_variable_in_loops body element_names args in let%bind ((_,free_vars), body) = repair_mutable_variable_in_loops body element_names args in
let for_body = add_to_end body @@ (O.e_record_accessor (O.e_variable args) (Label "0")) in let for_body = add_to_end body @@ (O.e_accessor (O.e_variable args) [Access_tuple Z.zero]) in
let init_record = store_mutable_variable free_vars in let init_record = store_mutable_variable free_vars in
let%bind collect = compile_expression collection in let%bind collect = compile_expression collection in
let aux name expr= let aux name expr=
O.e_let_in (name,None) false false (O.e_record_accessor (O.e_record_accessor (O.e_variable args) (Label "0")) (Label (Var.to_name name))) expr O.e_let_in (name,None) false false (O.e_accessor (O.e_variable args) [Access_tuple Z.zero; Access_record (Var.to_name name)]) expr
in in
let restore = fun expr -> List.fold_right aux free_vars expr in let restore = fun expr -> List.fold_right aux free_vars expr in
let restore = match collection_type with let restore = match collection_type with
| Map -> (match snd binder with | Map -> (match snd binder with
| Some v -> fun expr -> restore (O.e_let_in (fst binder, None) false false (O.e_record_accessor (O.e_record_accessor (O.e_variable args) (Label "1")) (Label "0")) | Some v -> fun expr -> restore (O.e_let_in (fst binder, None) false false (O.e_accessor (O.e_variable args) [Access_tuple Z.one; Access_tuple Z.zero])
(O.e_let_in (v, None) false false (O.e_record_accessor (O.e_record_accessor (O.e_variable args) (Label "1")) (Label "1")) expr)) (O.e_let_in (v, None) false false (O.e_accessor (O.e_variable args) [Access_tuple Z.one; Access_tuple Z.one]) expr))
| None -> fun expr -> restore (O.e_let_in (fst binder, None) false false (O.e_record_accessor (O.e_record_accessor (O.e_variable args) (Label "1")) (Label "0")) expr) | None -> fun expr -> restore (O.e_let_in (fst binder, None) false false (O.e_accessor (O.e_variable args) [Access_tuple Z.one; Access_tuple Z.zero]) expr)
) )
| _ -> fun expr -> restore (O.e_let_in (fst binder, None) false false (O.e_record_accessor (O.e_variable args) (Label "1")) expr) | _ -> fun expr -> restore (O.e_let_in (fst binder, None) false false (O.e_accessor (O.e_variable args) [Access_tuple Z.one]) expr)
in in
let lambda = O.e_lambda args None None (restore for_body) in let lambda = O.e_lambda args None None (restore for_body) in
let%bind op_name = match collection_type with let%bind op_name = match collection_type with
@ -610,18 +587,18 @@ let rec uncompile_type_expression : O.type_expression -> I.type_expression resul
let%bind lst = bind_map_list uncompile_type_expression lst in let%bind lst = bind_map_list uncompile_type_expression lst in
return @@ T_operator (type_operator, lst) return @@ T_operator (type_operator, lst)
let rec uncompile_expression' : O.expression -> I.expression result = let rec uncompile_expression : O.expression -> I.expression result =
fun e -> fun e ->
let return expr = ok @@ I.make_e ~loc:e.location expr in let return expr = ok @@ I.make_e ~loc:e.location expr in
match e.expression_content with match e.expression_content with
O.E_literal lit -> return @@ I.E_literal lit O.E_literal lit -> return @@ I.E_literal lit
| O.E_constant {cons_name;arguments} -> | O.E_constant {cons_name;arguments} ->
let%bind arguments = bind_map_list uncompile_expression' arguments in let%bind arguments = bind_map_list uncompile_expression arguments in
return @@ I.E_constant {cons_name;arguments} return @@ I.E_constant {cons_name;arguments}
| O.E_variable name -> return @@ I.E_variable name | O.E_variable name -> return @@ I.E_variable name
| O.E_application {lamb; args} -> | O.E_application {lamb; args} ->
let%bind lamb = uncompile_expression' lamb in let%bind lamb = uncompile_expression lamb in
let%bind args = uncompile_expression' args in let%bind args = uncompile_expression args in
return @@ I.E_application {lamb; args} return @@ I.E_application {lamb; args}
| O.E_lambda lambda -> | O.E_lambda lambda ->
let%bind lambda = uncompile_lambda lambda in let%bind lambda = uncompile_lambda lambda in
@ -633,114 +610,116 @@ let rec uncompile_expression' : O.expression -> I.expression result =
| O.E_let_in {let_binder;inline;rhs;let_result} -> | O.E_let_in {let_binder;inline;rhs;let_result} ->
let (binder,ty_opt) = let_binder in let (binder,ty_opt) = let_binder in
let%bind ty_opt = bind_map_option uncompile_type_expression ty_opt in let%bind ty_opt = bind_map_option uncompile_type_expression ty_opt in
let%bind rhs = uncompile_expression' rhs in let%bind rhs = uncompile_expression rhs in
let%bind let_result = uncompile_expression' let_result in let%bind let_result = uncompile_expression let_result in
return @@ I.E_let_in {let_binder=(binder,ty_opt);inline;rhs;let_result} return @@ I.E_let_in {let_binder=(binder,ty_opt);inline;rhs;let_result}
| O.E_constructor {constructor;element} -> | O.E_constructor {constructor;element} ->
let%bind element = uncompile_expression' element in let%bind element = uncompile_expression element in
return @@ I.E_constructor {constructor;element} return @@ I.E_constructor {constructor;element}
| O.E_matching {matchee; cases} -> | O.E_matching {matchee; cases} ->
let%bind matchee = uncompile_expression' matchee in let%bind matchee = uncompile_expression matchee in
let%bind cases = uncompile_matching cases in let%bind cases = uncompile_matching cases in
return @@ I.E_matching {matchee;cases} return @@ I.E_matching {matchee;cases}
| O.E_record record -> | O.E_record record ->
let record = I.LMap.to_kv_list record in let record = I.LMap.to_kv_list record in
let%bind record = let%bind record =
bind_map_list (fun (k,v) -> bind_map_list (fun (k,v) ->
let%bind v = uncompile_expression' v in let%bind v = uncompile_expression v in
ok @@ (k,v) ok @@ (k,v)
) record ) record
in in
return @@ I.E_record (O.LMap.of_list record) return @@ I.E_record (O.LMap.of_list record)
| O.E_record_accessor {record;path} -> | O.E_accessor {record;path} ->
let%bind record = uncompile_expression' record in let%bind record = uncompile_expression record in
return @@ I.E_record_accessor {record;path} let%bind path = uncompile_path path in
| O.E_record_update {record;path;update} -> return @@ I.E_accessor {record;path}
let%bind record = uncompile_expression' record in | O.E_update {record;path;update} ->
let%bind update = uncompile_expression' update in let%bind record = uncompile_expression record in
return @@ I.E_record_update {record;path;update} let%bind path = uncompile_path path in
let%bind update = uncompile_expression update in
return @@ I.E_update {record;path;update}
| O.E_tuple tuple -> | O.E_tuple tuple ->
let%bind tuple = bind_map_list uncompile_expression' tuple in let%bind tuple = bind_map_list uncompile_expression tuple in
return @@ I.E_tuple tuple return @@ I.E_tuple tuple
| O.E_tuple_accessor {tuple;path} ->
let%bind tuple = uncompile_expression' tuple in
return @@ I.E_tuple_accessor {tuple;path}
| O.E_tuple_update {tuple;path;update} ->
let%bind tuple = uncompile_expression' tuple in
let%bind update = uncompile_expression' update in
return @@ I.E_tuple_update {tuple;path;update}
| O.E_map map -> | O.E_map map ->
let%bind map = bind_map_list ( let%bind map = bind_map_list (
bind_map_pair uncompile_expression' bind_map_pair uncompile_expression
) map ) map
in in
return @@ I.E_map map return @@ I.E_map map
| O.E_big_map big_map -> | O.E_big_map big_map ->
let%bind big_map = bind_map_list ( let%bind big_map = bind_map_list (
bind_map_pair uncompile_expression' bind_map_pair uncompile_expression
) big_map ) big_map
in in
return @@ I.E_big_map big_map return @@ I.E_big_map big_map
| O.E_list lst -> | O.E_list lst ->
let%bind lst = bind_map_list uncompile_expression' lst in let%bind lst = bind_map_list uncompile_expression lst in
return @@ I.E_list lst return @@ I.E_list lst
| O.E_set set -> | O.E_set set ->
let%bind set = bind_map_list uncompile_expression' set in let%bind set = bind_map_list uncompile_expression set in
return @@ I.E_set set return @@ I.E_set set
| O.E_look_up look_up ->
let%bind look_up = bind_map_pair uncompile_expression' look_up in
return @@ I.E_look_up look_up
| O.E_ascription {anno_expr; type_annotation} -> | O.E_ascription {anno_expr; type_annotation} ->
let%bind anno_expr = uncompile_expression' anno_expr in let%bind anno_expr = uncompile_expression anno_expr in
let%bind type_annotation = uncompile_type_expression type_annotation in let%bind type_annotation = uncompile_type_expression type_annotation in
return @@ I.E_ascription {anno_expr; type_annotation} return @@ I.E_ascription {anno_expr; type_annotation}
| O.E_cond {condition;then_clause;else_clause} -> | O.E_cond {condition;then_clause;else_clause} ->
let%bind condition = uncompile_expression' condition in let%bind condition = uncompile_expression condition in
let%bind then_clause = uncompile_expression' then_clause in let%bind then_clause = uncompile_expression then_clause in
let%bind else_clause = uncompile_expression' else_clause in let%bind else_clause = uncompile_expression else_clause in
return @@ I.E_cond {condition; then_clause; else_clause} return @@ I.E_cond {condition; then_clause; else_clause}
| O.E_sequence {expr1; expr2} -> | O.E_sequence {expr1; expr2} ->
let%bind expr1 = uncompile_expression' expr1 in let%bind expr1 = uncompile_expression expr1 in
let%bind expr2 = uncompile_expression' expr2 in let%bind expr2 = uncompile_expression expr2 in
return @@ I.E_sequence {expr1; expr2} return @@ I.E_sequence {expr1; expr2}
| O.E_skip -> return @@ I.E_skip | O.E_skip -> return @@ I.E_skip
and uncompile_path : O.access list -> I.access list result =
fun path -> let aux a = match a with
| O.Access_record s -> ok @@ I.Access_record s
| O.Access_tuple i -> ok @@ I.Access_tuple i
| O.Access_map e ->
let%bind e = uncompile_expression e in
ok @@ I.Access_map e
in
bind_map_list aux path
and uncompile_lambda : O.lambda -> I.lambda result = and uncompile_lambda : O.lambda -> I.lambda result =
fun {binder;input_type;output_type;result}-> fun {binder;input_type;output_type;result}->
let%bind input_type = bind_map_option uncompile_type_expression input_type in let%bind input_type = bind_map_option uncompile_type_expression input_type in
let%bind output_type = bind_map_option uncompile_type_expression output_type in let%bind output_type = bind_map_option uncompile_type_expression output_type in
let%bind result = uncompile_expression' result in let%bind result = uncompile_expression result in
ok @@ I.{binder;input_type;output_type;result} ok @@ I.{binder;input_type;output_type;result}
and uncompile_matching : O.matching_expr -> I.matching_expr result = and uncompile_matching : O.matching_expr -> I.matching_expr result =
fun m -> fun m ->
match m with match m with
| O.Match_list {match_nil;match_cons} -> | O.Match_list {match_nil;match_cons} ->
let%bind match_nil = uncompile_expression' match_nil in let%bind match_nil = uncompile_expression match_nil in
let (hd,tl,expr) = match_cons in let (hd,tl,expr) = match_cons in
let%bind expr = uncompile_expression' expr in let%bind expr = uncompile_expression expr in
ok @@ I.Match_list {match_nil; match_cons=(hd,tl,expr)} ok @@ I.Match_list {match_nil; match_cons=(hd,tl,expr)}
| O.Match_option {match_none;match_some} -> | O.Match_option {match_none;match_some} ->
let%bind match_none = uncompile_expression' match_none in let%bind match_none = uncompile_expression match_none in
let (n,expr) = match_some in let (n,expr) = match_some in
let%bind expr = uncompile_expression' expr in let%bind expr = uncompile_expression expr in
ok @@ I.Match_option {match_none; match_some=(n,expr)} ok @@ I.Match_option {match_none; match_some=(n,expr)}
| O.Match_variant lst -> | O.Match_variant lst ->
let%bind lst = bind_map_list ( let%bind lst = bind_map_list (
fun ((c,n),expr) -> fun ((c,n),expr) ->
let%bind expr = uncompile_expression' expr in let%bind expr = uncompile_expression expr in
ok @@ ((c,n),expr) ok @@ ((c,n),expr)
) lst ) lst
in in
ok @@ I.Match_variant lst ok @@ I.Match_variant lst
| O.Match_record (lst,ty_opt,expr) -> | O.Match_record (lst,ty_opt,expr) ->
let%bind expr = uncompile_expression' expr in let%bind expr = uncompile_expression expr in
let%bind ty_opt = bind_map_option (bind_map_list uncompile_type_expression) ty_opt in let%bind ty_opt = bind_map_option (bind_map_list uncompile_type_expression) ty_opt in
ok @@ I.Match_record (lst,ty_opt,expr) ok @@ I.Match_record (lst,ty_opt,expr)
| O.Match_tuple (lst,ty_opt,expr) -> | O.Match_tuple (lst,ty_opt,expr) ->
let%bind expr = uncompile_expression' expr in let%bind expr = uncompile_expression expr in
let%bind ty_opt = bind_map_option (bind_map_list uncompile_type_expression) ty_opt in let%bind ty_opt = bind_map_option (bind_map_list uncompile_type_expression) ty_opt in
ok @@ I.Match_tuple (lst,ty_opt,expr) ok @@ I.Match_tuple (lst,ty_opt,expr)
| O.Match_variable (lst,ty_opt,expr) -> | O.Match_variable (lst,ty_opt,expr) ->
let%bind expr = uncompile_expression' expr in let%bind expr = uncompile_expression expr in
let%bind ty_opt = bind_map_option uncompile_type_expression ty_opt in let%bind ty_opt = bind_map_option uncompile_type_expression ty_opt in
ok @@ I.Match_variable (lst,ty_opt,expr) ok @@ I.Match_variable (lst,ty_opt,expr)

104
src/passes/05-self_ast_sugar/helpers.ml
View File

@ -30,9 +30,6 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
let%bind res = bind_fold_list (bind_fold_pair self) init' lst in let%bind res = bind_fold_list (bind_fold_pair self) init' lst in
ok res ok res
) )
| E_look_up ab ->
let%bind res = bind_fold_pair self init' ab in
ok res
| E_application {lamb;args} -> ( | E_application {lamb;args} -> (
let ab = (lamb,args) in let ab = (lamb,args) in
let%bind res = bind_fold_pair self init' ab in let%bind res = bind_fold_pair self init' ab in
@ -56,13 +53,23 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
let%bind res = bind_fold_lmap aux (ok init') m in let%bind res = bind_fold_lmap aux (ok init') m in
ok res ok res
) )
| E_record_update {record;update} -> ( | E_update {record;path;update} -> (
let%bind res = self init' record in let%bind res = self init' record in
let aux res a = match a with
| Access_map e -> self res e
| _ -> ok res
in
let%bind res = bind_fold_list aux res path in
let%bind res = fold_expression self res update in let%bind res = fold_expression self res update in
ok res ok res
) )
| E_record_accessor {record} -> ( | E_accessor {record;path} -> (
let%bind res = self init' record in let%bind res = self init' record in
let aux res a = match a with
| Access_map e -> self res e
| _ -> ok res
in
let%bind res = bind_fold_list aux res path in
ok res ok res
) )
| E_let_in { let_binder = _ ; rhs ; let_result } -> ( | E_let_in { let_binder = _ ; rhs ; let_result } -> (
@ -90,15 +97,6 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
let%bind res = bind_fold_list aux (init') t in let%bind res = bind_fold_list aux (init') t in
ok res ok res
) )
| E_tuple_update {tuple;update} -> (
let%bind res = self init' tuple in
let%bind res = fold_expression self res update in
ok res
)
| E_tuple_accessor {tuple} -> (
let%bind res = self init' tuple in
ok res
)
and fold_cases : 'a folder -> 'a -> matching_expr -> 'a result = fun f init m -> and fold_cases : 'a folder -> 'a -> matching_expr -> 'a result = fun f init m ->
match m with match m with
@ -158,10 +156,6 @@ let rec map_expression : exp_mapper -> expression -> expression result = fun f e
let%bind lst' = bind_map_list (bind_map_pair self) lst in let%bind lst' = bind_map_list (bind_map_pair self) lst in
return @@ E_big_map lst' return @@ E_big_map lst'
) )
| E_look_up ab -> (
let%bind ab' = bind_map_pair self ab in
return @@ E_look_up ab'
)
| E_ascription ascr -> ( | E_ascription ascr -> (
let%bind e' = self ascr.anno_expr in let%bind e' = self ascr.anno_expr in
return @@ E_ascription {ascr with anno_expr=e'} return @@ E_ascription {ascr with anno_expr=e'}
@ -171,18 +165,32 @@ let rec map_expression : exp_mapper -> expression -> expression result = fun f e
let%bind cases' = map_cases f cases in let%bind cases' = map_cases f cases in
return @@ E_matching {matchee=e';cases=cases'} return @@ E_matching {matchee=e';cases=cases'}
) )
| E_record_accessor acc -> (
let%bind e' = self acc.record in
return @@ E_record_accessor {acc with record = e'}
)
| E_record m -> ( | E_record m -> (
let%bind m' = bind_map_lmap self m in let%bind m' = bind_map_lmap self m in
return @@ E_record m' return @@ E_record m'
) )
| E_record_update {record; path; update} -> ( | E_accessor {record; path} -> (
let%bind record = self record in let%bind record = self record in
let aux a = match a with
| Access_map e ->
let%bind e = self e in
ok @@ Access_map e
| e -> ok @@ e
in
let%bind path = bind_map_list aux path in
return @@ E_accessor {record; path}
)
| E_update {record; path; update} -> (
let%bind record = self record in
let aux a = match a with
| Access_map e ->
let%bind e = self e in
ok @@ Access_map e
| e -> ok @@ e
in
let%bind path = bind_map_list aux path in
let%bind update = self update in let%bind update = self update in
return @@ E_record_update {record;path;update} return @@ E_update {record;path;update}
) )
| E_constructor c -> ( | E_constructor c -> (
let%bind e' = self c.element in let%bind e' = self c.element in
@ -223,15 +231,6 @@ let rec map_expression : exp_mapper -> expression -> expression result = fun f e
let%bind t' = bind_map_list self t in let%bind t' = bind_map_list self t in
return @@ E_tuple t' return @@ E_tuple t'
) )
| E_tuple_update {tuple; path; update} -> (
let%bind tuple = self tuple in
let%bind update = self update in
return @@ E_tuple_update {tuple; path; update}
)
| E_tuple_accessor {tuple;path} -> (
let%bind tuple = self tuple in
return @@ E_tuple_accessor {tuple;path}
)
| E_literal _ | E_variable _ | E_skip as e' -> return e' | E_literal _ | E_variable _ | E_skip as e' -> return e'
and map_type_expression : ty_exp_mapper -> type_expression -> type_expression result = fun f te -> and map_type_expression : ty_exp_mapper -> type_expression -> type_expression result = fun f te ->
@ -328,10 +327,6 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres
let%bind (res, lst') = bind_fold_map_list (bind_fold_map_pair self) init' lst in let%bind (res, lst') = bind_fold_map_list (bind_fold_map_pair self) init' lst in
ok (res, return @@ E_big_map lst') ok (res, return @@ E_big_map lst')
) )
| E_look_up ab -> (
let%bind (res, ab') = bind_fold_map_pair self init' ab in
ok (res, return @@ E_look_up ab')
)
| E_ascription ascr -> ( | E_ascription ascr -> (
let%bind (res,e') = self init' ascr.anno_expr in let%bind (res,e') = self init' ascr.anno_expr in
ok (res, return @@ E_ascription {ascr with anno_expr=e'}) ok (res, return @@ E_ascription {ascr with anno_expr=e'})
@ -341,33 +336,38 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres
let%bind (res,cases') = fold_map_cases f res cases in let%bind (res,cases') = fold_map_cases f res cases in
ok (res, return @@ E_matching {matchee=e';cases=cases'}) ok (res, return @@ E_matching {matchee=e';cases=cases'})
) )
| E_record_accessor acc -> (
let%bind (res, e') = self init' acc.record in
ok (res, return @@ E_record_accessor {acc with record = e'})
)
| E_record m -> ( | E_record m -> (
let%bind (res, lst') = bind_fold_map_list (fun res (k,e) -> let%bind (res,e) = self res e in ok (res,(k,e))) init' (LMap.to_kv_list m) in let%bind (res, lst') = bind_fold_map_list (fun res (k,e) -> let%bind (res,e) = self res e in ok (res,(k,e))) init' (LMap.to_kv_list m) in
let m' = LMap.of_list lst' in let m' = LMap.of_list lst' in
ok (res, return @@ E_record m') ok (res, return @@ E_record m')
) )
| E_record_update {record; path; update} -> ( | E_accessor {record;path} -> (
let%bind (res, record) = self init' record in let%bind (res, record) = self init' record in
let aux res a = match a with
| Access_map e ->
let%bind (res,e) = self res e in
ok @@ (res,Access_map e)
| e -> ok @@ (res,e)
in
let%bind (res, path) = bind_fold_map_list aux res path in
ok (res, return @@ E_accessor {record; path})
)
| E_update {record; path; update} -> (
let%bind (res, record) = self init' record in
let aux res a = match a with
| Access_map e ->
let%bind (res,e) = self res e in
ok @@ (res,Access_map e)
| e -> ok @@ (res,e)
in
let%bind (res, path) = bind_fold_map_list aux res path in
let%bind (res, update) = self res update in let%bind (res, update) = self res update in
ok (res, return @@ E_record_update {record;path;update}) ok (res, return @@ E_update {record;path;update})
) )
| E_tuple t -> ( | E_tuple t -> (
let%bind (res, t') = bind_fold_map_list self init' t in let%bind (res, t') = bind_fold_map_list self init' t in
ok (res, return @@ E_tuple t') ok (res, return @@ E_tuple t')
) )
| E_tuple_update {tuple; path; update} -> (
let%bind (res, tuple) = self init' tuple in
let%bind (res, update) = self res update in
ok (res, return @@ E_tuple_update {tuple;path;update})
)
| E_tuple_accessor {tuple; path} -> (
let%bind (res, tuple) = self init' tuple in
ok (res, return @@ E_tuple_accessor {tuple; path})
)
| E_constructor c -> ( | E_constructor c -> (
let%bind (res,e') = self init' c.element in let%bind (res,e') = self init' c.element in
ok (res, return @@ E_constructor {c with element = e'}) ok (res, return @@ E_constructor {c with element = e'})

59
src/passes/06-sugar_to_core/sugar_to_core.ml
View File

@ -86,13 +86,46 @@ let rec compile_expression : I.expression -> O.expression result =
) record ) record
in in
return @@ O.E_record (O.LMap.of_list record) return @@ O.E_record (O.LMap.of_list record)
| I.E_record_accessor {record;path} -> | I.E_accessor {record;path} ->
let%bind record = compile_expression record in let%bind record = compile_expression record in
return @@ O.E_record_accessor {record;path} let accessor ?loc e a =
| I.E_record_update {record;path;update} -> match a with
I.Access_tuple i -> ok @@ O.e_record_accessor ?loc e (Label (Z.to_string i))
| I.Access_record a -> ok @@ O.e_record_accessor ?loc e (Label a)
| I.Access_map k ->
let%bind k = compile_expression k in
ok @@ O.e_constant ?loc C_MAP_FIND_OPT [k;e]
in
bind_fold_list accessor record path
| I.E_update {record;path;update} ->
let%bind record = compile_expression record in let%bind record = compile_expression record in
let%bind update = compile_expression update in let%bind update = compile_expression update in
return @@ O.E_record_update {record;path;update} let accessor ?loc e a =
match a with
I.Access_tuple i -> ok @@ O.e_record_accessor ?loc e (Label (Z.to_string i))
| I.Access_record a -> ok @@ O.e_record_accessor ?loc e (Label a)
| I.Access_map k ->
let%bind k = compile_expression k in
ok @@ O.e_constant ?loc C_MAP_FIND_OPT [k;e]
in
let updator ?loc (s:O.expression) a e =
match a with
I.Access_tuple i -> ok @@ O.e_record_update ?loc s (Label (Z.to_string i)) e
| I.Access_record a -> ok @@ O.e_record_update ?loc s (Label a) e
| I.Access_map k ->
let%bind k = compile_expression k in
ok @@ O.e_constant ?loc C_UPDATE [k;O.e_some (e);s]
in
let aux (s, e : O.expression * _) lst =
let%bind s' = accessor ~loc:s.location s lst in
let e' = fun expr ->
let%bind u = updator ~loc:s.location s lst (expr)
in e u
in
ok @@ (s',e')
in
let%bind (_,rhs) = bind_fold_list aux (record, fun e -> ok @@ e) path in
rhs @@ update
| I.E_map map -> ( | I.E_map map -> (
let map = List.sort_uniq compare map in let map = List.sort_uniq compare map in
let aux = fun prev (k, v) -> let aux = fun prev (k, v) ->
@ -125,9 +158,6 @@ let rec compile_expression : I.expression -> O.expression result =
let%bind init = return @@ E_constant {cons_name=C_SET_EMPTY;arguments=[]} in let%bind init = return @@ E_constant {cons_name=C_SET_EMPTY;arguments=[]} in
bind_fold_list aux init lst' bind_fold_list aux init lst'
) )
| I.E_look_up look_up ->
let%bind (path, index) = bind_map_pair compile_expression look_up in
return @@ O.E_constant {cons_name=C_MAP_FIND_OPT;arguments=[index;path]}
| I.E_ascription {anno_expr; type_annotation} -> | I.E_ascription {anno_expr; type_annotation} ->
let%bind anno_expr = compile_expression anno_expr in let%bind anno_expr = compile_expression anno_expr in
let%bind type_annotation = idle_type_expression type_annotation in let%bind type_annotation = idle_type_expression type_annotation in
@ -149,15 +179,6 @@ let rec compile_expression : I.expression -> O.expression result =
let%bind (_, lst ) = bind_fold_list aux (0,[]) t in let%bind (_, lst ) = bind_fold_list aux (0,[]) t in
let m = O.LMap.of_list lst in let m = O.LMap.of_list lst in
return @@ O.E_record m return @@ O.E_record m
| I.E_tuple_accessor {tuple;path} ->
let%bind record = compile_expression tuple in
let path = O.Label (string_of_int path) in
return @@ O.E_record_accessor {record;path}
| I.E_tuple_update {tuple;path;update} ->
let%bind record = compile_expression tuple in
let path = O.Label (string_of_int path) in
let%bind update = compile_expression update in
return @@ O.E_record_update {record;path;update}
and compile_lambda : I.lambda -> O.lambda result = and compile_lambda : I.lambda -> O.lambda result =
fun {binder;input_type;output_type;result}-> fun {binder;input_type;output_type;result}->
@ -325,11 +346,13 @@ let rec uncompile_expression : O.expression -> I.expression result =
return @@ I.E_record (O.LMap.of_list record) return @@ I.E_record (O.LMap.of_list record)
| O.E_record_accessor {record;path} -> | O.E_record_accessor {record;path} ->
let%bind record = uncompile_expression record in let%bind record = uncompile_expression record in
return @@ I.E_record_accessor {record;path} let Label path = path in
return @@ I.E_accessor {record;path=[I.Access_record path]}
| O.E_record_update {record;path;update} -> | O.E_record_update {record;path;update} ->
let%bind record = uncompile_expression record in let%bind record = uncompile_expression record in
let%bind update = uncompile_expression update in let%bind update = uncompile_expression update in
return @@ I.E_record_update {record;path;update} let Label path = path in
return @@ I.E_update {record;path=[I.Access_record path];update}
| O.E_ascription {anno_expr; type_annotation} -> | O.E_ascription {anno_expr; type_annotation} ->
let%bind anno_expr = uncompile_expression anno_expr in let%bind anno_expr = uncompile_expression anno_expr in
let%bind type_annotation = uncompile_type_expression type_annotation in let%bind type_annotation = uncompile_type_expression type_annotation in

18
src/stages/1-ast_imperative/PP.ml
View File

@ -83,10 +83,10 @@ and expression_content ppf (ec : expression_content) =
c.arguments c.arguments
| E_record m -> | E_record m ->
fprintf ppf "{%a}" (record_sep expression (const ";")) m fprintf ppf "{%a}" (record_sep expression (const ";")) m
| E_record_accessor ra -> | E_accessor {record;path} ->
fprintf ppf "%a.%a" expression ra.record label ra.path fprintf ppf "%a.%a" expression record (list_sep accessor (const ".")) path
| E_record_update {record; path; update} -> | E_update {record; path; update} ->
fprintf ppf "{ %a with %a = %a }" expression record label path expression update fprintf ppf "{ %a with %a = %a }" expression record (list_sep accessor (const ".")) path expression update
| E_map m -> | E_map m ->
fprintf ppf "map[%a]" (list_sep_d assoc_expression) m fprintf ppf "map[%a]" (list_sep_d assoc_expression) m
| E_big_map m -> | E_big_map m ->
@ -95,8 +95,6 @@ and expression_content ppf (ec : expression_content) =
fprintf ppf "list[%a]" (list_sep_d expression) lst fprintf ppf "list[%a]" (list_sep_d expression) lst
| E_set lst -> | E_set lst ->
fprintf ppf "set[%a]" (list_sep_d expression) lst fprintf ppf "set[%a]" (list_sep_d expression) lst
| E_look_up (ds, ind) ->
fprintf ppf "(%a)[%a]" expression ds expression ind
| E_lambda {binder; input_type; output_type; result} -> | E_lambda {binder; input_type; output_type; result} ->
fprintf ppf "lambda (%a:%a) : %a return %a" fprintf ppf "lambda (%a:%a) : %a return %a"
expression_variable binder expression_variable binder
@ -129,14 +127,10 @@ and expression_content ppf (ec : expression_content) =
fprintf ppf "skip" fprintf ppf "skip"
| E_tuple t -> | E_tuple t ->
fprintf ppf "(%a)" (list_sep_d expression) t fprintf ppf "(%a)" (list_sep_d expression) t
| E_tuple_accessor ta ->
fprintf ppf "%a.%d" expression ta.tuple ta.path
| E_tuple_update {tuple; path; update} ->
fprintf ppf "{ %a with %d = %a }" expression tuple path expression update
| E_assign {variable; access_path; expression=e} -> | E_assign {variable; access_path; expression=e} ->
fprintf ppf "%a%a := %a" fprintf ppf "%a%a := %a"
expression_variable variable expression_variable variable
(list_sep (fun ppf a -> fprintf ppf ".%a" accessor a) (fun ppf () -> fprintf ppf "")) access_path (list_sep accessor (const ".")) access_path
expression e expression e
| E_for {binder; start; final; increment; body} -> | E_for {binder; start; final; increment; body} ->
fprintf ppf "for %a from %a to %a by %a do %a" fprintf ppf "for %a from %a to %a by %a do %a"
@ -157,7 +151,7 @@ and expression_content ppf (ec : expression_content) =
and accessor ppf a = and accessor ppf a =
match a with match a with
| Access_tuple i -> fprintf ppf "%d" i | Access_tuple i -> fprintf ppf "%a" Z.pp_print i
| Access_record s -> fprintf ppf "%s" s | Access_record s -> fprintf ppf "%s" s
| Access_map e -> fprintf ppf "%a" expression e | Access_map e -> fprintf ppf "%a" expression e

14
src/stages/1-ast_imperative/combinators.ml
View File

@ -119,15 +119,12 @@ let e_let_in ?loc (binder, ascr) inline rhs let_result = make_e ?loc @@ E_let_in
let e_constructor ?loc s a : expression = make_e ?loc @@ E_constructor { constructor = Constructor s; element = a} let e_constructor ?loc s a : expression = make_e ?loc @@ E_constructor { constructor = Constructor s; element = a}
let e_matching ?loc a b : expression = make_e ?loc @@ E_matching {matchee=a;cases=b} let e_matching ?loc a b : expression = make_e ?loc @@ E_matching {matchee=a;cases=b}
let e_record_accessor ?loc a b = make_e ?loc @@ E_record_accessor {record = a; path = Label b} let e_accessor ?loc record path = make_e ?loc @@ E_accessor {record; path}
let e_accessor_list ?loc a b = List.fold_left (fun a b -> e_record_accessor ?loc a b) a b let e_update ?loc record path update = make_e ?loc @@ E_update {record; path; update}
let e_record_update ?loc record path update = make_e ?loc @@ E_record_update {record; path=Label path; update}
let e_annotation ?loc anno_expr ty = make_e ?loc @@ E_ascription {anno_expr; type_annotation = ty} let e_annotation ?loc anno_expr ty = make_e ?loc @@ E_ascription {anno_expr; type_annotation = ty}
let e_tuple ?loc lst : expression = make_e ?loc @@ E_tuple lst let e_tuple ?loc lst : expression = make_e ?loc @@ E_tuple lst
let e_tuple_accessor ?loc tuple path : expression = make_e ?loc @@ E_tuple_accessor {tuple; path}
let e_tuple_update ?loc tuple path update : expression = make_e ?loc @@ E_tuple_update {tuple; path; update}
let e_pair ?loc a b : expression = e_tuple ?loc [a;b] let e_pair ?loc a b : expression = e_tuple ?loc [a;b]
let e_cond ?loc condition then_clause else_clause = make_e ?loc @@ E_cond {condition;then_clause;else_clause} let e_cond ?loc condition then_clause else_clause = make_e ?loc @@ E_cond {condition;then_clause;else_clause}
@ -138,7 +135,6 @@ let e_list ?loc lst : expression = make_e ?loc @@ E_list lst
let e_set ?loc lst : expression = make_e ?loc @@ E_set lst let e_set ?loc lst : expression = make_e ?loc @@ E_set lst
let e_map ?loc lst : expression = make_e ?loc @@ E_map lst let e_map ?loc lst : expression = make_e ?loc @@ E_map lst
let e_big_map ?loc lst : expression = make_e ?loc @@ E_big_map lst let e_big_map ?loc lst : expression = make_e ?loc @@ E_big_map lst
let e_look_up ?loc x y = make_e ?loc @@ E_look_up (x , y)
let e_while ?loc condition body = make_e ?loc @@ E_while {condition; body} let e_while ?loc condition body = make_e ?loc @@ E_while {condition; body}
let e_for ?loc binder start final increment body = make_e ?loc @@ E_for {binder;start;final;increment;body} let e_for ?loc binder start final increment body = make_e ?loc @@ E_for {binder;start;final;increment;body}
@ -189,14 +185,10 @@ let e_typed_set ?loc lst k = e_annotation ?loc (e_set lst) (t_set k)
let e_assign ?loc variable access_path expression = let e_assign ?loc variable access_path expression =
make_e ?loc @@ E_assign {variable;access_path;expression} make_e ?loc @@ E_assign {variable;access_path;expression}
let e_ez_assign ?loc variable access_path expression =
let variable = Var.of_name variable in
let access_path = List.map (fun s -> Access_record s) access_path in
e_assign ?loc variable access_path expression
let get_e_accessor = fun t -> let get_e_accessor = fun t ->
match t with match t with
| E_record_accessor {record; path} -> ok (record , path) | E_accessor {record; path} -> ok (record , path)
| _ -> simple_fail "not an accessor" | _ -> simple_fail "not an accessor"
let assert_e_accessor = fun t -> let assert_e_accessor = fun t ->

9
src/stages/1-ast_imperative/combinators.mli
View File

@ -106,15 +106,12 @@ val e_matching_variable: ?loc:Location.t -> expression -> expression_variable ->
val e_record : ?loc:Location.t -> expr Map.String.t -> expression val e_record : ?loc:Location.t -> expr Map.String.t -> expression
val e_record_ez : ?loc:Location.t -> ( string * expr ) list -> expression val e_record_ez : ?loc:Location.t -> ( string * expr ) list -> expression
val e_record_accessor : ?loc:Location.t -> expression -> string -> expression val e_accessor : ?loc:Location.t -> expression -> access list -> expression
val e_accessor_list : ?loc:Location.t -> expression -> string list -> expression val e_update : ?loc:Location.t -> expression -> access list -> expression -> expression
val e_record_update : ?loc:Location.t -> expression -> string -> expression -> expression
val e_annotation : ?loc:Location.t -> expression -> type_expression -> expression val e_annotation : ?loc:Location.t -> expression -> type_expression -> expression
val e_tuple : ?loc:Location.t -> expression list -> expression val e_tuple : ?loc:Location.t -> expression list -> expression
val e_tuple_accessor : ?loc:Location.t -> expression -> int -> expression
val e_tuple_update : ?loc:Location.t -> expression -> int -> expression -> expression
val e_pair : ?loc:Location.t -> expression -> expression -> expression val e_pair : ?loc:Location.t -> expression -> expression -> expression
val e_cond: ?loc:Location.t -> expression -> expression -> expression -> expression val e_cond: ?loc:Location.t -> expression -> expression -> expression -> expression
@ -125,10 +122,8 @@ val e_list : ?loc:Location.t -> expression list -> expression
val e_set : ?loc:Location.t -> expression list -> expression val e_set : ?loc:Location.t -> expression list -> expression
val e_map : ?loc:Location.t -> ( expression * expression ) list -> expression val e_map : ?loc:Location.t -> ( expression * expression ) list -> expression
val e_big_map : ?loc:Location.t -> ( expr * expr ) list -> expression val e_big_map : ?loc:Location.t -> ( expr * expr ) list -> expression
val e_look_up : ?loc:Location.t -> expression -> expression -> expression
val e_assign : ?loc:Location.t -> expression_variable -> access list -> expression -> expression val e_assign : ?loc:Location.t -> expression_variable -> access list -> expression -> expression
val e_ez_assign : ?loc:Location.t -> string -> string list -> expression -> expression
val e_while : ?loc:Location.t -> expression -> expression -> expression val e_while : ?loc:Location.t -> expression -> expression -> expression
val e_for : ?loc:Location.t -> expression_variable -> expression -> expression -> expression -> expression -> expression val e_for : ?loc:Location.t -> expression_variable -> expression -> expression -> expression -> expression -> expression

16
src/stages/1-ast_imperative/types.ml
View File

@ -53,8 +53,8 @@ and expression_content =
| E_matching of matching | E_matching of matching
(* Record *) (* Record *)
| E_record of expression label_map | E_record of expression label_map
| E_record_accessor of record_accessor | E_accessor of accessor
| E_record_update of record_update | E_update of update
(* Advanced *) (* Advanced *)
| E_ascription of ascription | E_ascription of ascription
(* Sugar *) (* Sugar *)
@ -62,14 +62,11 @@ and expression_content =
| E_sequence of sequence | E_sequence of sequence
| E_skip | E_skip
| E_tuple of expression list | E_tuple of expression list
| E_tuple_accessor of tuple_accessor
| E_tuple_update of tuple_update
(* Data Structures *) (* Data Structures *)
| E_map of (expression * expression) list | E_map of (expression * expression) list
| E_big_map of (expression * expression) list | E_big_map of (expression * expression) list
| E_list of expression list | E_list of expression list
| E_set of expression list | E_set of expression list
| E_look_up of (expression * expression)
(* Imperative *) (* Imperative *)
| E_assign of assign | E_assign of assign
| E_for of for_ | E_for of for_
@ -105,8 +102,8 @@ and let_in =
and constructor = {constructor: constructor'; element: expression} and constructor = {constructor: constructor'; element: expression}
and record_accessor = {record: expression; path: label} and accessor = {record: expression; path: access list}
and record_update = {record: expression; path: label ; update: expression} and update = {record: expression; path: access list; update: expression}
@ -142,9 +139,6 @@ and sequence = {
expr2: expression ; expr2: expression ;
} }
and tuple_accessor = {tuple: expression; path: int}
and tuple_update = {tuple: expression; path: int ; update: expression}
and assign = { and assign = {
variable : expression_variable; variable : expression_variable;
access_path : access list; access_path : access list;
@ -152,7 +146,7 @@ and assign = {
} }
and access = and access =
| Access_tuple of int | Access_tuple of Z.t
| Access_record of string | Access_record of string
| Access_map of expr | Access_map of expr

20
src/stages/2-ast_sugar/PP.ml
View File

@ -78,10 +78,10 @@ and expression_content ppf (ec : expression_content) =
c.arguments c.arguments
| E_record m -> | E_record m ->
fprintf ppf "{%a}" (record_sep_expr expression (const ";")) m fprintf ppf "{%a}" (record_sep_expr expression (const ";")) m
| E_record_accessor ra -> | E_accessor {record;path} ->
fprintf ppf "%a.%a" expression ra.record label ra.path fprintf ppf "%a.%a" expression record (list_sep accessor (const ".")) path
| E_record_update {record; path; update} -> | E_update {record; path; update} ->
fprintf ppf "{ %a with %a = %a }" expression record label path expression update fprintf ppf "{ %a with %a = %a }" expression record (list_sep accessor (const ".")) path expression update
| E_map m -> | E_map m ->
fprintf ppf "map[%a]" (list_sep_d assoc_expression) m fprintf ppf "map[%a]" (list_sep_d assoc_expression) m
| E_big_map m -> | E_big_map m ->
@ -90,8 +90,6 @@ and expression_content ppf (ec : expression_content) =
fprintf ppf "list[%a]" (list_sep_d expression) lst fprintf ppf "list[%a]" (list_sep_d expression) lst
| E_set lst -> | E_set lst ->
fprintf ppf "set[%a]" (list_sep_d expression) lst fprintf ppf "set[%a]" (list_sep_d expression) lst
| E_look_up (ds, ind) ->
fprintf ppf "(%a)[%a]" expression ds expression ind
| E_lambda {binder; input_type; output_type; result} -> | E_lambda {binder; input_type; output_type; result} ->
fprintf ppf "lambda (%a:%a) : %a return %a" fprintf ppf "lambda (%a:%a) : %a return %a"
expression_variable binder expression_variable binder
@ -127,10 +125,12 @@ and expression_content ppf (ec : expression_content) =
fprintf ppf "skip" fprintf ppf "skip"
| E_tuple t -> | E_tuple t ->
fprintf ppf "(%a)" (list_sep_d expression) t fprintf ppf "(%a)" (list_sep_d expression) t
| E_tuple_accessor ta ->
fprintf ppf "%a.%d" expression ta.tuple ta.path and accessor ppf a =
| E_tuple_update {tuple; path; update} -> match a with
fprintf ppf "{ %a with %d = %a }" expression tuple path expression update | Access_tuple i -> fprintf ppf "%a" Z.pp_print i
| Access_record s -> fprintf ppf "%s" s
| Access_map e -> fprintf ppf "%a" expression e
and option_type_name ppf and option_type_name ppf
((n, ty_opt) : expression_variable * type_expression option) = ((n, ty_opt) : expression_variable * type_expression option) =

13
src/stages/2-ast_sugar/combinators.ml
View File

@ -108,14 +108,12 @@ let e_constructor ?loc s a : expression = make_e ?loc @@ E_constructor { constru
let e_matching ?loc a b : expression = make_e ?loc @@ E_matching {matchee=a;cases=b} let e_matching ?loc a b : expression = make_e ?loc @@ E_matching {matchee=a;cases=b}
let e_record ?loc map : expression = make_e ?loc @@ E_record map let e_record ?loc map : expression = make_e ?loc @@ E_record map
let e_record_accessor ?loc record path = make_e ?loc @@ E_record_accessor {record; path} let e_accessor ?loc record path = make_e ?loc @@ E_accessor {record; path}
let e_record_update ?loc record path update = make_e ?loc @@ E_record_update {record; path; update} let e_update ?loc record path update = make_e ?loc @@ E_update {record; path; update}
let e_annotation ?loc anno_expr ty = make_e ?loc @@ E_ascription {anno_expr; type_annotation = ty} let e_annotation ?loc anno_expr ty = make_e ?loc @@ E_ascription {anno_expr; type_annotation = ty}
let e_tuple ?loc lst : expression = make_e ?loc @@ E_tuple lst let e_tuple ?loc lst : expression = make_e ?loc @@ E_tuple lst
let e_tuple_accessor ?loc tuple path = make_e ?loc @@ E_tuple_accessor {tuple; path}
let e_tuple_update ?loc tuple path update = make_e ?loc @@ E_tuple_update {tuple; path; update}
let e_pair ?loc a b : expression = e_tuple ?loc [a;b] let e_pair ?loc a b : expression = e_tuple ?loc [a;b]
let e_cond ?loc condition then_clause else_clause = make_e ?loc @@ E_cond {condition;then_clause;else_clause} let e_cond ?loc condition then_clause else_clause = make_e ?loc @@ E_cond {condition;then_clause;else_clause}
@ -126,7 +124,6 @@ let e_list ?loc lst : expression = make_e ?loc @@ E_list lst
let e_set ?loc lst : expression = make_e ?loc @@ E_set lst let e_set ?loc lst : expression = make_e ?loc @@ E_set lst
let e_map ?loc lst : expression = make_e ?loc @@ E_map lst let e_map ?loc lst : expression = make_e ?loc @@ E_map lst
let e_big_map ?loc lst : expression = make_e ?loc @@ E_big_map lst let e_big_map ?loc lst : expression = make_e ?loc @@ E_big_map lst
let e_look_up ?loc a b : expression = make_e ?loc @@ E_look_up (a,b)
let e_bool ?loc b : expression = e_constructor ?loc (Constructor (string_of_bool b)) (e_unit ()) let e_bool ?loc b : expression = e_constructor ?loc (Constructor (string_of_bool b)) (e_unit ())
@ -150,13 +147,13 @@ let e_typed_set ?loc lst k = e_annotation ?loc (e_set lst) (t_set k)
let get_e_record_accessor = fun t -> let get_e_accessor = fun t ->
match t with match t with
| E_record_accessor {record; path} -> ok (record, path) | E_accessor {record; path} -> ok (record, path)
| _ -> simple_fail "not a record accessor" | _ -> simple_fail "not a record accessor"
let assert_e_accessor = fun t -> let assert_e_accessor = fun t ->
let%bind _ = get_e_record_accessor t in let%bind _ = get_e_accessor t in
ok () ok ()
let get_e_pair = fun t -> let get_e_pair = fun t ->

7
src/stages/2-ast_sugar/combinators.mli
View File

@ -79,14 +79,12 @@ val e_recursive : ?loc:Location.t -> expression_variable -> type_expression -> l
val e_let_in : ?loc:Location.t -> ( expression_variable * type_expression option ) -> bool -> bool -> expression -> expression -> expression val e_let_in : ?loc:Location.t -> ( expression_variable * type_expression option ) -> bool -> bool -> expression -> expression -> expression
val e_record : ?loc:Location.t -> expr label_map -> expression val e_record : ?loc:Location.t -> expr label_map -> expression
val e_record_accessor : ?loc:Location.t -> expression -> label -> expression val e_accessor : ?loc:Location.t -> expression -> access list -> expression
val e_record_update : ?loc:Location.t -> expression -> label -> expression -> expression val e_update : ?loc:Location.t -> expression -> access list -> expression -> expression
val e_annotation : ?loc:Location.t -> expression -> type_expression -> expression val e_annotation : ?loc:Location.t -> expression -> type_expression -> expression
val e_tuple : ?loc:Location.t -> expression list -> expression val e_tuple : ?loc:Location.t -> expression list -> expression
val e_tuple_accessor : ?loc:Location.t -> expression -> int -> expression
val e_tuple_update : ?loc:Location.t -> expression -> int -> expression -> expression
val e_pair : ?loc:Location.t -> expression -> expression -> expression val e_pair : ?loc:Location.t -> expression -> expression -> expression
val e_cond: ?loc:Location.t -> expression -> expression -> expression -> expression val e_cond: ?loc:Location.t -> expression -> expression -> expression -> expression
@ -97,7 +95,6 @@ val e_list : ?loc:Location.t -> expression list -> expression
val e_set : ?loc:Location.t -> expression list -> expression val e_set : ?loc:Location.t -> expression list -> expression
val e_map : ?loc:Location.t -> ( expression * expression ) list -> expression val e_map : ?loc:Location.t -> ( expression * expression ) list -> expression
val e_big_map : ?loc:Location.t -> ( expr * expr ) list -> expression val e_big_map : ?loc:Location.t -> ( expr * expr ) list -> expression
val e_look_up : ?loc:Location.t -> expression -> expression -> expression
val e_matching : ?loc:Location.t -> expression -> matching_expr -> expression val e_matching : ?loc:Location.t -> expression -> matching_expr -> expression

19
src/stages/2-ast_sugar/types.ml
View File

@ -54,8 +54,8 @@ and expression_content =
| E_matching of matching | E_matching of matching
(* Record *) (* Record *)
| E_record of expression label_map | E_record of expression label_map
| E_record_accessor of record_accessor | E_accessor of accessor
| E_record_update of record_update | E_update of update
(* Advanced *) (* Advanced *)
| E_ascription of ascription | E_ascription of ascription
(* Sugar *) (* Sugar *)
@ -63,14 +63,11 @@ and expression_content =
| E_sequence of sequence | E_sequence of sequence
| E_skip | E_skip
| E_tuple of expression list | E_tuple of expression list
| E_tuple_accessor of tuple_accessor
| E_tuple_update of tuple_update
(* Data Structures *) (* Data Structures *)
| E_map of (expression * expression) list | E_map of (expression * expression) list
| E_big_map of (expression * expression) list | E_big_map of (expression * expression) list
| E_list of expression list | E_list of expression list
| E_set of expression list | E_set of expression list
| E_look_up of (expression * expression)
and constant = and constant =
{ cons_name: constant' (* this is at the end because it is huge *) { cons_name: constant' (* this is at the end because it is huge *)
@ -103,8 +100,13 @@ and let_in = {
and constructor = {constructor: constructor'; element: expression} and constructor = {constructor: constructor'; element: expression}
and record_accessor = {record: expression; path: label} and accessor = {record: expression; path: access list}
and record_update = {record: expression; path: label ; update: expression} and update = {record: expression; path: access list ; update: expression}
and access =
| Access_tuple of Z.t
| Access_record of string
| Access_map of expr
and matching_expr = and matching_expr =
| Match_variant of ((constructor' * expression_variable) * expression) list | Match_variant of ((constructor' * expression_variable) * expression) list
@ -137,9 +139,6 @@ and sequence = {
expr2: expression ; expr2: expression ;
} }
and tuple_accessor = {tuple: expression; path: int}
and tuple_update = {tuple: expression; path: int ; update: expression}
and environment_element_definition = and environment_element_definition =
| ED_binder | ED_binder
| ED_declaration of (expression * free_variables) | ED_declaration of (expression * free_variables)