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

Merge branch 'gardening/fix-ast' into 'dev'

Browse Source 
Refactoring in the ast

See merge request ligolang/ligo!665
This commit is contained in:
Pierre-Emmanuel Wulfman 2020-06-08 13:32:52 +00:00
commit 94a3c1c3da
43 changed files with 3136 additions and 3163 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 = {
field_path : (field_name, dot) nsepseq;
field_path : (selection, dot) nsepseq;
assignment : equal;
field_expr : expr
}

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

@ -650,8 +650,8 @@ update_record:
in {region; value} }
field_path_assignment :
nsepseq(field_name,".") "=" expr {
let start = nsepseq_to_region (fun x -> x.region) $1 in
nsepseq(selection,".") "=" expr {
let start = nsepseq_to_region selection_to_region $1 in
let region = cover start (expr_to_region $3) in
let value = {field_path = $1;
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; _} =
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_expr state field_expr
@ -965,7 +965,7 @@ and pp_field_assign state {value; _} =
and pp_field_path_assign state {value; _} =
pp_node state "<field path for update>";
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
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 = {
field_path : (field_name, dot) nsepseq;
field_path : (selection, dot) nsepseq;
equal : equal;
field_expr : expr
}

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

@ -987,8 +987,8 @@ field_assignment:
in {region; value} }
field_path_assignment:
nsepseq(field_name,".") "=" expr {
let start = nsepseq_to_region (fun x -> x.region) $1
nsepseq(selection,".") "=" expr {
let start = nsepseq_to_region selection_to_region $1
and stop = expr_to_region $3 in
let region = cover start stop
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; _} =
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_expr state field_expr
@ -1353,7 +1353,7 @@ and pp_field_assign state {value; _} =
and pp_field_path_assign state {value; _} =
pp_node state "<field path for update>";
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
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}
in {region; value} }
real_selection:
field_name { FieldName $1 }
| "<int>" { Component $1 }
field_path_assignment:
field_name {
let value = {
real_selection {
let region = selection_to_region $1
and value = {
field_path = ($1,[]);
assignment = ghost;
field_expr = EVar $1 }
in {$1 with value}
field_expr = match $1 with
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 {
let start = nsepseq_to_region (fun x -> x.region) $1 in
let stop = expr_to_region $3 in
let region = cover start stop in
let value = {
| nsepseq(real_selection,".") ":" expr {
let start = nsepseq_to_region selection_to_region $1
and stop = expr_to_region $3 in
let region = cover start stop
and value = {
field_path = $1;
assignment = $2;
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>
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
##
## 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>
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
##
## Ends in an error in state: 430.

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

@ -343,26 +343,25 @@ let rec compile_expression :
let path' =
let aux (s:Raw.selection) =
match s with
FieldName property -> property.value
| Component index -> Z.to_string (snd index.value)
FieldName property -> Access_record property.value
| Component index -> Access_tuple (snd index.value)
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
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
| Raw.Name v -> (v.value , [])
| Raw.Path p -> (
let p' = p.value in
let var = p'.struct_name.value in
let path = p'.field_path in
let path' =
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
let path' = List.map compile_selection @@ npseq_to_list path in
(var , path')
)
in
@ -371,30 +370,19 @@ let rec compile_expression :
let (name, path) = compile_path u.record in
let record = match path with
| [] -> e_variable (Var.of_name name)
| _ ->
let aux expr (Label l) = e_record_accessor expr l in
List.fold_left aux (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%bind updates' =
let aux (f:Raw.field_path_assign Raw.reg) =
let (f,_) = r_split f 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
bind_map_list aux @@ npseq_to_list updates
in
let aux ur (path, expr) =
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
let aux ur (path, expr) = ok @@ e_update ~loc ur path expr in
bind_fold_list aux record updates'
in
trace (abstracting_expr t) @@
match t with
Raw.ELetIn e ->
@ -439,11 +427,11 @@ let rec compile_expression :
| hd :: [] ->
if (List.length prep_vars = 1)
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 ->
e_let_in ~loc hd
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)
| [] -> body (* Precluded by corner case assertion above *)
in
@ -960,7 +948,7 @@ and compile_declaration : Raw.declaration -> declaration Location.wrap list resu
ok @@ [loc x @@ (Declaration_constant (Var.of_name var.value , lhs_type , inline, rhs'))]
)
and compile_cases : type a . (Raw.pattern * a) list -> (a, unit) matching_content result =
and compile_cases : (Raw.pattern * expression) list -> matching_expr result =
fun t ->
let open Raw in
let rec get_var (t:Raw.pattern) =
@ -1031,7 +1019,7 @@ and compile_cases : type a . (Raw.pattern * a) list -> (a, unit) matching_conten
match patterns with
| [(PFalse _, f) ; (PTrue _, t)]
| [(PTrue _, t) ; (PFalse _, f)] ->
ok @@ Match_variant ([((Constructor "true", Var.of_name "_"), t); ((Constructor "false", Var.of_name "_"), f)], ())
ok @@ Match_variant ([((Constructor "true", Var.of_name "_"), t); ((Constructor "false", Var.of_name "_"), f)])
| [(PList (PCons c), cons); (PList (PListComp sugar_nil), nil)]
| [(PList (PListComp sugar_nil), nil); (PList (PCons c), cons)] ->
let%bind () =
@ -1044,7 +1032,7 @@ and compile_cases : type a . (Raw.pattern * a) list -> (a, unit) matching_conten
let%bind a = get_var a in
let%bind b = get_var b in
ok (a, b) in
ok @@ Match_list {match_cons=(Var.of_name a, Var.of_name b, cons, ()); match_nil=nil}
ok @@ Match_list {match_cons=(Var.of_name a, Var.of_name b, cons); match_nil=nil}
| lst ->
let error x =
let title () = "Pattern" in
@ -1075,7 +1063,7 @@ and compile_cases : type a . (Raw.pattern * a) list -> (a, unit) matching_conten
| [ (("None", None), none_expr);
(("Some", Some some_var), some_expr) ] ->
ok @@ Match_option {
match_some = (Var.of_name some_var, some_expr, ());
match_some = (Var.of_name some_var, some_expr);
match_none = none_expr }
| _ -> simple_fail "bad option pattern"
in bind_or (as_option () , as_variant ())

78
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 aux (s:Raw.selection) =
match s with
| FieldName property -> property.value
| Component index -> (Z.to_string (snd index.value))
| FieldName property -> Access_record property.value
| Component index -> (Access_tuple (snd index.value))
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 =
@ -451,7 +451,7 @@ let rec compile_expression (t:Raw.expr) : expr result =
| Path p -> compile_projection p
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 ->
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 record = match path with
| [] -> 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%bind updates' =
let aux (f:Raw.field_path_assign Raw.reg) =
let (f,_) = r_split f 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
bind_map_list aux @@ npseq_to_list updates
in
let aux ur (path, expr) =
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
let aux ur (path, expr) = ok @@ e_update ~loc ur path expr in
bind_fold_list aux record updates'
and compile_logic_expression (t:Raw.logic_expr) : expression result =
@ -668,7 +660,7 @@ and compile_fun_decl :
let%bind tpl_declarations =
let aux = fun i (param, type_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 ass = return_let_in (Var.of_name param , type_variable) inline expr in
ass
@ -731,7 +723,7 @@ and compile_fun_expression :
(arguments_name , type_expression) in
let%bind tpl_declarations =
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 ass = return_let_in (Var.of_name param , type_variable) false expr in
ass
@ -871,7 +863,8 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res
match a.lhs with
| Path path -> (
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 -> (
let v' = v.value in
@ -884,7 +877,8 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res
in
let%bind key_expr = compile_expression v'.index.value.inside 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 -> (
@ -914,7 +908,7 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res
let reg = r.region in
let (r,loc) = r_split r in
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}
in
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%bind expr = compile_update {value=u;region=reg} 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 -> (
@ -945,9 +940,10 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res
let assigns = List.fold_right
(fun (key, value) map -> (e_map_add key value map))
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
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 -> (
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
(fun hd s -> e_constant C_SET_ADD [hd ; s])
inj (e_accessor_list ~loc (e_variable (Var.of_name name)) access_path) in
return_statement @@ e_ez_assign ~loc name access_path assigns
inj (e_accessor ~loc (e_variable (Var.of_name name)) access_path) in
let name = Var.of_name name in
return_statement @@ e_assign ~loc name access_path assigns
)
| MapRemove r -> (
let (v , loc) = r_split r 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) , [])
| Path p ->
let (name,p') = compile_path v.map in
@ -976,11 +973,12 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res
in
let%bind key' = compile_expression key 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 -> (
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), [])
| Path path ->
let(name, p') = compile_path set_rm.set in
@ -989,26 +987,26 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res
in
let%bind removed' = compile_expression set_rm.element 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
| Raw.Name v -> (v.value , [])
| Raw.Path p -> (
let p' = p.value in
let var = p'.struct_name.value in
let path = p'.field_path in
let path' =
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
let path' = List.map compile_selection @@ npseq_to_list path in
(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 ->
let open Raw in
let get_var (t:Raw.pattern) =
@ -1059,14 +1057,14 @@ and compile_cases : (Raw.pattern * expression) list -> matching_expr result = fu
match patterns with
| [(PConstr PFalse _ , f) ; (PConstr PTrue _ , t)]
| [(PConstr PTrue _ , t) ; (PConstr PFalse _ , f)] ->
ok @@ Match_variant ([((Constructor "true", Var.of_name "_"), t); ((Constructor "false", Var.of_name "_"), f)], ())
ok @@ Match_variant ([((Constructor "true", Var.of_name "_"), t); ((Constructor "false", Var.of_name "_"), f)])
| [(PConstr PSomeApp v , some) ; (PConstr PNone _ , none)]
| [(PConstr PNone _ , none) ; (PConstr PSomeApp v , some)] -> (
let (_, v) = v.value in
let%bind v = match v.value.inside with
| PVar v -> ok v.value
| p -> fail @@ unsupported_deep_Some_patterns p in
ok @@ Match_option {match_none = none ; match_some = (Var.of_name v, some, ()) }
ok @@ Match_option {match_none = none ; match_some = (Var.of_name v, some) }
)
| [(PList PCons c, cons) ; (PList (PNil _), nil)]
| [(PList (PNil _), nil) ; (PList PCons c, cons)] ->
@ -1079,7 +1077,7 @@ and compile_cases : (Raw.pattern * expression) list -> matching_expr result = fu
| _ -> fail @@ unsupported_deep_list_patterns c
in
ok @@ Match_list {match_cons = (Var.of_name a, Var.of_name b, cons,()) ; match_nil = nil}
ok @@ Match_list {match_cons = (Var.of_name a, Var.of_name b, cons) ; match_nil = nil}
| lst ->
trace (simple_info "currently, only booleans, options, lists and \
user-defined constructors are supported in patterns") @@

232
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
ok res
)
| E_look_up ab ->
let%bind res = bind_fold_pair self init' ab in
ok res
| E_application {lamb;args} -> (
let ab = (lamb,args) in
let%bind res = bind_fold_pair self init' ab in
@ -56,15 +53,25 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
let%bind res = bind_fold_lmap aux (ok init') m in
ok res
)
| E_record_update {record;update} -> (
| E_update {record;path;update} -> (
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
ok res
)
| E_record_accessor {record} -> (
let%bind res = self init' record in
ok res
)
| E_accessor {record;path} -> (
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
)
| E_tuple t -> (
let aux init'' expr =
let%bind res = fold_expression self init'' expr in
@ -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
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 } -> (
let%bind res = self init' rhs in
let%bind res = self res let_result in
@ -114,31 +112,37 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
let%bind res = self res body in
ok res
and fold_cases : 'a folder -> 'a -> matching_expr -> 'a result = fun f init m ->
match m with
| Match_list { match_nil ; match_cons = (_ , _ , cons, _) } -> (
let%bind res = fold_expression f init match_nil in
let%bind res = fold_expression f res cons in
ok res
)
| Match_option { match_none ; match_some = (_ , some, _) } -> (
let%bind res = fold_expression f init match_none in
let%bind res = fold_expression f res some in
ok res
)
| Match_tuple ((_ , e), _) -> (
let%bind res = fold_expression f init e in
ok res
)
| Match_variant (lst, _) -> (
| Match_variant lst -> (
let aux init' ((_ , _) , e) =
let%bind res' = fold_expression f init' e in
ok res' in
let%bind res = bind_fold_list aux init lst in
ok res
)
| Match_list { match_nil ; match_cons = (_ , _ , cons) } -> (
let%bind res = fold_expression f init match_nil in
let%bind res = fold_expression f res cons in
ok res
)
| Match_option { match_none ; match_some = (_ , some) } -> (
let%bind res = fold_expression f init match_none in
let%bind res = fold_expression f res some in
ok res
)
| Match_record (_, _, e) -> (
let%bind res = fold_expression f init e in
ok res
)
| Match_tuple (_, _, e) -> (
let%bind res = fold_expression f init e in
ok res
)
| Match_variable (_, _, e) -> (
let%bind res = fold_expression f init e in
ok res
)
type exp_mapper = expression -> expression result
type ty_exp_mapper = type_expression -> type_expression result
@ -166,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
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 -> (
let%bind e' = self ascr.anno_expr in
return @@ E_ascription {ascr with anno_expr=e'}
@ -179,32 +179,37 @@ let rec map_expression : exp_mapper -> expression -> expression result = fun f e
let%bind cases' = map_cases f cases in
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 -> (
let%bind m' = bind_map_lmap self m in
return @@ E_record m'
)
| E_record_update {record; path; update} -> (
| E_accessor {record; path} -> (
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
return @@ E_record_update {record;path;update}
return @@ E_update {record;path;update}
)
| E_tuple t -> (
let%bind t' = bind_map_list self t in
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 -> (
let%bind e' = self c.element in
return @@ E_constructor {c with element = e'}
@ -284,27 +289,35 @@ and map_type_expression : ty_exp_mapper -> type_expression -> type_expression re
and map_cases : exp_mapper -> matching_expr -> matching_expr result = fun f m ->
match m with
| Match_list { match_nil ; match_cons = (hd , tl , cons, _) } -> (
let%bind match_nil = map_expression f match_nil in
let%bind cons = map_expression f cons in
ok @@ Match_list { match_nil ; match_cons = (hd , tl , cons, ()) }
)
| Match_option { match_none ; match_some = (name , some, _) } -> (
let%bind match_none = map_expression f match_none in
let%bind some = map_expression f some in
ok @@ Match_option { match_none ; match_some = (name , some, ()) }
)
| Match_tuple ((names , e), _) -> (
let%bind e' = map_expression f e in
ok @@ Match_tuple ((names , e'), [])
)
| Match_variant (lst, _) -> (
| Match_variant lst -> (
let aux ((a , b) , e) =
let%bind e' = map_expression f e in
ok ((a , b) , e')
in
let%bind lst' = bind_map_list aux lst in
ok @@ Match_variant (lst', ())
ok @@ Match_variant lst'
)
| Match_list { match_nil ; match_cons = (hd , tl , cons) } -> (
let%bind match_nil = map_expression f match_nil in
let%bind cons = map_expression f cons in
ok @@ Match_list { match_nil ; match_cons = (hd , tl , cons) }
)
| Match_option { match_none ; match_some = (name , some) } -> (
let%bind match_none = map_expression f match_none in
let%bind some = map_expression f some in
ok @@ Match_option { match_none ; match_some = (name , some) }
)
| Match_record (names, ty_opt, e) -> (
let%bind e' = map_expression f e in
ok @@ Match_record (names, ty_opt, e')
)
| Match_tuple (names, ty_opt, e) -> (
let%bind e' = map_expression f e in
ok @@ Match_tuple (names, ty_opt, e')
)
| Match_variable (name, ty_opt, e) -> (
let%bind e' = map_expression f e in
ok @@ Match_variable (name, ty_opt, e')
)
and map_program : abs_mapper -> program -> program result = fun m p ->
@ -347,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
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 -> (
let%bind (res,e') = self init' ascr.anno_expr in
ok (res, return @@ E_ascription {ascr with anno_expr=e'})
@ -360,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
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 -> (
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
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 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
ok (res, return @@ E_record_update {record;path;update})
ok (res, return @@ E_update {record;path;update})
)
| E_tuple t -> (
let%bind (res, t') = bind_fold_map_list self init' t in
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 -> (
let%bind (res,e') = self init' c.element in
ok (res, return @@ E_constructor {c with element = e'})
@ -440,25 +454,33 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres
and fold_map_cases : 'a fold_mapper -> 'a -> matching_expr -> ('a * matching_expr) result = fun f init m ->
match m with
| Match_list { match_nil ; match_cons = (hd , tl , cons, _) } -> (
let%bind (init, match_nil) = fold_map_expression f init match_nil in
let%bind (init, cons) = fold_map_expression f init cons in
ok @@ (init, Match_list { match_nil ; match_cons = (hd , tl , cons, ()) })
)
| Match_option { match_none ; match_some = (name , some, _) } -> (
let%bind (init, match_none) = fold_map_expression f init match_none in
let%bind (init, some) = fold_map_expression f init some in
ok @@ (init, Match_option { match_none ; match_some = (name , some, ()) })
)
| Match_tuple ((names , e), _) -> (
let%bind (init, e') = fold_map_expression f init e in
ok @@ (init, Match_tuple ((names , e'), []))
)
| Match_variant (lst, _) -> (
| Match_variant lst -> (
let aux init ((a , b) , e) =
let%bind (init,e') = fold_map_expression f init e in
ok (init, ((a , b) , e'))
in
let%bind (init,lst') = bind_fold_map_list aux init lst in
ok @@ (init, Match_variant (lst', ()))
)
ok @@ (init, Match_variant lst')
)
| Match_list { match_nil ; match_cons = (hd , tl , cons) } -> (
let%bind (init, match_nil) = fold_map_expression f init match_nil in
let%bind (init, cons) = fold_map_expression f init cons in
ok @@ (init, Match_list { match_nil ; match_cons = (hd , tl , cons) })
)
| Match_option { match_none ; match_some = (name , some) } -> (
let%bind (init, match_none) = fold_map_expression f init match_none in
let%bind (init, some) = fold_map_expression f init some in
ok @@ (init, Match_option { match_none ; match_some = (name , some) })
)
| Match_record (names, ty_opt, e) -> (
let%bind (init, e') = fold_map_expression f init e in
ok @@ (init, Match_record (names, ty_opt, e'))
)
| Match_tuple (names, ty_opt, e) -> (
let%bind (init, e') = fold_map_expression f init e in
ok @@ (init, Match_tuple (names, ty_opt, e'))
)
| Match_variable (name, ty_opt, e) -> (
let%bind (init, e') = fold_map_expression f init e in
ok @@ (init, Match_variable (name, ty_opt, e'))
)

251
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)
else(
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)
)
| 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_literal _ | E_variable _
| E_application _ | E_lambda _| E_recursive _
| E_constructor _ | E_record _| E_record_accessor _|E_record_update _
| E_ascription _ | E_sequence _ | E_tuple _ | E_tuple_accessor _ | E_tuple_update _
| E_map _ | E_big_map _ |E_list _ | E_set _ |E_look_up _
| E_constructor _ | E_record _| E_accessor _|E_update _
| E_ascription _ | E_sequence _ | E_tuple _
| E_map _ | E_big_map _ |E_list _ | E_set _
-> ok (true, (decl_var, free_var),ass_exp)
)
(element_names,[])
@ -87,8 +87,7 @@ and repair_mutable_variable_in_loops (for_body : O.expression) (element_names :
else(
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) (Label "0")
(O.e_record_update (O.e_record_accessor (O.e_variable env) (Label "0")) (Label (Var.to_name name)) (O.e_variable name))
O.e_update (O.e_variable env) [O.Access_tuple Z.zero; 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)
@ -102,9 +101,9 @@ and repair_mutable_variable_in_loops (for_body : O.expression) (element_names :
| E_skip
| E_literal _ | E_variable _
| E_application _ | E_lambda _| E_recursive _
| E_constructor _ | E_record _| E_record_accessor _|E_record_update _
| E_ascription _ | E_sequence _ | E_tuple _ | E_tuple_accessor _ | E_tuple_update _
| E_map _ | E_big_map _ |E_list _ | E_set _ |E_look_up _
| E_constructor _ | E_record _| E_accessor _| E_update _
| E_ascription _ | E_sequence _ | E_tuple _
| E_map _ | E_big_map _ |E_list _ | E_set _
-> ok (true, (decl_var, free_var),ass_exp)
)
(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) =
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
let ef = List.fold_left aux (fun e -> e) free_vars in
fun e -> match e with
@ -234,13 +233,15 @@ and compile_expression' : I.expression -> (O.expression option -> O.expression)
) record
in
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
return @@ O.e_record_accessor ~loc record path
| I.E_record_update {record;path;update} ->
let%bind path = compile_path path in
return @@ O.e_accessor ~loc record path
| I.E_update {record;path;update} ->
let%bind record = compile_expression record in
let%bind path = compile_path path 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 ->
let%bind map = bind_map_list (
bind_map_pair compile_expression
@ -259,9 +260,6 @@ and compile_expression' : I.expression -> (O.expression option -> O.expression)
| I.E_set set ->
let%bind set = bind_map_list compile_expression set in
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} ->
let%bind anno_expr = compile_expression anno_expr 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 ->
let%bind tuple = bind_map_list compile_expression tuple in
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} ->
let accessor ?loc s a =
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 access_path = compile_path access_path 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
| 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
@ -347,6 +314,16 @@ and compile_expression' : I.expression -> (O.expression option -> O.expression)
let%bind w = compile_while w in
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 =
fun {binder;input_type;output_type;result}->
@ -365,7 +342,7 @@ and compile_matching : I.matching -> Location.t -> (O.expression option -> O.exp
match cases with
| I.Match_option {match_none;match_some} ->
let%bind match_none' = compile_expression match_none in
let (n,expr,tv) = match_some in
let (n,expr) = match_some in
let%bind expr' = compile_expression expr in
let env = Var.fresh () in
let%bind ((_,free_vars_none), match_none) = repair_mutable_variable_in_matching match_none' [] env in
@ -374,7 +351,7 @@ and compile_matching : I.matching -> Location.t -> (O.expression option -> O.exp
let expr = add_to_end expr (O.e_variable env) in
let free_vars = List.sort_uniq Var.compare @@ free_vars_none @ free_vars_some in
if (List.length free_vars != 0) then
let match_expr = O.e_matching matchee (O.Match_option {match_none; match_some=(n,expr,tv)}) in
let match_expr = O.e_matching matchee (O.Match_option {match_none; match_some=(n,expr)}) in
let return_expr = fun expr ->
O.e_let_in (env,None) false false (store_mutable_variable free_vars) @@
O.e_let_in (env,None) false false match_expr @@
@ -382,19 +359,19 @@ and compile_matching : I.matching -> Location.t -> (O.expression option -> O.exp
in
ok @@ restore_mutable_variable return_expr free_vars env
else
return @@ O.e_matching ~loc matchee @@ O.Match_option {match_none=match_none'; match_some=(n,expr',tv)}
return @@ O.e_matching ~loc matchee @@ O.Match_option {match_none=match_none'; match_some=(n,expr')}
| I.Match_list {match_nil;match_cons} ->
let%bind match_nil' = compile_expression match_nil in
let (hd,tl,expr,tv) = match_cons in
let (hd,tl,expr) = match_cons in
let%bind expr' = compile_expression expr in
let env = Var.fresh () in
let%bind ((_,free_vars_nil), match_nil) = repair_mutable_variable_in_matching match_nil' [] env in
let%bind ((_,free_vars_cons), expr) = repair_mutable_variable_in_matching expr' [hd;tl] env in
let match_nil = add_to_end match_nil (O.e_variable env) in
let expr = add_to_end expr (O.e_variable env) in
let expr = add_to_end expr (O.e_variable env) in
let free_vars = List.sort_uniq Var.compare @@ free_vars_nil @ free_vars_cons in
if (List.length free_vars != 0) then
let match_expr = O.e_matching matchee (O.Match_list {match_nil; match_cons=(hd,tl,expr,tv)}) in
let match_expr = O.e_matching matchee (O.Match_list {match_nil; match_cons=(hd,tl,expr)}) in
let return_expr = fun expr ->
O.e_let_in (env,None) false false (store_mutable_variable free_vars) @@
O.e_let_in (env,None) false false match_expr @@
@ -402,11 +379,8 @@ and compile_matching : I.matching -> Location.t -> (O.expression option -> O.exp
in
ok @@ restore_mutable_variable return_expr free_vars env
else
return @@ O.e_matching ~loc matchee @@ O.Match_list {match_nil=match_nil'; match_cons=(hd,tl,expr',tv)}
| I.Match_tuple ((lst,expr), tv) ->
let%bind expr = compile_expression expr in
return @@ O.e_matching ~loc matchee @@ O.Match_tuple ((lst,expr), tv)
| I.Match_variant (lst,tv) ->
return @@ O.e_matching ~loc matchee @@ O.Match_list {match_nil=match_nil'; match_cons=(hd,tl,expr')}
| I.Match_variant lst ->
let env = Var.fresh () in
let aux fv ((c,n),expr) =
let%bind expr = compile_expression expr in
@ -418,10 +392,10 @@ and compile_matching : I.matching -> Location.t -> (O.expression option -> O.exp
let free_vars = List.sort_uniq Var.compare @@ List.concat fv in
if (List.length free_vars == 0) then (
let cases = List.map (fun case -> let (a,_,b) = case in (a,b)) cases in
return @@ O.e_matching ~loc matchee @@ O.Match_variant (cases,tv)
return @@ O.e_matching ~loc matchee @@ O.Match_variant cases
) else (
let cases = List.map (fun case -> let (a,b,_) = case in (a,b)) cases in
let match_expr = O.e_matching matchee @@ O.Match_variant (cases,tv) in
let match_expr = O.e_matching matchee @@ O.Match_variant cases in
let return_expr = fun expr ->
O.e_let_in (env,None) false false (store_mutable_variable free_vars) @@
O.e_let_in (env,None) false false match_expr @@
@ -429,6 +403,18 @@ and compile_matching : I.matching -> Location.t -> (O.expression option -> O.exp
in
ok @@ restore_mutable_variable return_expr free_vars env
)
| I.Match_record (lst,ty_opt,expr) ->
let%bind expr = compile_expression expr in
let%bind ty_opt = bind_map_option (bind_map_list compile_type_expression) ty_opt in
return @@ O.e_matching ~loc matchee @@ O.Match_record (lst,ty_opt,expr)
| I.Match_tuple (lst,ty_opt,expr) ->
let%bind expr = compile_expression expr in
let%bind ty_opt = bind_map_option (bind_map_list compile_type_expression) ty_opt in
return @@ O.e_matching ~loc matchee @@ O.Match_tuple (lst,ty_opt,expr)
| I.Match_variable (lst,ty_opt,expr) ->
let%bind expr = compile_expression expr in
let%bind ty_opt = bind_map_option compile_type_expression ty_opt in
return @@ O.e_matching ~loc matchee @@ O.Match_variable (lst,ty_opt,expr)
and compile_while I.{condition;body} =
let env_rec = Var.fresh () in
@ -444,7 +430,7 @@ and compile_while I.{condition;body} =
let for_body = add_to_end for_body ctrl in
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
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
@ -459,7 +445,7 @@ and compile_while I.{condition;body} =
let return_expr = fun expr ->
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 (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
in
ok @@ restore_mutable_variable return_expr captured_name_list env_rec
@ -474,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 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 (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
in
(* Modify the body loop*)
@ -483,7 +469,7 @@ and compile_for I.{binder;start;final;increment;body} =
let for_body = add_to_end for_body ctrl in
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
(* restores the initial value of the free_var*)
@ -492,7 +478,7 @@ and compile_for I.{binder;start;final;increment;body} =
(*Prep the lambda for the fold*)
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 @@
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
(* Make the fold_while en precharge the vakye *)
@ -505,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 let_binder false false init_rec @@
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
in
ok @@ restore_mutable_variable return_expr captured_name_list env_rec
@ -521,21 +507,21 @@ and compile_for_each I.{binder;collection;collection_type; body} =
let%bind body = compile_expression body 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%bind collect = compile_expression collection in
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
let restore = fun expr -> List.fold_right aux free_vars expr in
let restore = match collection_type 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"))
(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))
| 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)
| 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_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_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
let lambda = O.e_lambda args None None (restore for_body) in
let%bind op_name = match collection_type with
@ -601,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
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 ->
let return expr = ok @@ I.make_e ~loc:e.location expr in
match e.expression_content with
O.E_literal lit -> return @@ I.E_literal lit
| 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}
| O.E_variable name -> return @@ I.E_variable name
| O.E_application {lamb; args} ->
let%bind lamb = uncompile_expression' lamb in
let%bind args = uncompile_expression' args in
let%bind lamb = uncompile_expression lamb in
let%bind args = uncompile_expression args in
return @@ I.E_application {lamb; args}
| O.E_lambda lambda ->
let%bind lambda = uncompile_lambda lambda in
@ -624,105 +610,116 @@ let rec uncompile_expression' : O.expression -> I.expression result =
| O.E_let_in {let_binder;inline;rhs;let_result} ->
let (binder,ty_opt) = let_binder in
let%bind ty_opt = bind_map_option uncompile_type_expression ty_opt in
let%bind rhs = uncompile_expression' rhs in
let%bind let_result = uncompile_expression' let_result in
let%bind rhs = uncompile_expression rhs in
let%bind let_result = uncompile_expression let_result in
return @@ I.E_let_in {let_binder=(binder,ty_opt);inline;rhs;let_result}
| 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}
| 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
return @@ I.E_matching {matchee;cases}
| O.E_record record ->
let record = I.LMap.to_kv_list record in
let%bind record =
bind_map_list (fun (k,v) ->
let%bind v = uncompile_expression' v in
let%bind v = uncompile_expression v in
ok @@ (k,v)
) record
in
return @@ I.E_record (O.LMap.of_list record)
| O.E_record_accessor {record;path} ->
let%bind record = uncompile_expression' record in
return @@ I.E_record_accessor {record;path}
| O.E_record_update {record;path;update} ->
let%bind record = uncompile_expression' record in
let%bind update = uncompile_expression' update in
return @@ I.E_record_update {record;path;update}
| O.E_accessor {record;path} ->
let%bind record = uncompile_expression record in
let%bind path = uncompile_path path in
return @@ I.E_accessor {record;path}
| O.E_update {record;path;update} ->
let%bind record = uncompile_expression record in
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 ->
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
| 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 ->
let%bind map = bind_map_list (
bind_map_pair uncompile_expression'
bind_map_pair uncompile_expression
) map
in
return @@ I.E_map map
| O.E_big_map big_map ->
let%bind big_map = bind_map_list (
bind_map_pair uncompile_expression'
bind_map_pair uncompile_expression
) big_map
in
return @@ I.E_big_map big_map
| 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
| 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
| 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} ->
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
return @@ I.E_ascription {anno_expr; type_annotation}
| O.E_cond {condition;then_clause;else_clause} ->
let%bind condition = uncompile_expression' condition in
let%bind then_clause = uncompile_expression' then_clause in
let%bind else_clause = uncompile_expression' else_clause in
let%bind condition = uncompile_expression condition in
let%bind then_clause = uncompile_expression then_clause in
let%bind else_clause = uncompile_expression else_clause in
return @@ I.E_cond {condition; then_clause; else_clause}
| O.E_sequence {expr1; expr2} ->
let%bind expr1 = uncompile_expression' expr1 in
let%bind expr2 = uncompile_expression' expr2 in
let%bind expr1 = uncompile_expression expr1 in
let%bind expr2 = uncompile_expression expr2 in
return @@ I.E_sequence {expr1; expr2}
| 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 =
fun {binder;input_type;output_type;result}->
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 result = uncompile_expression' result in
let%bind result = uncompile_expression result in
ok @@ I.{binder;input_type;output_type;result}
and uncompile_matching : O.matching_expr -> I.matching_expr result =
fun m ->
match m with
| O.Match_list {match_nil;match_cons} ->
let%bind match_nil = uncompile_expression' match_nil in
let (hd,tl,expr,tv) = match_cons in
let%bind expr = uncompile_expression' expr in
ok @@ I.Match_list {match_nil; match_cons=(hd,tl,expr,tv)}
let%bind match_nil = uncompile_expression match_nil in
let (hd,tl,expr) = match_cons in
let%bind expr = uncompile_expression expr in
ok @@ I.Match_list {match_nil; match_cons=(hd,tl,expr)}
| O.Match_option {match_none;match_some} ->
let%bind match_none = uncompile_expression' match_none in
let (n,expr,tv) = match_some in
let%bind expr = uncompile_expression' expr in
ok @@ I.Match_option {match_none; match_some=(n,expr,tv)}
| O.Match_tuple ((lst,expr), tv) ->
let%bind expr = uncompile_expression' expr in
ok @@ O.Match_tuple ((lst,expr), tv)
| O.Match_variant (lst,tv) ->
let%bind match_none = uncompile_expression match_none in
let (n,expr) = match_some in
let%bind expr = uncompile_expression expr in
ok @@ I.Match_option {match_none; match_some=(n,expr)}
| O.Match_variant lst ->
let%bind lst = bind_map_list (
fun ((c,n),expr) ->
let%bind expr = uncompile_expression' expr in
let%bind expr = uncompile_expression expr in
ok @@ ((c,n),expr)
) lst
in
ok @@ I.Match_variant (lst,tv)
ok @@ I.Match_variant lst
| O.Match_record (lst,ty_opt,expr) ->
let%bind expr = uncompile_expression expr 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)
| O.Match_tuple (lst,ty_opt,expr) ->
let%bind expr = uncompile_expression expr 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)
| O.Match_variable (lst,ty_opt,expr) ->
let%bind expr = uncompile_expression expr in
let%bind ty_opt = bind_map_option uncompile_type_expression ty_opt in
ok @@ I.Match_variable (lst,ty_opt,expr)

232
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
ok res
)
| E_look_up ab ->
let%bind res = bind_fold_pair self init' ab in
ok res
| E_application {lamb;args} -> (
let ab = (lamb,args) in
let%bind res = bind_fold_pair self init' ab in
@ -56,15 +53,25 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
let%bind res = bind_fold_lmap aux (ok init') m in
ok res
)
| E_record_update {record;update} -> (
| E_update {record;path;update} -> (
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
ok res
)
| E_record_accessor {record} -> (
let%bind res = self init' record in
ok res
)
| E_accessor {record;path} -> (
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
)
| E_let_in { let_binder = _ ; rhs ; let_result } -> (
let%bind res = self init' rhs in
let%bind res = self res let_result in
@ -90,40 +97,38 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
let%bind res = bind_fold_list aux (init') t in
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 ->
match m with
| Match_list { match_nil ; match_cons = (_ , _ , cons, _) } -> (
let%bind res = fold_expression f init match_nil in
let%bind res = fold_expression f res cons in
ok res
)
| Match_option { match_none ; match_some = (_ , some, _) } -> (
let%bind res = fold_expression f init match_none in
let%bind res = fold_expression f res some in
ok res
)
| Match_tuple ((_ , e), _) -> (
let%bind res = fold_expression f init e in
ok res
)
| Match_variant (lst, _) -> (
| Match_variant lst -> (
let aux init' ((_ , _) , e) =
let%bind res' = fold_expression f init' e in
ok res' in
let%bind res = bind_fold_list aux init lst in
ok res
)
| Match_list { match_nil ; match_cons = (_ , _ , cons) } -> (
let%bind res = fold_expression f init match_nil in
let%bind res = fold_expression f res cons in
ok res
)
| Match_option { match_none ; match_some = (_ , some) } -> (
let%bind res = fold_expression f init match_none in
let%bind res = fold_expression f res some in
ok res
)
| Match_record (_, _, e) -> (
let%bind res = fold_expression f init e in
ok res
)
| Match_tuple (_, _, e) -> (
let%bind res = fold_expression f init e in
ok res
)
| Match_variable (_, _, e) -> (
let%bind res = fold_expression f init e in
ok res
)
type exp_mapper = expression -> expression result
type ty_exp_mapper = type_expression -> type_expression result
@ -151,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
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 -> (
let%bind e' = self ascr.anno_expr in
return @@ E_ascription {ascr with anno_expr=e'}
@ -164,18 +165,32 @@ let rec map_expression : exp_mapper -> expression -> expression result = fun f e
let%bind cases' = map_cases f cases in
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 -> (
let%bind m' = bind_map_lmap self m in
return @@ E_record m'
)
| E_record_update {record; path; update} -> (
| E_accessor {record; path} -> (
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
return @@ E_record_update {record;path;update}
return @@ E_update {record;path;update}
)
| E_constructor c -> (
let%bind e' = self c.element in
@ -216,15 +231,6 @@ let rec map_expression : exp_mapper -> expression -> expression result = fun f e
let%bind t' = bind_map_list self t in
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'
and map_type_expression : ty_exp_mapper -> type_expression -> type_expression result = fun f te ->
@ -250,27 +256,35 @@ and map_type_expression : ty_exp_mapper -> type_expression -> type_expression re
and map_cases : exp_mapper -> matching_expr -> matching_expr result = fun f m ->
match m with
| Match_list { match_nil ; match_cons = (hd , tl , cons, _) } -> (
let%bind match_nil = map_expression f match_nil in
let%bind cons = map_expression f cons in
ok @@ Match_list { match_nil ; match_cons = (hd , tl , cons, ()) }
)
| Match_option { match_none ; match_some = (name , some, _) } -> (
let%bind match_none = map_expression f match_none in
let%bind some = map_expression f some in
ok @@ Match_option { match_none ; match_some = (name , some, ()) }
)
| Match_tuple ((names , e), _) -> (
let%bind e' = map_expression f e in
ok @@ Match_tuple ((names , e'), [])
)
| Match_variant (lst, _) -> (
| Match_variant lst -> (
let aux ((a , b) , e) =
let%bind e' = map_expression f e in
ok ((a , b) , e')
in
let%bind lst' = bind_map_list aux lst in
ok @@ Match_variant (lst', ())
ok @@ Match_variant lst'
)
| Match_list { match_nil ; match_cons = (hd , tl , cons) } -> (
let%bind match_nil = map_expression f match_nil in
let%bind cons = map_expression f cons in
ok @@ Match_list { match_nil ; match_cons = (hd , tl , cons) }
)
| Match_option { match_none ; match_some = (name , some) } -> (
let%bind match_none = map_expression f match_none in
let%bind some = map_expression f some in
ok @@ Match_option { match_none ; match_some = (name , some) }
)
| Match_record (names, ty_opt, e) -> (
let%bind e' = map_expression f e in
ok @@ Match_record (names, ty_opt, e')
)
| Match_tuple (names, ty_opt, e) -> (
let%bind e' = map_expression f e in
ok @@ Match_tuple (names, ty_opt, e')
)
| Match_variable (name, ty_opt, e) -> (
let%bind e' = map_expression f e in
ok @@ Match_variable (name, ty_opt, e')
)
and map_program : abs_mapper -> program -> program result = fun m p ->
@ -313,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
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 -> (
let%bind (res,e') = self init' ascr.anno_expr in
ok (res, return @@ E_ascription {ascr with anno_expr=e'})
@ -326,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
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 -> (
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
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 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
ok (res, return @@ E_record_update {record;path;update})
ok (res, return @@ E_update {record;path;update})
)
| E_tuple t -> (
let%bind (res, t') = bind_fold_map_list self init' t in
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 -> (
let%bind (res,e') = self init' c.element in
ok (res, return @@ E_constructor {c with element = e'})
@ -389,28 +404,35 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres
ok (res, return @@ E_sequence {expr1;expr2})
)
| E_literal _ | E_variable _ | E_skip as e' -> ok (init', return e')
and fold_map_cases : 'a fold_mapper -> 'a -> matching_expr -> ('a * matching_expr) result = fun f init m ->
match m with
| Match_list { match_nil ; match_cons = (hd , tl , cons, _) } -> (
let%bind (init, match_nil) = fold_map_expression f init match_nil in
let%bind (init, cons) = fold_map_expression f init cons in
ok @@ (init, Match_list { match_nil ; match_cons = (hd , tl , cons, ()) })
)
| Match_option { match_none ; match_some = (name , some, _) } -> (
let%bind (init, match_none) = fold_map_expression f init match_none in
let%bind (init, some) = fold_map_expression f init some in
ok @@ (init, Match_option { match_none ; match_some = (name , some, ()) })
)
| Match_tuple ((names , e), _) -> (
let%bind (init, e') = fold_map_expression f init e in
ok @@ (init, Match_tuple ((names , e'), []))
)
| Match_variant (lst, _) -> (
| Match_variant lst -> (
let aux init ((a , b) , e) =
let%bind (init,e') = fold_map_expression f init e in
ok (init, ((a , b) , e'))
in
let%bind (init,lst') = bind_fold_map_list aux init lst in
ok @@ (init, Match_variant (lst', ()))
)
ok @@ (init, Match_variant lst')
)
| Match_list { match_nil ; match_cons = (hd , tl , cons) } -> (
let%bind (init, match_nil) = fold_map_expression f init match_nil in
let%bind (init, cons) = fold_map_expression f init cons in
ok @@ (init, Match_list { match_nil ; match_cons = (hd , tl , cons) })
)
| Match_option { match_none ; match_some = (name , some) } -> (
let%bind (init, match_none) = fold_map_expression f init match_none in
let%bind (init, some) = fold_map_expression f init some in
ok @@ (init, Match_option { match_none ; match_some = (name , some) })
)
| Match_record (names, ty_opt, e) -> (
let%bind (init, e') = fold_map_expression f init e in
ok @@ (init, Match_record (names, ty_opt, e'))
)
| Match_tuple (names, ty_opt, e) -> (
let%bind (init, e') = fold_map_expression f init e in
ok @@ (init, Match_tuple (names, ty_opt, e'))
)
| Match_variable (name, ty_opt, e) -> (
let%bind (init, e') = fold_map_expression f init e in
ok @@ (init, Match_variable (name, ty_opt, e'))
)

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

@ -2,7 +2,7 @@ module I = Ast_sugar
module O = Ast_core
open Trace
let rec idle_type_expression : I.type_expression -> O.type_expression result =
let rec compile_type_expression : I.type_expression -> O.type_expression result =
fun te ->
let return tc = ok @@ O.make_t ~loc:te.location tc in
match te.type_content with
@ -11,7 +11,7 @@ let rec idle_type_expression : I.type_expression -> O.type_expression result =
let%bind sum =
bind_map_list (fun (k,v) ->
let {ctor_type ; michelson_annotation ; ctor_decl_pos} : I.ctor_content = v in
let%bind ctor_type = idle_type_expression ctor_type in
let%bind ctor_type = compile_type_expression ctor_type in
let v' : O.ctor_content = {ctor_type ; michelson_annotation ; ctor_decl_pos} in
ok @@ (k,v')
) sum
@ -22,7 +22,7 @@ let rec idle_type_expression : I.type_expression -> O.type_expression result =
let%bind record =
bind_map_list (fun (k,v) ->
let {field_type ; michelson_annotation ; field_decl_pos} : I.field_content = v in
let%bind field_type = idle_type_expression field_type in
let%bind field_type = compile_type_expression field_type in
let v' : O.field_content = {field_type ; field_annotation=michelson_annotation ; field_decl_pos} in
ok @@ (k,v')
) record
@ -30,19 +30,19 @@ let rec idle_type_expression : I.type_expression -> O.type_expression result =
return @@ O.T_record (O.LMap.of_list record)
| I.T_tuple tuple ->
let aux (i,acc) el =
let%bind el = idle_type_expression el in
let%bind el = compile_type_expression el in
ok @@ (i+1,(O.Label (string_of_int i), ({field_type=el;field_annotation=None;field_decl_pos=0}:O.field_content))::acc) in
let%bind (_, lst ) = bind_fold_list aux (0,[]) tuple in
let record = O.LMap.of_list lst in
return @@ O.T_record record
| I.T_arrow {type1;type2} ->
let%bind type1 = idle_type_expression type1 in
let%bind type2 = idle_type_expression type2 in
let%bind type1 = compile_type_expression type1 in
let%bind type2 = compile_type_expression type2 in
return @@ T_arrow {type1;type2}
| I.T_variable type_variable -> return @@ T_variable type_variable
| I.T_constant type_constant -> return @@ T_constant type_constant
| I.T_operator (type_operator, lst) ->
let%bind lst = bind_map_list idle_type_expression lst in
let%bind lst = bind_map_list compile_type_expression lst in
return @@ T_operator (type_operator, lst)
let rec compile_expression : I.expression -> O.expression result =
@ -62,12 +62,12 @@ let rec compile_expression : I.expression -> O.expression result =
let%bind lambda = compile_lambda lambda in
return @@ O.E_lambda lambda
| I.E_recursive {fun_name;fun_type;lambda} ->
let%bind fun_type = idle_type_expression fun_type in
let%bind fun_type = compile_type_expression fun_type in
let%bind lambda = compile_lambda lambda in
return @@ O.E_recursive {fun_name;fun_type;lambda}
| I.E_let_in {let_binder;inline;rhs;let_result} ->
let (binder,ty_opt) = let_binder in
let%bind ty_opt = bind_map_option idle_type_expression ty_opt in
let%bind ty_opt = bind_map_option compile_type_expression ty_opt in
let%bind rhs = compile_expression rhs in
let%bind let_result = compile_expression let_result in
return @@ O.E_let_in {let_binder=(binder,ty_opt);inline;rhs;let_result}
@ -76,8 +76,7 @@ let rec compile_expression : I.expression -> O.expression result =
return @@ O.E_constructor {constructor;element}
| I.E_matching {matchee; cases} ->
let%bind matchee = compile_expression matchee in
let%bind cases = compile_matching cases in
return @@ O.E_matching {matchee;cases}
compile_matching e.location matchee cases
| I.E_record record ->
let record = I.LMap.to_kv_list record in
let%bind record =
@ -87,13 +86,46 @@ let rec compile_expression : I.expression -> O.expression result =
) record
in
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
return @@ O.E_record_accessor {record;path}
| I.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
bind_fold_list accessor record path
| I.E_update {record;path;update} ->
let%bind record = compile_expression record 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 -> (
let map = List.sort_uniq compare map in
let aux = fun prev (k, v) ->
@ -126,18 +158,15 @@ let rec compile_expression : I.expression -> O.expression result =
let%bind init = return @@ E_constant {cons_name=C_SET_EMPTY;arguments=[]} in
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} ->
let%bind anno_expr = compile_expression anno_expr in
let%bind type_annotation = idle_type_expression type_annotation in
let%bind type_annotation = compile_type_expression type_annotation in
return @@ O.E_ascription {anno_expr; type_annotation}
| I.E_cond {condition; then_clause; else_clause} ->
let%bind matchee = compile_expression condition in
let%bind match_true = compile_expression then_clause in
let%bind match_false = compile_expression else_clause in
return @@ O.E_matching {matchee; cases=Match_variant ([((Constructor "true", Var.of_name "_"),match_true);((Constructor "false", Var.of_name "_"), match_false)],())}
return @@ O.E_matching {matchee; cases=Match_variant ([((Constructor "true", Var.of_name "_"),match_true);((Constructor "false", Var.of_name "_"), match_false)])}
| I.E_sequence {expr1; expr2} ->
let%bind expr1 = compile_expression expr1 in
let%bind expr2 = compile_expression expr2 in
@ -150,46 +179,71 @@ let rec compile_expression : I.expression -> O.expression result =
let%bind (_, lst ) = bind_fold_list aux (0,[]) t in
let m = O.LMap.of_list lst in
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 =
fun {binder;input_type;output_type;result}->
let%bind input_type = bind_map_option idle_type_expression input_type in
let%bind output_type = bind_map_option idle_type_expression output_type in
let%bind input_type = bind_map_option compile_type_expression input_type in
let%bind output_type = bind_map_option compile_type_expression output_type in
let%bind result = compile_expression result in
ok @@ O.{binder;input_type;output_type;result}
and compile_matching : I.matching_expr -> O.matching_expr result =
fun m ->
and compile_matching : Location.t -> O.expression -> I.matching_expr -> O.expression result =
fun loc e m ->
match m with
| I.Match_list {match_nil;match_cons} ->
let%bind match_nil = compile_expression match_nil in
let (hd,tl,expr,tv) = match_cons in
let (hd,tl,expr) = match_cons in
let%bind expr = compile_expression expr in
ok @@ O.Match_list {match_nil; match_cons=(hd,tl,expr,tv)}
ok @@ O.e_matching ~loc e @@ O.Match_list {match_nil; match_cons=(hd,tl,expr)}
| I.Match_option {match_none;match_some} ->
let%bind match_none = compile_expression match_none in
let (n,expr,tv) = match_some in
let (n,expr) = match_some in
let%bind expr = compile_expression expr in
ok @@ O.Match_option {match_none; match_some=(n,expr,tv)}
| I.Match_tuple ((lst,expr), tv) ->
let%bind expr = compile_expression expr in
ok @@ O.Match_tuple ((lst,expr), tv)
| I.Match_variant (lst,tv) ->
ok @@ O.e_matching ~loc e @@ O.Match_option {match_none; match_some=(n,expr)}
| I.Match_variant lst ->
let%bind lst = bind_map_list (
fun ((c,n),expr) ->
let%bind expr = compile_expression expr in
ok @@ ((c,n),expr)
) lst
in
ok @@ O.Match_variant (lst,tv)
ok @@ O.e_matching ~loc e @@ O.Match_variant lst
| I.Match_record (fields,field_types, expr) ->
let combine fields field_types =
match field_types with
Some ft -> List.combine fields @@ List.map (fun x -> Some x) ft
| None -> List.map (fun x -> (x, None)) fields
in
let%bind next = compile_expression expr in
let%bind field_types = bind_map_option (bind_map_list compile_type_expression) field_types in
let aux ((index,expr) : int * _ ) ((field,name): (O.label * (O.expression_variable * O.type_expression option))) =
let f = fun expr' -> O.e_let_in name false (O.e_record_accessor e field) expr' in
(index+1, fun expr' -> expr (f expr'))
in
let (_,header) = List.fold_left aux (0, fun e -> e) @@
List.map (fun ((a,b),c) -> (a,(b,c))) @@
combine fields field_types
in
ok @@ header next
| I.Match_tuple (fields,field_types, expr) ->
let combine fields field_types =
match field_types with
Some ft -> List.combine fields @@ List.map (fun x -> Some x) ft
| None -> List.map (fun x -> (x, None)) fields
in
let%bind next = compile_expression expr in
let%bind field_types = bind_map_option (bind_map_list compile_type_expression) field_types in
let aux ((index,expr) : int * _ ) (field: O.expression_variable * O.type_expression option) =
let f = fun expr' -> O.e_let_in field false (O.e_record_accessor e (Label (string_of_int index))) expr' in
(index+1, fun expr' -> expr (f expr'))
in
let (_,header) = List.fold_left aux (0, fun e -> e) @@
combine fields field_types
in
ok @@ header next
| I.Match_variable (a, ty_opt, expr) ->
let%bind ty_opt = bind_map_option compile_type_expression ty_opt in
let%bind expr = compile_expression expr in
ok @@ O.e_let_in (a,ty_opt) false e expr
let compile_declaration : I.declaration Location.wrap -> _ =
fun {wrap_content=declaration;location} ->
@ -197,10 +251,10 @@ let compile_declaration : I.declaration Location.wrap -> _ =
match declaration with
| I.Declaration_constant (n, te_opt, inline, expr) ->
let%bind expr = compile_expression expr in
let%bind te_opt = bind_map_option idle_type_expression te_opt in
let%bind te_opt = bind_map_option compile_type_expression te_opt in
return @@ O.Declaration_constant (n, te_opt, inline, expr)
| I.Declaration_type (n, te) ->
let%bind te = idle_type_expression te in
let%bind te = compile_type_expression te in
return @@ O.Declaration_type (n,te)
let compile_program : I.program -> O.program result =
@ -292,11 +346,13 @@ let rec uncompile_expression : O.expression -> I.expression result =
return @@ I.E_record (O.LMap.of_list record)
| O.E_record_accessor {record;path} ->
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} ->
let%bind record = uncompile_expression record 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} ->
let%bind anno_expr = uncompile_expression anno_expr in
let%bind type_annotation = uncompile_type_expression type_annotation in
@ -313,22 +369,19 @@ and uncompile_matching : O.matching_expr -> I.matching_expr result =
match m with
| O.Match_list {match_nil;match_cons} ->
let%bind match_nil = uncompile_expression match_nil in
let (hd,tl,expr,tv) = match_cons in
let (hd,tl,expr) = match_cons in
let%bind expr = uncompile_expression expr in
ok @@ I.Match_list {match_nil; match_cons=(hd,tl,expr,tv)}
ok @@ I.Match_list {match_nil; match_cons=(hd,tl,expr)}
| O.Match_option {match_none;match_some} ->
let%bind match_none = uncompile_expression match_none in
let (n,expr,tv) = match_some in
let (n,expr) = match_some in
let%bind expr = uncompile_expression expr in
ok @@ I.Match_option {match_none; match_some=(n,expr,tv)}
| O.Match_tuple ((lst,expr), tv) ->
let%bind expr = uncompile_expression expr in
ok @@ O.Match_tuple ((lst,expr), tv)
| O.Match_variant (lst,tv) ->
ok @@ I.Match_option {match_none; match_some=(n,expr)}
| O.Match_variant lst ->
let%bind lst = bind_map_list (
fun ((c,n),expr) ->
let%bind expr = uncompile_expression expr in
ok @@ ((c,n),expr)
) lst
in
ok @@ I.Match_variant (lst,tv)
ok @@ I.Match_variant lst

42
src/passes/07-self_ast_core/helpers.ml
View File

@ -72,21 +72,17 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
and fold_cases : 'a folder -> 'a -> matching_expr -> 'a result = fun f init m ->
match m with
| Match_list { match_nil ; match_cons = (_ , _ , cons, _) } -> (
| Match_list { match_nil ; match_cons = (_ , _ , cons) } -> (
let%bind res = fold_expression f init match_nil in
let%bind res = fold_expression f res cons in
ok res
)
| Match_option { match_none ; match_some = (_ , some, _) } -> (
| Match_option { match_none ; match_some = (_ , some) } -> (
let%bind res = fold_expression f init match_none in
let%bind res = fold_expression f res some in
ok res
)
| Match_tuple ((_ , e), _) -> (
let%bind res = fold_expression f init e in
ok res
)
| Match_variant (lst, _) -> (
| Match_variant lst -> (
let aux init' ((_ , _) , e) =
let%bind res' = fold_expression f init' e in
ok res' in
@ -174,27 +170,23 @@ and map_type_expression : ty_exp_mapper -> type_expression -> type_expression re
and map_cases : exp_mapper -> matching_expr -> matching_expr result = fun f m ->
match m with
| Match_list { match_nil ; match_cons = (hd , tl , cons, _) } -> (
| Match_list { match_nil ; match_cons = (hd , tl , cons) } -> (
let%bind match_nil = map_expression f match_nil in
let%bind cons = map_expression f cons in
ok @@ Match_list { match_nil ; match_cons = (hd , tl , cons, ()) }
ok @@ Match_list { match_nil ; match_cons = (hd , tl , cons) }
)
| Match_option { match_none ; match_some = (name , some, _) } -> (
| Match_option { match_none ; match_some = (name , some) } -> (
let%bind match_none = map_expression f match_none in
let%bind some = map_expression f some in
ok @@ Match_option { match_none ; match_some = (name , some, ()) }
ok @@ Match_option { match_none ; match_some = (name , some) }
)
| Match_tuple ((names , e), _) -> (
let%bind e' = map_expression f e in
ok @@ Match_tuple ((names , e'), [])
)
| Match_variant (lst, _) -> (
| Match_variant lst -> (
let aux ((a , b) , e) =
let%bind e' = map_expression f e in
ok ((a , b) , e')
in
let%bind lst' = bind_map_list aux lst in
ok @@ Match_variant (lst', ())
ok @@ Match_variant lst'
)
and map_program : abs_mapper -> program -> program result = fun m p ->
@ -274,25 +266,21 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres
and fold_map_cases : 'a fold_mapper -> 'a -> matching_expr -> ('a * matching_expr) result = fun f init m ->
match m with
| Match_list { match_nil ; match_cons = (hd , tl , cons, _) } -> (
| Match_list { match_nil ; match_cons = (hd , tl , cons) } -> (
let%bind (init, match_nil) = fold_map_expression f init match_nil in
let%bind (init, cons) = fold_map_expression f init cons in
ok @@ (init, Match_list { match_nil ; match_cons = (hd , tl , cons, ()) })
ok @@ (init, Match_list { match_nil ; match_cons = (hd , tl , cons) })
)
| Match_option { match_none ; match_some = (name , some, _) } -> (
| Match_option { match_none ; match_some = (name , some) } -> (
let%bind (init, match_none) = fold_map_expression f init match_none in
let%bind (init, some) = fold_map_expression f init some in
ok @@ (init, Match_option { match_none ; match_some = (name , some, ()) })
ok @@ (init, Match_option { match_none ; match_some = (name , some) })
)
| Match_tuple ((names , e), _) -> (
let%bind (init, e') = fold_map_expression f init e in
ok @@ (init, Match_tuple ((names , e'), []))
)
| Match_variant (lst, _) -> (
| Match_variant lst -> (
let aux init ((a , b) , e) =
let%bind (init,e') = fold_map_expression f init e in
ok (init, ((a , b) , e'))
in
let%bind (init,lst') = bind_fold_map_list aux init lst in
ok @@ (init, Match_variant (lst', ()))
ok @@ (init, Match_variant lst')
)

1
src/passes/08-typer-new/todo_use_fold_generator.ml
View File

@ -3,6 +3,7 @@ module O = Ast_typed
let convert_constructor' (I.Constructor c) = O.Constructor c
let convert_label (I.Label c) = O.Label c
let convert_type_constant : I.type_constant -> O.type_constant = function
| TC_unit -> TC_unit
| TC_string -> TC_string

18
src/passes/08-typer-new/typer.ml
View File

@ -40,7 +40,7 @@ and type_match : environment -> O'.typer_state -> O.type_expression -> I.matchin
trace_strong (match_error ~expected:i ~actual:t loc)
@@ get_t_option t in
let%bind (match_none , state') = type_expression e state match_none in
let (opt, b, _) = match_some in
let (opt, b) = match_some in
let e' = Environment.add_ez_binder opt tv e in
let%bind (body , state'') = type_expression e' state' b in
ok (O.Match_option {match_none ; match_some = { opt; body; tv}} , state'')
@ -49,23 +49,12 @@ and type_match : environment -> O'.typer_state -> O.type_expression -> I.matchin
trace_strong (match_error ~expected:i ~actual:t loc)
@@ get_t_list t in
let%bind (match_nil , state') = type_expression e state match_nil in
let (hd, tl, b, _) = match_cons in
let (hd, tl, b) = match_cons in
let e' = Environment.add_ez_binder hd t_elt e in
let e' = Environment.add_ez_binder tl t e' in
let%bind (body , state'') = type_expression e' state' b in
ok (O.Match_list {match_nil ; match_cons = {hd; tl; body;tv=t}} , state'')
| Match_tuple ((vars, b),_) ->
let%bind tvs =
trace_strong (match_error ~expected:i ~actual:t loc)
@@ get_t_tuple t in
let%bind lst' =
generic_try (match_tuple_wrong_arity tvs vars loc)
@@ (fun () -> List.combine vars tvs) in
let aux prev (name, tv) = Environment.add_ez_binder name tv prev in
let e' = List.fold_left aux e lst' in
let%bind (body , state') = type_expression e' state b in
ok (O.Match_tuple {vars ; body ; tvs} , state')
| Match_variant (lst,_) ->
| Match_variant lst ->
let%bind variant_opt =
let aux acc ((constructor_name , _) , _) =
let%bind (_ , variant) =
@ -362,7 +351,6 @@ and type_expression : environment -> O'.typer_state -> ?tv_opt:O.type_expression
match cur with
| Match_list { match_nil ; match_cons = { hd=_ ; tl=_ ; body ; tv=_} } -> [ match_nil ; body ]
| Match_option { match_none ; match_some = {opt=_; body; tv=_} } -> [ match_none ; body ]
| Match_tuple { vars=_ ; body ; tvs=_ } -> [ body ]
| Match_variant { cases ; tv=_ } -> List.map (fun ({constructor=_; pattern=_; body} : O.matching_content_case) -> body) cases in
List.map get_type_expression @@ aux m' in
let%bind () = match tvs with

13
src/passes/08-typer-new/untyper.ml
View File

@ -264,8 +264,8 @@ let rec untype_expression (e:O.expression) : (I.expression) result =
return (e_record @@ LMap.of_list r')
| E_record_accessor {record; path} ->
let%bind r' = untype_expression record in
let Label s = path in
return (e_record_accessor r' s)
let Label path = path in
return (e_record_accessor r' (Label path))
| E_record_update {record; path; update} ->
let%bind r' = untype_expression record in
let%bind e = untype_expression update in
@ -299,22 +299,19 @@ and untype_lambda ty {binder; result} : I.lambda result =
and untype_matching : (O.expression -> I.expression result) -> O.matching_expr -> I.matching_expr result = fun f m ->
let open I in
match m with
| Match_tuple { vars ; body ; tvs=_ } ->
let%bind b = f body in
ok @@ I.Match_tuple ((vars, b),[])
| Match_option {match_none ; match_some = {opt; body;tv=_}} ->
let%bind match_none = f match_none in
let%bind some = f body in
let match_some = opt, some, () in
let match_some = opt, some in
ok @@ Match_option {match_none ; match_some}
| Match_list {match_nil ; match_cons = {hd;tl;body;tv=_}} ->
let%bind match_nil = f match_nil in
let%bind cons = f body in
let match_cons = hd , tl , cons, () in
let match_cons = hd , tl , cons in
ok @@ Match_list {match_nil ; match_cons}
| Match_variant { cases ; tv=_ } ->
let aux ({constructor;pattern;body} : O.matching_content_case) =
let%bind body = f body in
ok ((unconvert_constructor' constructor,pattern),body) in
let%bind lst' = bind_map_list aux cases in
ok @@ Match_variant (lst',())
ok @@ Match_variant lst'

40
src/passes/08-typer-old/typer.ml
View File

@ -125,17 +125,6 @@ module Errors = struct
] in
error ~data title message ()
let match_tuple_wrong_arity (expected:'a list) (actual:'b list) (loc:Location.t) () =
let title () = "matching tuple of different size" in
let message () = "" in
let data = [
("expected" , fun () -> Format.asprintf "%d" (List.length expected)) ;
("actual" , fun () -> Format.asprintf "%d" (List.length actual)) ;
("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in
error ~data title message ()
(* TODO: this should be a trace_info? *)
let program_error (p:I.program) () =
let message () = "" in
@ -528,7 +517,7 @@ and type_match : (environment -> I.expression -> O.expression result) -> environ
trace_strong (match_error ~expected:i ~actual:t loc)
@@ get_t_option t in
let%bind match_none = f e match_none in
let (opt, b,_) = match_some in
let (opt, b) = match_some in
let e' = Environment.add_ez_binder opt tv e in
let%bind body = f e' b in
ok (O.Match_option {match_none ; match_some = {opt; body; tv}})
@ -537,23 +526,12 @@ and type_match : (environment -> I.expression -> O.expression result) -> environ
trace_strong (match_error ~expected:i ~actual:t loc)
@@ get_t_list t in
let%bind match_nil = f e match_nil in
let (hd, tl, b,_) = match_cons in
let (hd, tl, b) = match_cons in
let e' = Environment.add_ez_binder hd t_elt e in
let e' = Environment.add_ez_binder tl t e' in
let%bind body = f e' b in
ok (O.Match_list {match_nil ; match_cons = {hd; tl; body; tv=t_elt}})
| Match_tuple ((vars, b),_) ->
let%bind tvs =
trace_strong (match_error ~expected:i ~actual:t loc)
@@ get_t_tuple t in
let%bind vars' =
generic_try (match_tuple_wrong_arity tvs vars loc)
@@ (fun () -> List.combine vars tvs) in
let aux prev (name, tv) = Environment.add_ez_binder name tv prev in
let e' = List.fold_left aux e vars' in
let%bind body = f e' b in
ok (O.Match_tuple { vars ; body ; tvs})
| Match_variant (lst,_) ->
| Match_variant lst ->
let%bind variant_cases' =
trace (match_error ~expected:i ~actual:t loc)
@@ Ast_typed.Combinators.get_t_sum t in
@ -937,7 +915,6 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
match cur with
| Match_list { match_nil ; match_cons = {hd=_ ; tl=_ ; body ; tv=_} } -> [ match_nil ; body ]
| Match_option { match_none ; match_some = {opt=_ ; body ; tv=_ } } -> [ match_none ; body ]
| Match_tuple {vars=_;body;tvs=_} -> [ body ]
| Match_variant {cases; tv=_} -> List.map (fun (c : O.matching_content_case) -> c.body) cases in
List.map get_type_expression @@ aux m' in
let aux prec cur =
@ -1081,7 +1058,7 @@ let rec untype_expression (e:O.expression) : (I.expression) result =
| E_record_accessor {record; path} ->
let%bind r' = untype_expression record in
let Label s = path in
return (e_record_accessor r' s)
return (e_record_accessor r' (Label s))
| E_record_update {record=r; path=O.Label l; update=e} ->
let%bind r' = untype_expression r in
let%bind e = untype_expression e in
@ -1104,22 +1081,19 @@ let rec untype_expression (e:O.expression) : (I.expression) result =
and untype_matching : (O.expression -> I.expression result) -> O.matching_expr -> I.matching_expr result = fun f m ->
let open I in
match m with
| Match_tuple {vars; body;tvs=_} ->
let%bind b = f body in
ok @@ I.Match_tuple ((vars, b),[])
| Match_option {match_none ; match_some = {opt; body ; tv=_}} ->
let%bind match_none = f match_none in
let%bind some = f body in
let match_some = opt, some, () in
let match_some = opt, some in
ok @@ Match_option {match_none ; match_some}
| Match_list {match_nil ; match_cons = {hd ; tl ; body ; tv=_}} ->
let%bind match_nil = f match_nil in
let%bind cons = f body in
let match_cons = hd , tl , cons, () in
let match_cons = hd , tl , cons in
ok @@ Match_list {match_nil ; match_cons}
| Match_variant {cases;tv=_} ->
let aux ({constructor;pattern;body} : O.matching_content_case) =
let%bind c' = f body in
ok ((unconvert_constructor' constructor,pattern),c') in
let%bind lst' = bind_map_list aux cases in
ok @@ Match_variant (lst',())
ok @@ Match_variant lst'

12
src/passes/09-self_ast_typed/helpers.ml
View File

@ -63,10 +63,6 @@ and fold_cases : 'a . 'a folder -> 'a -> matching_expr -> 'a result = fun f init
let%bind res = fold_expression f res body in
ok res
)
| Match_tuple {vars=_ ; body; tvs=_} -> (
let%bind res = fold_expression f init body in
ok res
)
| Match_variant {cases;tv=_} -> (
let aux init' {constructor=_; pattern=_ ; body} =
let%bind res' = fold_expression f init' body in
@ -140,10 +136,6 @@ and map_cases : mapper -> matching_expr -> matching_expr result = fun f m ->
let%bind body = map_expression f body in
ok @@ Match_option { match_none ; match_some = { opt ; body ; tv } }
)
| Match_tuple { vars ; body ; tvs } -> (
let%bind body = map_expression f body in
ok @@ Match_tuple { vars ; body ; tvs }
)
| Match_variant {cases;tv} -> (
let aux { constructor ; pattern ; body } =
let%bind body = map_expression f body in
@ -231,10 +223,6 @@ and fold_map_cases : 'a . 'a fold_mapper -> 'a -> matching_expr -> ('a * matchin
let%bind (init, body) = fold_map_expression f init body in
ok @@ (init, Match_option { match_none ; match_some = { opt ; body ; tv } })
)
| Match_tuple { vars ; body ; tvs } -> (
let%bind (init, body) = fold_map_expression f init body in
ok @@ (init, Match_tuple {vars ; body ; tvs })
)
| Match_variant {cases ; tv} -> (
let aux init {constructor ; pattern ; body} =
let%bind (init, body) = fold_map_expression f init body in

3
src/passes/09-self_ast_typed/tail_recursion.ml
View File

@ -67,9 +67,6 @@ and check_recursive_call_in_matching = fun n final_path c ->
let%bind _ = check_recursive_call n final_path match_none in
let%bind _ = check_recursive_call n final_path body in
ok ()
| Match_tuple {vars=_;body;tvs=_} ->
let%bind _ = check_recursive_call n final_path body in
ok ()
| Match_variant {cases;tv=_} ->
let aux {constructor=_; pattern=_; body} =
let%bind _ = check_recursive_call n final_path body in

12
src/passes/10-transpiler/transpiler.ml
View File

@ -32,16 +32,6 @@ them. please report this to the developers." in
let content () = Format.asprintf "%a" Var.pp name in
error title content
let row_loc l = ("location" , fun () -> Format.asprintf "%a" Location.pp l)
let unsupported_pattern_matching kind location =
let title () = "unsupported pattern-matching" in
let content () = Format.asprintf "%s patterns aren't supported yet" kind in
let data = [
row_loc location ;
] in
error ~data title content
let not_functional_main location =
let title () = "not functional main" in
let content () = "main should be a function" in
@ -615,7 +605,6 @@ and transpile_annotated_expression (ae:AST.expression) : expression result =
trace_strong (corner_case ~loc:__LOC__ "building constructor") @@
aux expr' tree''
)
| AST.Match_tuple _ -> fail @@ unsupported_pattern_matching "tuple" ae.location
)
and transpile_lambda l (input_type , output_type) =
@ -739,7 +728,6 @@ and transpile_recursive {fun_name; fun_type; lambda} =
trace_strong (corner_case ~loc:__LOC__ "building constructor") @@
aux expr tree''
)
| AST.Match_tuple _ -> failwith "match_tuple not supported"
in
let%bind fun_type = transpile_type fun_type in
let%bind (input_type,output_type) = get_t_function fun_type in

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

@ -83,10 +83,10 @@ and expression_content ppf (ec : expression_content) =
c.arguments
| E_record m ->
fprintf ppf "{%a}" (record_sep expression (const ";")) m
| E_record_accessor ra ->
fprintf ppf "%a.%a" expression ra.record label ra.path
| E_record_update {record; path; update} ->
fprintf ppf "{ %a with %a = %a }" expression record label path expression update
| E_accessor {record;path} ->
fprintf ppf "%a.%a" expression record (list_sep accessor (const ".")) path
| E_update {record; path; update} ->
fprintf ppf "{ %a with %a = %a }" expression record (list_sep accessor (const ".")) path expression update
| E_map m ->
fprintf ppf "map[%a]" (list_sep_d assoc_expression) 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
| E_set 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} ->
fprintf ppf "lambda (%a:%a) : %a return %a"
expression_variable binder
@ -129,14 +127,10 @@ and expression_content ppf (ec : expression_content) =
fprintf ppf "skip"
| E_tuple 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} ->
fprintf ppf "%a%a := %a"
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
| E_for {binder; start; final; increment; body} ->
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 =
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_map e -> fprintf ppf "%a" expression e
@ -184,27 +178,35 @@ and matching_variant_case : type a . (_ -> a -> unit) -> _ -> (constructor' * ex
fun f ppf ((c,n),a) ->
fprintf ppf "| %a %a -> %a" constructor c expression_variable n f a
and matching : type a . (formatter -> a -> unit) -> formatter -> (a,unit) matching_content -> unit =
and matching : (formatter -> expression -> unit) -> formatter -> matching_expr -> unit =
fun f ppf m -> match m with
| Match_tuple ((lst, b), _) ->
fprintf ppf "let (%a) = %a" (list_sep_d expression_variable) lst f b
| Match_variant (lst, _) ->
| Match_variant lst ->
fprintf ppf "%a" (list_sep (matching_variant_case f) (tag "@.")) lst
| Match_list {match_nil ; match_cons = (hd, tl, match_cons, _)} ->
| Match_list {match_nil ; match_cons = (hd, tl, match_cons)} ->
fprintf ppf "| Nil -> %a @.| %a :: %a -> %a" f match_nil expression_variable hd expression_variable tl f match_cons
| Match_option {match_none ; match_some = (some, match_some, _)} ->
| Match_option {match_none ; match_some = (some, match_some)} ->
fprintf ppf "| None -> %a @.| Some %a -> %a" f match_none expression_variable some f match_some
| Match_tuple (lst, _,b) ->
fprintf ppf "(%a) -> %a" (list_sep_d expression_variable) lst f b
| Match_record (lst, _,b) ->
fprintf ppf "{%a} -> %a" (list_sep_d (fun ppf (a,b) -> fprintf ppf "%a = %a" label a expression_variable b)) lst f b
| Match_variable (a, _,b) ->
fprintf ppf "%a -> %a" expression_variable a f b
(* Shows the type expected for the matched value *)
and matching_type ppf m = match m with
| Match_tuple _ ->
fprintf ppf "tuple"
| Match_variant (lst, _) ->
| Match_variant lst ->
fprintf ppf "variant %a" (list_sep matching_variant_case_type (tag "@.")) lst
| Match_list _ ->
fprintf ppf "list"
| Match_option _ ->
fprintf ppf "option"
| Match_tuple _ ->
fprintf ppf "tuple"
| Match_record _ ->
fprintf ppf "record"
| Match_variable _ ->
fprintf ppf "variable"
and matching_variant_case_type ppf ((c,n),_a) =
fprintf ppf "| %a %a" constructor c expression_variable n

21
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_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_list ?loc a b = List.fold_left (fun a b -> e_record_accessor ?loc a b) a b
let e_record_update ?loc record path update = make_e ?loc @@ E_record_update {record; path=Label path; update}
let e_accessor ?loc record path = make_e ?loc @@ E_accessor {record; path}
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_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_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_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_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_for ?loc binder start final increment body = make_e ?loc @@ E_for {binder;start;final;increment;body}
@ -148,9 +144,14 @@ let e_bool ?loc b : expression = e_constructor ?loc (string_of_bool b) (e_unit
let ez_match_variant (lst : ((string * string) * 'a) list) =
let lst = List.map (fun ((c,n),a) -> ((Constructor c, Var.of_name n), a) ) lst in
Match_variant (lst,())
Match_variant lst
let e_matching_variant ?loc a (lst : ((string * string)* 'a) list) =
e_matching ?loc a (ez_match_variant lst)
let e_matching_record ?loc m lst ty_opt expr = e_matching ?loc m @@ Match_record (lst,ty_opt, expr)
let e_matching_tuple ?loc m lst ty_opt expr = e_matching ?loc m @@ Match_tuple (lst,ty_opt, expr)
let e_matching_variable ?loc m var ty_opt expr = e_matching ?loc m @@ Match_variable (var,ty_opt, expr)
let e_record_ez ?loc (lst : (string * expr) list) : expression =
let map = List.fold_left (fun m (x, y) -> LMap.add (Label x) y m) LMap.empty lst in
make_e ?loc @@ E_record map
@ -184,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 =
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 ->
match t with
| E_record_accessor {record; path} -> ok (record , path)
| E_accessor {record; path} -> ok (record , path)
| _ -> simple_fail "not an accessor"
let assert_e_accessor = fun t ->

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

@ -98,20 +98,20 @@ val e_let_in : ?loc:Location.t -> ( expression_variable * type_expression option
val e_constructor : ?loc:Location.t -> string -> expression -> expression
val e_matching : ?loc:Location.t -> expression -> matching_expr -> expression
val ez_match_variant : ((string * string ) * 'a ) list -> ('a,unit) matching_content
val ez_match_variant : ((string * string ) * expression) list -> matching_expr
val e_matching_variant : ?loc:Location.t -> expression -> ((string * string) * expression) list -> expression
val e_matching_record : ?loc:Location.t -> expression -> (label * expression_variable) list -> type_expression list option -> expression -> expression
val e_matching_tuple : ?loc:Location.t -> expression -> expression_variable list -> type_expression list option -> expression -> expression
val e_matching_variable: ?loc:Location.t -> expression -> expression_variable -> type_expression option -> expression -> 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_accessor : ?loc:Location.t -> expression -> string -> expression
val e_accessor_list : ?loc:Location.t -> expression -> string list -> expression
val e_record_update : ?loc:Location.t -> expression -> string -> expression -> expression
val e_accessor : ?loc:Location.t -> expression -> access list -> expression
val e_update : ?loc:Location.t -> expression -> access list -> expression -> expression
val e_annotation : ?loc:Location.t -> expression -> type_expression -> 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_cond: ?loc:Location.t -> expression -> expression -> expression -> expression
@ -122,10 +122,8 @@ val e_list : ?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_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_ez_assign : ?loc:Location.t -> string -> string list -> expression -> expression
val e_while : ?loc:Location.t -> expression -> expression -> expression
val e_for : ?loc:Location.t -> expression_variable -> expression -> expression -> expression -> expression -> expression

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

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

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

@ -78,10 +78,10 @@ and expression_content ppf (ec : expression_content) =
c.arguments
| E_record m ->
fprintf ppf "{%a}" (record_sep_expr expression (const ";")) m
| E_record_accessor ra ->
fprintf ppf "%a.%a" expression ra.record label ra.path
| E_record_update {record; path; update} ->
fprintf ppf "{ %a with %a = %a }" expression record label path expression update
| E_accessor {record;path} ->
fprintf ppf "%a.%a" expression record (list_sep accessor (const ".")) path
| E_update {record; path; update} ->
fprintf ppf "{ %a with %a = %a }" expression record (list_sep accessor (const ".")) path expression update
| E_map m ->
fprintf ppf "map[%a]" (list_sep_d assoc_expression) 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
| E_set 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} ->
fprintf ppf "lambda (%a:%a) : %a return %a"
expression_variable binder
@ -127,10 +125,12 @@ and expression_content ppf (ec : expression_content) =
fprintf ppf "skip"
| E_tuple 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
and accessor ppf a =
match a with
| 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
((n, ty_opt) : expression_variable * type_expression option) =
@ -150,27 +150,35 @@ and matching_variant_case : type a . (_ -> a -> unit) -> _ -> (constructor' * ex
fun f ppf ((c,n),a) ->
fprintf ppf "| %a %a -> %a" constructor c expression_variable n f a
and matching : type a . (formatter -> a -> unit) -> formatter -> (a,unit) matching_content -> unit =
and matching : (formatter -> expression -> unit) -> formatter -> matching_expr -> unit =
fun f ppf m -> match m with
| Match_tuple ((lst, b), _) ->
fprintf ppf "let (%a) = %a" (list_sep_d expression_variable) lst f b
| Match_variant (lst, _) ->
| Match_variant lst ->
fprintf ppf "%a" (list_sep (matching_variant_case f) (tag "@.")) lst
| Match_list {match_nil ; match_cons = (hd, tl, match_cons, _)} ->
| Match_list {match_nil ; match_cons = (hd, tl, match_cons)} ->
fprintf ppf "| Nil -> %a @.| %a :: %a -> %a" f match_nil expression_variable hd expression_variable tl f match_cons
| Match_option {match_none ; match_some = (some, match_some, _)} ->
| Match_option {match_none ; match_some = (some, match_some)} ->
fprintf ppf "| None -> %a @.| Some %a -> %a" f match_none expression_variable some f match_some
| Match_tuple (lst, _,b) ->
fprintf ppf "(%a) -> %a" (list_sep_d expression_variable) lst f b
| Match_record (lst, _,b) ->
fprintf ppf "{%a} -> %a" (list_sep_d (fun ppf (a,b) -> fprintf ppf "%a = %a" label a expression_variable b)) lst f b
| Match_variable (a, _,b) ->
fprintf ppf "%a -> %a" expression_variable a f b
(* Shows the type expected for the matched value *)
and matching_type ppf m = match m with
| Match_tuple _ ->
fprintf ppf "tuple"
| Match_variant (lst, _) ->
| Match_variant lst ->
fprintf ppf "variant %a" (list_sep matching_variant_case_type (tag "@.")) lst
| Match_list _ ->
fprintf ppf "list"
| Match_option _ ->
fprintf ppf "option"
| Match_tuple _ ->
fprintf ppf "tuple"
| Match_record _ ->
fprintf ppf "record"
| Match_variable _ ->
fprintf ppf "variable"
and matching_variant_case_type ppf ((c,n),_a) =
fprintf ppf "| %a %a" constructor c expression_variable n

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_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_record_update ?loc record path update = make_e ?loc @@ E_record_update {record; path; update}
let e_accessor ?loc record path = make_e ?loc @@ E_accessor {record; path}
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_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_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_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_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 ())
@ -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
| E_record_accessor {record; path} -> ok (record, path)
| E_accessor {record; path} -> ok (record, path)
| _ -> simple_fail "not a record accessor"
let assert_e_accessor = fun t ->
let%bind _ = get_e_record_accessor t in
let%bind _ = get_e_accessor t in
ok ()
let get_e_pair = fun t ->

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

@ -78,15 +78,13 @@ val e_application : ?loc:Location.t -> expression -> expression -> expression
val e_recursive : ?loc:Location.t -> expression_variable -> type_expression -> lambda -> 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_accessor : ?loc:Location.t -> expression -> label -> expression
val e_record_update : ?loc:Location.t -> expression -> label -> expression -> expression
val e_record : ?loc:Location.t -> expr label_map -> expression
val e_accessor : ?loc:Location.t -> expression -> access list -> expression
val e_update : ?loc:Location.t -> expression -> access list -> expression -> expression
val e_annotation : ?loc:Location.t -> expression -> type_expression -> 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_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_map : ?loc:Location.t -> ( expression * expression ) 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

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

@ -54,8 +54,8 @@ and expression_content =
| E_matching of matching
(* Record *)
| E_record of expression label_map
| E_record_accessor of record_accessor
| E_record_update of record_update
| E_accessor of accessor
| E_update of update
(* Advanced *)
| E_ascription of ascription
(* Sugar *)
@ -63,14 +63,11 @@ and expression_content =
| E_sequence of sequence
| E_skip
| E_tuple of expression list
| E_tuple_accessor of tuple_accessor
| E_tuple_update of tuple_update
(* Data Structures *)
| E_map of (expression * expression) list
| E_big_map of (expression * expression) list
| E_list of expression list
| E_set of expression list
| E_look_up of (expression * expression)
and constant =
{ cons_name: constant' (* this is at the end because it is huge *)
@ -103,10 +100,28 @@ and let_in = {
and constructor = {constructor: constructor'; element: expression}
and record_accessor = {record: expression; path: label}
and record_update = {record: expression; path: label ; update: expression}
and accessor = {record: expression; path: access list}
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 =
| Match_variant of ((constructor' * expression_variable) * expression) list
| Match_list of {
match_nil : expression ;
match_cons : expression_variable * expression_variable * expression ;
}
| Match_option of {
match_none : expression ;
match_some : expression_variable * expression ;
}
| Match_tuple of expression_variable list * type_expression list option * expression
| Match_record of (label * expression_variable) list * type_expression list option * expression
| Match_variable of expression_variable * type_expression option * expression
and matching_expr = (expr,unit) matching_content
and matching =
{ matchee: expression
; cases: matching_expr
@ -124,9 +139,6 @@ and sequence = {
expr2: expression ;
}
and tuple_accessor = {tuple: expression; path: int}
and tuple_update = {tuple: expression; path: int ; update: expression}
and environment_element_definition =
| ED_binder
| ED_declaration of (expression * free_variables)

16
src/stages/3-ast_core/PP.ml
View File

@ -66,26 +66,22 @@ and assoc_expression ppf : expr * expr -> unit =
and single_record_patch ppf ((p, expr) : label * expr) =
fprintf ppf "%a <- %a" label p expression expr
and matching_variant_case : type a . (_ -> a -> unit) -> _ -> (constructor' * expression_variable) * a -> unit =
and matching_variant_case : (_ -> expression -> unit) -> _ -> (constructor' * expression_variable) * expression -> unit =
fun f ppf ((c,n),a) ->
fprintf ppf "| %a %a ->@;<1 2>%a@ " constructor c expression_variable n f a
and matching : type a . (formatter -> a -> unit) -> formatter -> (a,unit) matching_content -> unit =
and matching : (formatter -> expression -> unit) -> formatter -> matching_expr -> unit =
fun f ppf m -> match m with
| Match_tuple ((lst, b), _) ->
fprintf ppf "@[<hv>| (%a) ->@;<1 2>%a@]" (list_sep_d expression_variable) lst f b
| Match_variant (lst, _) ->
| Match_variant lst ->
fprintf ppf "@[<hv>%a@]" (list_sep (matching_variant_case f) (tag "@ ")) lst
| Match_list {match_nil ; match_cons = (hd, tl, match_cons, _)} ->
| Match_list {match_nil ; match_cons = (hd, tl, match_cons)} ->
fprintf ppf "@[<hv>| Nil ->@;<1 2>%a@ | %a :: %a ->@;<1 2>%a@]" f match_nil expression_variable hd expression_variable tl f match_cons
| Match_option {match_none ; match_some = (some, match_some, _)} ->
| Match_option {match_none ; match_some = (some, match_some)} ->
fprintf ppf "@[<hv>| None ->@;<1 2>%a@ | Some %a ->@;<1 2>%a@]" f match_none expression_variable some f match_some
(* Shows the type expected for the matched value *)
and matching_type ppf m = match m with
| Match_tuple _ ->
fprintf ppf "tuple"
| Match_variant (lst, _) ->
| Match_variant lst ->
fprintf ppf "variant %a" (list_sep matching_variant_case_type (tag "@.")) lst
| Match_list _ ->
fprintf ppf "list"

2
src/stages/3-ast_core/combinators.ml
View File

@ -107,7 +107,7 @@ 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_record ?loc map = make_e ?loc @@ E_record map
let e_record_accessor ?loc a b = make_e ?loc @@ E_record_accessor {record = a; path = Label b}
let e_record_accessor ?loc a b = make_e ?loc @@ E_record_accessor {record = a; path = b}
let e_record_update ?loc record path update = make_e ?loc @@ E_record_update {record; path; update}
let e_annotation ?loc anno_expr ty = make_e ?loc @@ E_ascription {anno_expr; type_annotation = ty}

2
src/stages/3-ast_core/combinators.mli
View File

@ -74,7 +74,7 @@ val e_string_cat : ?loc:Location.t -> expression -> expression -> expression
val e_map_add : ?loc:Location.t -> expression -> expression -> expression -> expression
val e_constructor : ?loc:Location.t -> string -> expression -> expression
val e_matching : ?loc:Location.t -> expression -> matching_expr -> expression
val e_record_accessor : ?loc:Location.t -> expression -> string -> expression
val e_record_accessor : ?loc:Location.t -> expression -> label -> expression
val e_variable : ?loc:Location.t -> expression_variable -> expression
val e_let_in : ?loc:Location.t -> ( expression_variable * type_expression option ) -> bool -> expression -> expression -> expression
val e_annotation : ?loc:Location.t -> expression -> type_expression -> expression

12
src/stages/3-ast_core/types.ml
View File

@ -76,7 +76,17 @@ and constructor = {constructor: constructor'; element: expression}
and record_accessor = {record: expression; path: label}
and record_update = {record: expression; path: label ; update: expression}
and matching_expr = (expr,unit) matching_content
and matching_expr =
| Match_list of {
match_nil : expression ;
match_cons : expression_variable * expression_variable * expression ;
}
| Match_option of {
match_none : expression ;
match_some : expression_variable * expression ;
}
| Match_variant of ((constructor' * expression_variable) * expression) list
and matching =
{ matchee: expression
; cases: matching_expr

2
src/stages/4-ast_typed/PP.ml
View File

@ -315,8 +315,6 @@ and matching_variant_case : (_ -> expression -> unit) -> _ -> matching_content_c
fprintf ppf "| %a %a -> %a" constructor c expression_variable pattern f body
and matching : (formatter -> expression -> unit) -> _ -> matching_expr -> unit = fun f ppf m -> match m with
| Match_tuple {vars; body; tvs=_} ->
fprintf ppf "let (%a) = %a" (list_sep_d expression_variable) vars f body
| Match_variant {cases ; tv=_} ->
fprintf ppf "%a" (list_sep (matching_variant_case f) (tag "@.")) cases
| Match_list {match_nil ; match_cons = {hd; tl; body; tv=_}} ->

7
src/stages/4-ast_typed/ast.ml
View File

@ -124,12 +124,6 @@ and matching_content_option = {
and expression_variable_list = expression_variable list
and type_expression_list = type_expression list
and matching_content_tuple = {
vars : expression_variable_list ;
body : expression ;
tvs : type_expression_list ;
}
and matching_content_case = {
constructor : constructor' ;
pattern : expression_variable ;
@ -146,7 +140,6 @@ and matching_content_variant = {
and matching_expr =
| Match_list of matching_content_list
| Match_option of matching_content_option
| Match_tuple of matching_content_tuple
| Match_variant of matching_content_variant
and constant' =

15
src/stages/4-ast_typed/compute_environment.ml
View File

@ -92,21 +92,6 @@ and cases : environment -> matching_expr -> matching_expr = fun env cs ->
in
return @@ Match_option { match_none ; match_some }
)
| Match_tuple c -> (
let var_tvs =
try (
List.combine c.vars c.tvs
) with _ -> raise (Failure ("Internal error: broken invariant at " ^ __LOC__))
in
let env' =
let aux prev (var , tv) =
Environment.add_ez_binder var tv prev
in
List.fold_left aux env var_tvs
in
let body = self ~env' c.body in
return @@ Match_tuple { c with body }
)
| Match_variant c -> (
let variant_type = Combinators.get_t_sum_exn c.tv in
let cases =

2
src/stages/4-ast_typed/misc.ml
View File

@ -236,8 +236,6 @@ module Free_variables = struct
match m with
| Match_list { match_nil = n ; match_cons = {hd; tl; body; tv=_} } -> union (f b n) (f (union (of_list [hd ; tl]) b) body)
| Match_option { match_none = n ; match_some = {opt; body; tv=_} } -> union (f b n) (f (union (singleton opt) b) body)
| Match_tuple { vars ; body ; tvs=_ } ->
f (union (of_list vars) b) body
| Match_variant { cases ; tv=_ } -> unions @@ List.map (matching_variant_case f b) cases
and matching_expression = fun x -> matching expression x

2
src/stages/4-ast_typed/misc_smart.ml
View File

@ -90,8 +90,6 @@ module Captured_variables = struct
let%bind n' = f b n in
let%bind s' = f (union (singleton opt) b) body in
ok @@ union n' s'
| Match_tuple { vars ; body ; tvs=_ } ->
f (union (of_list vars) b) body
| Match_variant { cases ; tv=_ } ->
let%bind lst' = bind_map_list (matching_variant_case f b) cases in
ok @@ unions lst'

2
src/stages/common/ast_common.ml
View File

@ -1,3 +1,5 @@
include Types
module Types = Types
module PP = PP
module Helpers = Helpers

13
src/stages/common/types.ml
View File

@ -11,6 +11,7 @@ type label = Label of string
module CMap = Map.Make( struct type t = constructor' let compare (Constructor a) (Constructor b) = compare a b end)
module LMap = Map.Make( struct type t = label let compare (Label a) (Label b) = String.compare a b end)
type 'a label_map = 'a LMap.t
type 'a constructor_map = 'a CMap.t
@ -169,18 +170,6 @@ type literal =
| Literal_void
| Literal_operation of
Memory_proto_alpha.Protocol.Alpha_context.packed_internal_operation
and ('a,'tv) matching_content =
| Match_list of {
match_nil : 'a ;
match_cons : expression_variable * expression_variable * 'a * 'tv;
}
| Match_option of {
match_none : 'a ;
match_some : expression_variable * 'a * 'tv;
}
| Match_tuple of (expression_variable list * 'a) * 'tv list
| Match_variant of ((constructor' * expression_variable) * 'a) list * 'tv
and constant' =
| C_INT
| C_UNIT