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

Merge branch 'dev' of gitlab.com:ligolang/ligo into rinderknecht@pprint

Browse Source
This commit is contained in:
Christian Rinderknecht 2020-06-08 16:05:23 +02:00
commit dfbba95cbf
43 changed files with 1534 additions and 1554 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

@ -349,7 +349,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

@ -643,8 +643,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

@ -526,7 +526,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
@ -972,7 +972,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

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

@ -2002,7 +2002,7 @@ interactive_expr: LBRACE Ident DOT Ident Verbatim
interactive_expr: LBRACE Ident EQ Bytes SEMI Ident EQ Bytes SEMI With
##
## Ends in an error in state: 554.
## Ends in an error in state: 551.
##
## nsepseq(field_assignment,SEMI) -> field_assignment SEMI . nsepseq(field_assignment,SEMI) [ RBRACE ]
## seq(__anonymous_0(field_assignment,SEMI)) -> field_assignment SEMI . seq(__anonymous_0(field_assignment,SEMI)) [ RBRACE ]
@ -2015,7 +2015,7 @@ interactive_expr: LBRACE Ident EQ Bytes SEMI Ident EQ Bytes SEMI With
interactive_expr: LBRACE Ident EQ Bytes SEMI Ident EQ Bytes With
##
## Ends in an error in state: 553.
## Ends in an error in state: 550.
##
## nsepseq(field_assignment,SEMI) -> field_assignment . [ RBRACE ]
## nsepseq(field_assignment,SEMI) -> field_assignment . SEMI nsepseq(field_assignment,SEMI) [ RBRACE ]
@ -2047,7 +2047,7 @@ interactive_expr: LBRACE Ident EQ Bytes SEMI Ident EQ Bytes With
interactive_expr: LBRACE Ident EQ Bytes SEMI Ident With
##
## Ends in an error in state: 550.
## Ends in an error in state: 547.
##
## field_assignment -> Ident . EQ expr [ SEMI RBRACE ]
##
@ -2059,7 +2059,7 @@ interactive_expr: LBRACE Ident EQ Bytes SEMI Ident With
interactive_expr: LBRACE Ident EQ Bytes SEMI With
##
## Ends in an error in state: 549.
## Ends in an error in state: 546.
##
## nsepseq(field_assignment,SEMI) -> field_assignment SEMI . nsepseq(field_assignment,SEMI) [ RBRACE ]
## nseq(__anonymous_0(field_assignment,SEMI)) -> field_assignment SEMI . seq(__anonymous_0(field_assignment,SEMI)) [ RBRACE ]
@ -2072,7 +2072,7 @@ interactive_expr: LBRACE Ident EQ Bytes SEMI With
interactive_expr: LBRACE Ident EQ Bytes With
##
## Ends in an error in state: 548.
## Ends in an error in state: 545.
##
## nsepseq(field_assignment,SEMI) -> field_assignment . [ RBRACE ]
## nsepseq(field_assignment,SEMI) -> field_assignment . SEMI nsepseq(field_assignment,SEMI) [ RBRACE ]
@ -2128,21 +2128,9 @@ interactive_expr: LBRACE Ident WILD
<YOUR SYNTAX ERROR MESSAGE HERE>
interactive_expr: LBRACE Ident With Ident DOT With
interactive_expr: LBRACE Ident With Int EQ Bytes SEMI Int EQ Bytes SEMI With
##
## Ends in an error in state: 530.
##
## nsepseq(field_name,DOT) -> Ident DOT . nsepseq(field_name,DOT) [ EQ ]
##
## The known suffix of the stack is as follows:
## Ident DOT
##
<YOUR SYNTAX ERROR MESSAGE HERE>
interactive_expr: LBRACE Ident With Ident EQ Bytes SEMI Ident EQ Bytes SEMI With
##
## Ends in an error in state: 544.
## Ends in an error in state: 541.
##
## nsepseq(field_path_assignment,SEMI) -> field_path_assignment SEMI . nsepseq(field_path_assignment,SEMI) [ RBRACE ]
## seq(__anonymous_0(field_path_assignment,SEMI)) -> field_path_assignment SEMI . seq(__anonymous_0(field_path_assignment,SEMI)) [ RBRACE ]
@ -2153,9 +2141,9 @@ interactive_expr: LBRACE Ident With Ident EQ Bytes SEMI Ident EQ Bytes SEMI With
<YOUR SYNTAX ERROR MESSAGE HERE>
interactive_expr: LBRACE Ident With Ident EQ Bytes SEMI Ident EQ Bytes With
interactive_expr: LBRACE Ident With Int EQ Bytes SEMI Int EQ Bytes With
##
## Ends in an error in state: 543.
## Ends in an error in state: 540.
##
## nsepseq(field_path_assignment,SEMI) -> field_path_assignment . [ RBRACE ]
## nsepseq(field_path_assignment,SEMI) -> field_path_assignment . SEMI nsepseq(field_path_assignment,SEMI) [ RBRACE ]
@ -2180,14 +2168,14 @@ interactive_expr: LBRACE Ident With Ident EQ Bytes SEMI Ident EQ Bytes With
## In state 368, spurious reduction of production base_expr(expr) -> disj_expr_level
## In state 370, spurious reduction of production base_cond__open(expr) -> base_expr(expr)
## In state 371, spurious reduction of production expr -> base_cond__open(expr)
## In state 538, spurious reduction of production field_path_assignment -> nsepseq(field_name,DOT) EQ expr
## In state 534, spurious reduction of production field_path_assignment -> nsepseq(selection,DOT) EQ expr
##
<YOUR SYNTAX ERROR MESSAGE HERE>
interactive_expr: LBRACE Ident With Ident EQ Bytes SEMI With
interactive_expr: LBRACE Ident With Int EQ Bytes SEMI With
##
## Ends in an error in state: 540.
## Ends in an error in state: 537.
##
## nsepseq(field_path_assignment,SEMI) -> field_path_assignment SEMI . nsepseq(field_path_assignment,SEMI) [ RBRACE ]
## nseq(__anonymous_0(field_path_assignment,SEMI)) -> field_path_assignment SEMI . seq(__anonymous_0(field_path_assignment,SEMI)) [ RBRACE ]
@ -2198,9 +2186,9 @@ interactive_expr: LBRACE Ident With Ident EQ Bytes SEMI With
<YOUR SYNTAX ERROR MESSAGE HERE>
interactive_expr: LBRACE Ident With Ident EQ Bytes With
interactive_expr: LBRACE Ident With Int EQ Bytes With
##
## Ends in an error in state: 539.
## Ends in an error in state: 536.
##
## nsepseq(field_path_assignment,SEMI) -> field_path_assignment . [ RBRACE ]
## nsepseq(field_path_assignment,SEMI) -> field_path_assignment . SEMI nsepseq(field_path_assignment,SEMI) [ RBRACE ]
@ -2225,32 +2213,37 @@ interactive_expr: LBRACE Ident With Ident EQ Bytes With
## In state 368, spurious reduction of production base_expr(expr) -> disj_expr_level
## In state 370, spurious reduction of production base_cond__open(expr) -> base_expr(expr)
## In state 371, spurious reduction of production expr -> base_cond__open(expr)
## In state 538, spurious reduction of production field_path_assignment -> nsepseq(field_name,DOT) EQ expr
## In state 534, spurious reduction of production field_path_assignment -> nsepseq(selection,DOT) EQ expr
##
<YOUR SYNTAX ERROR MESSAGE HERE>
interactive_expr: LBRACE Ident With Ident EQ With
interactive_expr: LBRACE Ident With Int EQ With
##
## Ends in an error in state: 537.
## Ends in an error in state: 533.
##
## field_path_assignment -> nsepseq(field_name,DOT) EQ . expr [ SEMI RBRACE ]
## field_path_assignment -> nsepseq(selection,DOT) EQ . expr [ SEMI RBRACE ]
##
## The known suffix of the stack is as follows:
## nsepseq(field_name,DOT) EQ
## nsepseq(selection,DOT) EQ
##
<YOUR SYNTAX ERROR MESSAGE HERE>
interactive_expr: LBRACE Ident With Ident With
interactive_expr: LBRACE Ident With Int With
##
## Ends in an error in state: 529.
## Ends in an error in state: 532.
##
## nsepseq(field_name,DOT) -> Ident . [ EQ ]
## nsepseq(field_name,DOT) -> Ident . DOT nsepseq(field_name,DOT) [ EQ ]
## field_path_assignment -> nsepseq(selection,DOT) . EQ expr [ SEMI RBRACE ]
##
## The known suffix of the stack is as follows:
## Ident
## nsepseq(selection,DOT)
##
## WARNING: This example involves spurious reductions.
## This implies that, although the LR(1) items shown above provide an
## accurate view of the past (what has been recognized so far), they
## may provide an INCOMPLETE view of the future (what was expected next).
## In state 187, spurious reduction of production nsepseq(selection,DOT) -> selection
##
<YOUR SYNTAX ERROR MESSAGE HERE>
@ -2282,7 +2275,7 @@ interactive_expr: LBRACE With
interactive_expr: LBRACKET Verbatim SEMI Verbatim SEMI With
##
## Ends in an error in state: 569.
## Ends in an error in state: 566.
##
## nsepseq(expr,SEMI) -> expr SEMI . nsepseq(expr,SEMI) [ RBRACKET ]
## seq(__anonymous_0(expr,SEMI)) -> expr SEMI . seq(__anonymous_0(expr,SEMI)) [ RBRACKET ]
@ -2295,7 +2288,7 @@ interactive_expr: LBRACKET Verbatim SEMI Verbatim SEMI With
interactive_expr: LBRACKET Verbatim SEMI Verbatim With
##
## Ends in an error in state: 568.
## Ends in an error in state: 565.
##
## nsepseq(expr,SEMI) -> expr . [ RBRACKET ]
## nsepseq(expr,SEMI) -> expr . SEMI nsepseq(expr,SEMI) [ RBRACKET ]
@ -2326,7 +2319,7 @@ interactive_expr: LBRACKET Verbatim SEMI Verbatim With
interactive_expr: LBRACKET Verbatim SEMI With
##
## Ends in an error in state: 565.
## Ends in an error in state: 562.
##
## nsepseq(expr,SEMI) -> expr SEMI . nsepseq(expr,SEMI) [ RBRACKET ]
## nseq(__anonymous_0(expr,SEMI)) -> expr SEMI . seq(__anonymous_0(expr,SEMI)) [ RBRACKET ]
@ -2339,7 +2332,7 @@ interactive_expr: LBRACKET Verbatim SEMI With
interactive_expr: LBRACKET Verbatim With
##
## Ends in an error in state: 564.
## Ends in an error in state: 561.
##
## nsepseq(expr,SEMI) -> expr . [ RBRACKET ]
## nsepseq(expr,SEMI) -> expr . SEMI nsepseq(expr,SEMI) [ RBRACKET ]
@ -2382,7 +2375,7 @@ interactive_expr: LBRACKET With
interactive_expr: LPAR Verbatim COLON Ident VBAR
##
## Ends in an error in state: 583.
## Ends in an error in state: 580.
##
## par(annot_expr) -> LPAR annot_expr . RPAR [ With Verbatim VBAR Type True Then TIMES String SLASH SEMI RPAR RBRACKET RBRACE PLUS Or Nat NE Mutez Mod MINUS Let LT LPAR LE LBRACKET LBRACE Int In Ident GT GE False End Else EQ EOF Constr CONS COMMA COLON CAT Bytes Begin BOOL_OR BOOL_AND Attr ]
##
@ -2396,14 +2389,14 @@ interactive_expr: LPAR Verbatim COLON Ident VBAR
## In state 28, spurious reduction of production cartesian -> core_type
## In state 36, spurious reduction of production fun_type -> cartesian
## In state 27, spurious reduction of production type_expr -> fun_type
## In state 582, spurious reduction of production annot_expr -> expr COLON type_expr
## In state 579, spurious reduction of production annot_expr -> expr COLON type_expr
##
<YOUR SYNTAX ERROR MESSAGE HERE>
interactive_expr: LPAR Verbatim COLON With
##
## Ends in an error in state: 581.
## Ends in an error in state: 578.
##
## annot_expr -> expr COLON . type_expr [ RPAR ]
##
@ -2415,7 +2408,7 @@ interactive_expr: LPAR Verbatim COLON With
interactive_expr: LPAR Verbatim With
##
## Ends in an error in state: 579.
## Ends in an error in state: 576.
##
## annot_expr -> expr . COLON type_expr [ RPAR ]
## par(expr) -> LPAR expr . RPAR [ With Verbatim VBAR Type True Then TIMES String SLASH SEMI RPAR RBRACKET RBRACE PLUS Or Nat NE Mutez Mod MINUS Let LT LPAR LE LBRACKET LBRACE Int In Ident GT GE False End Else EQ EOF Constr CONS COMMA COLON CAT Bytes Begin BOOL_OR BOOL_AND Attr ]
@ -2532,7 +2525,7 @@ interactive_expr: Let Rec With
interactive_expr: Let WILD EQ Bytes Attr Type
##
## Ends in an error in state: 557.
## Ends in an error in state: 554.
##
## let_expr(expr) -> Let let_binding seq(Attr) . In expr [ With Type Then SEMI RPAR RBRACKET RBRACE Let In EOF COLON Attr ]
##
@ -2551,7 +2544,7 @@ interactive_expr: Let WILD EQ Bytes Attr Type
interactive_expr: Let WILD EQ Bytes In With
##
## Ends in an error in state: 558.
## Ends in an error in state: 555.
##
## let_expr(expr) -> Let let_binding seq(Attr) In . expr [ With Type Then SEMI RPAR RBRACKET RBRACE Let In EOF COLON Attr ]
##
@ -2563,7 +2556,7 @@ interactive_expr: Let WILD EQ Bytes In With
interactive_expr: Let WILD EQ Bytes With
##
## Ends in an error in state: 556.
## Ends in an error in state: 553.
##
## let_expr(expr) -> Let let_binding . seq(Attr) In expr [ With Type Then SEMI RPAR RBRACKET RBRACE Let In EOF COLON Attr ]
##
@ -2618,7 +2611,7 @@ interactive_expr: MINUS With
interactive_expr: Match Verbatim Type
##
## Ends in an error in state: 572.
## Ends in an error in state: 569.
##
## match_expr(base_cond) -> Match expr . With option(VBAR) cases(base_cond) [ With Type Then SEMI RPAR RBRACKET RBRACE Let In EOF COLON Attr ]
##
@ -2660,7 +2653,7 @@ interactive_expr: Match Verbatim With LPAR Bytes RPAR With
interactive_expr: Match Verbatim With VBAR Begin
##
## Ends in an error in state: 574.
## Ends in an error in state: 571.
##
## match_expr(base_cond) -> Match expr With option(VBAR) . cases(base_cond) [ With Type Then SEMI RPAR RBRACKET RBRACE Let In EOF COLON Attr ]
##
@ -2672,7 +2665,7 @@ interactive_expr: Match Verbatim With VBAR Begin
interactive_expr: Match Verbatim With WILD ARROW Bytes VBAR With
##
## Ends in an error in state: 578.
## Ends in an error in state: 575.
##
## cases(base_cond) -> cases(base_cond) VBAR . case_clause(base_cond) [ With VBAR Type Then SEMI RPAR RBRACKET RBRACE Let In EOF COLON Attr ]
##
@ -3207,7 +3200,7 @@ interactive_expr: Match Verbatim With WILD ARROW Let With
interactive_expr: Match Verbatim With WILD ARROW Verbatim COMMA Bytes Else
##
## Ends in an error in state: 577.
## Ends in an error in state: 574.
##
## cases(base_cond) -> cases(base_cond) . VBAR case_clause(base_cond) [ With VBAR Type Then SEMI RPAR RBRACKET RBRACE Let In EOF COLON Attr ]
## match_expr(base_cond) -> Match expr With option(VBAR) cases(base_cond) . [ With Type Then SEMI RPAR RBRACKET RBRACE Let In EOF COLON Attr ]
@ -3271,7 +3264,7 @@ interactive_expr: Match Verbatim With WILD ARROW Verbatim End
interactive_expr: Match Verbatim With WILD ARROW With
##
## Ends in an error in state: 576.
## Ends in an error in state: 573.
##
## case_clause(base_cond) -> pattern ARROW . base_cond [ With VBAR Type Then SEMI RPAR RBRACKET RBRACE Let In EOF COLON Attr ]
##
@ -3320,7 +3313,7 @@ interactive_expr: Match Verbatim With WILD COMMA With
interactive_expr: Match Verbatim With WILD CONS Bytes SEMI
##
## Ends in an error in state: 575.
## Ends in an error in state: 572.
##
## case_clause(base_cond) -> pattern . ARROW base_cond [ With VBAR Type Then SEMI RPAR RBRACKET RBRACE Let In EOF COLON Attr ]
##
@ -3364,7 +3357,7 @@ interactive_expr: Match Verbatim With WILD With
interactive_expr: Match Verbatim With With
##
## Ends in an error in state: 573.
## Ends in an error in state: 570.
##
## match_expr(base_cond) -> Match expr With . option(VBAR) cases(base_cond) [ With Type Then SEMI RPAR RBRACKET RBRACE Let In EOF COLON Attr ]
##
@ -3754,7 +3747,7 @@ interactive_expr: Verbatim WILD
interactive_expr: Verbatim With
##
## Ends in an error in state: 600.
## Ends in an error in state: 597.
##
## interactive_expr -> expr . EOF [ # ]
##
@ -3783,7 +3776,7 @@ interactive_expr: Verbatim With
interactive_expr: With
##
## Ends in an error in state: 598.
## Ends in an error in state: 595.
##
## interactive_expr' -> . interactive_expr [ # ]
##
@ -4229,7 +4222,7 @@ contract: Let LPAR With
contract: Let Rec WILD EQ Bytes With
##
## Ends in an error in state: 587.
## Ends in an error in state: 584.
##
## let_declaration -> Let Rec let_binding . seq(Attr) [ Type Let EOF ]
##
@ -4354,7 +4347,7 @@ contract: Let WILD EQ Bytes Attr With
contract: Let WILD EQ Bytes With
##
## Ends in an error in state: 589.
## Ends in an error in state: 586.
##
## let_declaration -> Let let_binding . seq(Attr) [ Type Let EOF ]
##
@ -4490,7 +4483,7 @@ contract: Type Ident EQ Constr With
contract: Type Ident EQ Ident VBAR
##
## Ends in an error in state: 595.
## Ends in an error in state: 592.
##
## declarations -> declaration . [ EOF ]
## declarations -> declaration . declarations [ EOF ]
@ -4506,7 +4499,7 @@ contract: Type Ident EQ Ident VBAR
## In state 36, spurious reduction of production fun_type -> cartesian
## In state 27, spurious reduction of production type_expr -> fun_type
## In state 61, spurious reduction of production type_decl -> Type Ident EQ type_expr
## In state 591, spurious reduction of production declaration -> type_decl
## In state 588, spurious reduction of production declaration -> type_decl
##
<YOUR SYNTAX ERROR MESSAGE HERE>

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

@ -562,7 +562,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/pascaligo/Parser.mly
View File

@ -980,8 +980,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; assignment=$2; field_expr=$3}

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

@ -626,9 +626,9 @@ and print_field_assign state {value; _} =
and print_field_path_assign state {value; _} =
let {field_path; assignment; field_expr} = value in
print_nsepseq state "field_path" print_var field_path;
print_token state assignment "=";
print_expr state field_expr
print_nsepseq state "field_path" print_selection field_path;
print_token state assignment "=";
print_expr state field_expr
and print_update_expr state {value; _} =
let {record; kwd_with; updates} = value in
@ -1390,8 +1390,8 @@ and pp_field_assign state {value; _} =
and pp_field_path_assign state {value; _} =
pp_node state "<update>";
let path = Utils.nsepseq_to_list value.field_path in
List.iter (pp_ident (state#pad 2 0)) path;
pp_expr (state#pad 2 1) value.field_expr
List.iter (pp_selection (state#pad 2 0)) path;
pp_expr (state#pad 2 1) value.field_expr
and pp_map_patch state patch =
pp_path (state#pad 2 0) patch.path;

1455
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

@ -1031,19 +1031,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 ())

87
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 =
@ -452,7 +452,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
@ -465,26 +465,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
bind_fold_list aux record updates'
bind_map_list aux @@ npseq_to_list updates 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 =
let return x = ok x in
@ -669,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
@ -730,7 +721,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
@ -868,7 +859,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
@ -881,7 +873,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 -> (
@ -911,7 +904,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, [];
{value = {field_path = FieldName fa.value.field_name, [];
assignment = fa.value.assignment;
field_expr = fa.value.field_expr};
region = fa.region} in
@ -924,8 +917,9 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res
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
| MapPatch patch -> (
let name = Var.of_name name in
return_statement @@ e_assign ~loc name access_path expr
| MapPatch patch ->
let (map_p, loc) = r_split patch in
let (name, access_path) = compile_path map_p.path in
let%bind inj = bind_list
@ -943,10 +937,9 @@ 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)
in
return_statement @@ e_ez_assign ~loc name access_path assigns
)
(e_accessor ~loc (e_variable (Var.of_name name)) access_path)
and name = Var.of_name name in
return_statement @@ e_assign ~loc name access_path assigns
| SetPatch patch -> (
let (setp, loc) = r_split patch in
let (name , access_path) = compile_path setp.path in
@ -959,13 +952,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
@ -974,11 +968,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
@ -987,26 +982,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) =
@ -1057,14 +1052,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)] ->
@ -1077,7 +1072,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