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

Merge branch 'rinderknecht@pprint' of https://gitlab.com/ligolang/ligo into reasonligo-pretty-printer

Browse Source
This commit is contained in:
Sander Spies 2020-06-08 13:23:03 +02:00
commit c770aa3541
12 changed files with 1563 additions and 1552 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
src/bin/expect_tests/literals.ml
View File

@ -7,7 +7,7 @@ let%expect_test _ =
let%expect_test _ = let%expect_test _ =
run_ligo_bad ["interpret" ; "(\"thisisnotasignature\":signature)" ; "--syntax=pascaligo"] ; run_ligo_bad ["interpret" ; "(\"thisisnotasignature\":signature)" ; "--syntax=pascaligo"] ;
[%expect {| [%expect {|
ligo: in file "", line 0, characters 1-32. Badly formatted literal: Signature thisisnotasignature {"location":"in file \"\", line 0, characters 1-32"} ligo: in file "", line 0, characters 0-33. Badly formatted literal: Signature thisisnotasignature {"location":"in file \"\", line 0, characters 0-33"}
If you're not sure how to fix this error, you can If you're not sure how to fix this error, you can
@ -25,7 +25,7 @@ let%expect_test _ =
let%expect_test _ = let%expect_test _ =
run_ligo_bad ["interpret" ; "(\"thisisnotapublickey\":key)" ; "--syntax=pascaligo"] ; run_ligo_bad ["interpret" ; "(\"thisisnotapublickey\":key)" ; "--syntax=pascaligo"] ;
[%expect {| [%expect {|
ligo: in file "", line 0, characters 1-26. Badly formatted literal: key thisisnotapublickey {"location":"in file \"\", line 0, characters 1-26"} ligo: in file "", line 0, characters 0-27. Badly formatted literal: key thisisnotapublickey {"location":"in file \"\", line 0, characters 0-27"}
If you're not sure how to fix this error, you can If you're not sure how to fix this error, you can

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

@ -228,7 +228,7 @@ and field_pattern = {
and expr = and expr =
ECase of expr case reg ECase of expr case reg
| ECond of cond_expr reg | ECond of cond_expr reg
| EAnnot of (expr * colon * type_expr) par reg | EAnnot of annot_expr par reg
| ELogic of logic_expr | ELogic of logic_expr
| EArith of arith_expr | EArith of arith_expr
| EString of string_expr | EString of string_expr
@ -247,6 +247,8 @@ and expr =
| EFun of fun_expr reg | EFun of fun_expr reg
| ESeq of expr injection reg | ESeq of expr injection reg
and annot_expr = expr * colon * type_expr
and 'a injection = { and 'a injection = {
compound : compound; compound : compound;
elements : ('a, semi) sepseq; elements : ('a, semi) sepseq;

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

@ -583,7 +583,10 @@ core_expr:
| record_expr { ERecord $1 } | record_expr { ERecord $1 }
| update_record { EUpdate $1 } | update_record { EUpdate $1 }
| par(expr) { EPar $1 } | par(expr) { EPar $1 }
| par(expr ":" type_expr {$1,$2,$3}) { EAnnot $1 } | par(annot_expr) { EAnnot $1 }
annot_expr:
expr ":" type_expr { $1,$2,$3 }
module_field: module_field:
module_name "." module_fun { module_name "." module_fun {

25
src/passes/01-parser/cameligo/Pretty.ml
View File

@ -41,8 +41,9 @@ and pp_verbatim s = string "{|" ^^ pp_ident s ^^ string "|}"
and pp_let_binding (binding : let_binding) = and pp_let_binding (binding : let_binding) =
let {binders; lhs_type; let_rhs; _} = binding in let {binders; lhs_type; let_rhs; _} = binding in
let patterns = Utils.nseq_to_list binders in let head, tail = binders in
let patterns = group (separate_map (break 1) pp_pattern patterns) in let patterns =
group (nest 2 (separate_map (break 1) pp_pattern (head::tail))) in
let lhs = let lhs =
patterns ^^ patterns ^^
match lhs_type with match lhs_type with
@ -71,9 +72,9 @@ and pp_pattern = function
and pp_pconstr = function and pp_pconstr = function
PNone _ -> string "None" PNone _ -> string "None"
| PSomeApp p -> pp_patt_some p | PSomeApp p -> pp_patt_some p
| PConstrApp a -> pp_patt_c_app a | PConstrApp a -> pp_pconstr_app a
and pp_patt_c_app {value; _} = and pp_pconstr_app {value; _} =
match value with match value with
constr, None -> pp_ident constr constr, None -> pp_ident constr
| constr, Some pat -> | constr, Some pat ->
@ -95,11 +96,11 @@ and pp_ppar p = pp_par pp_pattern p
and pp_plist = function and pp_plist = function
PListComp cmp -> pp_list_comp cmp PListComp cmp -> pp_list_comp cmp
| PCons cons -> pp_cons cons | PCons cons -> pp_pcons cons
and pp_list_comp e = group (pp_injection pp_pattern e) and pp_list_comp e = group (pp_injection pp_pattern e)
and pp_cons {value; _} = and pp_pcons {value; _} =
let patt1, _, patt2 = value in let patt1, _, patt2 = value in
prefix 2 1 (pp_pattern patt1 ^^ string " ::") (pp_pattern patt2) prefix 2 1 (pp_pattern patt1 ^^ string " ::") (pp_pattern patt2)
@ -126,14 +127,15 @@ and pp_ptyped {value; _} =
and pp_type_decl decl = and pp_type_decl decl =
let {name; type_expr; _} = decl.value in let {name; type_expr; _} = decl.value in
let padding = match type_expr with TSum _ -> 0 | _ -> 2 in
string "type " ^^ string name.value ^^ string " =" string "type " ^^ string name.value ^^ string " ="
^^ group (nest 2 (break 1 ^^ pp_type_expr type_expr)) ^^ group (nest padding (break 1 ^^ pp_type_expr type_expr))
and pp_expr = function and pp_expr = function
ECase e -> pp_case_expr e ECase e -> pp_case_expr e
| ECond e -> group (pp_cond_expr e) | ECond e -> group (pp_cond_expr e)
| EAnnot e -> pp_annot_expr e | EAnnot e -> pp_annot_expr e
| ELogic e -> pp_logic_expr e | ELogic e -> group (pp_logic_expr e)
| EArith e -> group (pp_arith_expr e) | EArith e -> group (pp_arith_expr e)
| EString e -> pp_string_expr e | EString e -> pp_string_expr e
| EList e -> group (pp_list_expr e) | EList e -> group (pp_list_expr e)
@ -166,14 +168,15 @@ and pp_cases {value; _} =
and pp_clause {value; _} = and pp_clause {value; _} =
let {pattern; rhs; _} = value in let {pattern; rhs; _} = value in
prefix 4 1 (pp_pattern pattern ^^ string " ->") (pp_expr rhs) pp_pattern pattern ^^ prefix 4 1 (string " ->") (pp_expr rhs)
and pp_cond_expr {value; _} = and pp_cond_expr {value; _} =
let {test; ifso; kwd_else; ifnot; _} = value in let {test; ifso; kwd_else; ifnot; _} = value in
let test = string "if " ^^ group (nest 3 (pp_expr test)) let test = string "if " ^^ group (nest 3 (pp_expr test))
and ifso = string "then" ^^ group (nest 2 (break 1 ^^ pp_expr ifso)) and ifso = string "then" ^^ group (nest 2 (break 1 ^^ pp_expr ifso))
and ifnot = string "else" ^^ group (nest 2 (break 1 ^^ pp_expr ifnot)) and ifnot = string "else" ^^ group (nest 2 (break 1 ^^ pp_expr ifnot))
in if kwd_else#is_ghost then test ^/^ ifso in if kwd_else#is_ghost
then test ^/^ ifso
else test ^/^ ifso ^/^ ifnot else test ^/^ ifso ^/^ ifnot
and pp_annot_expr {value; _} = and pp_annot_expr {value; _} =
@ -420,7 +423,7 @@ and pp_field_decl {value; _} =
in prefix 2 1 (name ^^ string " :") t_expr in prefix 2 1 (name ^^ string " :") t_expr
and pp_type_app {value = ctor, tuple; _} = and pp_type_app {value = ctor, tuple; _} =
prefix 2 1 (pp_type_tuple tuple) (pp_type_constr ctor) pp_type_tuple tuple ^^ group (nest 2 (break 1 ^^ pp_type_constr ctor))
and pp_type_tuple {value; _} = and pp_type_tuple {value; _} =
let head, tail = value.inside in let head, tail = value.inside in

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

@ -2380,14 +2380,14 @@ interactive_expr: LBRACKET With
<YOUR SYNTAX ERROR MESSAGE HERE> <YOUR SYNTAX ERROR MESSAGE HERE>
interactive_expr: LPAR Verbatim COLON String VBAR interactive_expr: LPAR Verbatim COLON Ident VBAR
## ##
## Ends in an error in state: 582. ## Ends in an error in state: 583.
## ##
## par(__anonymous_1) -> LPAR expr COLON type_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 ] ## 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 ]
## ##
## The known suffix of the stack is as follows: ## The known suffix of the stack is as follows:
## LPAR expr COLON type_expr ## LPAR annot_expr
## ##
## WARNING: This example involves spurious reductions. ## WARNING: This example involves spurious reductions.
## This implies that, although the LR(1) items shown above provide an ## This implies that, although the LR(1) items shown above provide an
@ -2396,6 +2396,7 @@ interactive_expr: LPAR Verbatim COLON String VBAR
## In state 28, spurious reduction of production cartesian -> core_type ## In state 28, spurious reduction of production cartesian -> core_type
## In state 36, spurious reduction of production fun_type -> cartesian ## In state 36, spurious reduction of production fun_type -> cartesian
## In state 27, spurious reduction of production type_expr -> fun_type ## In state 27, spurious reduction of production type_expr -> fun_type
## In state 582, spurious reduction of production annot_expr -> expr COLON type_expr
## ##
<YOUR SYNTAX ERROR MESSAGE HERE> <YOUR SYNTAX ERROR MESSAGE HERE>
@ -2404,10 +2405,10 @@ interactive_expr: LPAR Verbatim COLON With
## ##
## Ends in an error in state: 581. ## Ends in an error in state: 581.
## ##
## par(__anonymous_1) -> LPAR expr COLON . type_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 ] ## annot_expr -> expr COLON . type_expr [ RPAR ]
## ##
## The known suffix of the stack is as follows: ## The known suffix of the stack is as follows:
## LPAR expr COLON ## expr COLON
## ##
<YOUR SYNTAX ERROR MESSAGE HERE> <YOUR SYNTAX ERROR MESSAGE HERE>
@ -2416,7 +2417,7 @@ interactive_expr: LPAR Verbatim With
## ##
## Ends in an error in state: 579. ## Ends in an error in state: 579.
## ##
## par(__anonymous_1) -> LPAR expr . COLON type_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 ] ## 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 ] ## 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 ]
## ##
## The known suffix of the stack is as follows: ## The known suffix of the stack is as follows:
@ -2446,7 +2447,7 @@ interactive_expr: LPAR With
## ##
## Ends in an error in state: 167. ## Ends in an error in state: 167.
## ##
## par(__anonymous_1) -> LPAR . expr COLON type_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 ] ## 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 ]
## 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 ] ## 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 ]
## unit -> LPAR . 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 ] ## unit -> LPAR . 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 ]
## ##
@ -3753,7 +3754,7 @@ interactive_expr: Verbatim WILD
interactive_expr: Verbatim With interactive_expr: Verbatim With
## ##
## Ends in an error in state: 599. ## Ends in an error in state: 600.
## ##
## interactive_expr -> expr . EOF [ # ] ## interactive_expr -> expr . EOF [ # ]
## ##
@ -3782,7 +3783,7 @@ interactive_expr: Verbatim With
interactive_expr: With interactive_expr: With
## ##
## Ends in an error in state: 597. ## Ends in an error in state: 598.
## ##
## interactive_expr' -> . interactive_expr [ # ] ## interactive_expr' -> . interactive_expr [ # ]
## ##
@ -4228,7 +4229,7 @@ contract: Let LPAR With
contract: Let Rec WILD EQ Bytes With contract: Let Rec WILD EQ Bytes With
## ##
## Ends in an error in state: 586. ## Ends in an error in state: 587.
## ##
## let_declaration -> Let Rec let_binding . seq(Attr) [ Type Let EOF ] ## let_declaration -> Let Rec let_binding . seq(Attr) [ Type Let EOF ]
## ##
@ -4353,7 +4354,7 @@ contract: Let WILD EQ Bytes Attr With
contract: Let WILD EQ Bytes With contract: Let WILD EQ Bytes With
## ##
## Ends in an error in state: 588. ## Ends in an error in state: 589.
## ##
## let_declaration -> Let let_binding . seq(Attr) [ Type Let EOF ] ## let_declaration -> Let let_binding . seq(Attr) [ Type Let EOF ]
## ##
@ -4489,7 +4490,7 @@ contract: Type Ident EQ Constr With
contract: Type Ident EQ Ident VBAR contract: Type Ident EQ Ident VBAR
## ##
## Ends in an error in state: 594. ## Ends in an error in state: 595.
## ##
## declarations -> declaration . [ EOF ] ## declarations -> declaration . [ EOF ]
## declarations -> declaration . declarations [ EOF ] ## declarations -> declaration . declarations [ EOF ]
@ -4505,7 +4506,7 @@ contract: Type Ident EQ Ident VBAR
## In state 36, spurious reduction of production fun_type -> cartesian ## In state 36, spurious reduction of production fun_type -> cartesian
## In state 27, spurious reduction of production type_expr -> fun_type ## 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 61, spurious reduction of production type_decl -> Type Ident EQ type_expr
## In state 590, spurious reduction of production declaration -> type_decl ## In state 591, spurious reduction of production declaration -> type_decl
## ##
<YOUR SYNTAX ERROR MESSAGE HERE> <YOUR SYNTAX ERROR MESSAGE HERE>

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

@ -206,7 +206,6 @@ and type_tuple = (type_expr, comma) nsepseq par reg
(* Function and procedure declarations *) (* Function and procedure declarations *)
and fun_expr = { and fun_expr = {
kwd_recursive: kwd_recursive option;
kwd_function : kwd_function; kwd_function : kwd_function;
param : parameters; param : parameters;
colon : colon; colon : colon;
@ -417,8 +416,7 @@ and for_int = {
assign : var_assign reg; assign : var_assign reg;
kwd_to : kwd_to; kwd_to : kwd_to;
bound : expr; bound : expr;
kwd_step : kwd_step option; step : (kwd_step * expr) option;
step : expr option;
block : block reg block : block reg
} }
@ -448,7 +446,7 @@ and collection =
and expr = and expr =
ECase of expr case reg ECase of expr case reg
| ECond of cond_expr reg | ECond of cond_expr reg
| EAnnot of annot_expr reg | EAnnot of annot_expr par reg
| ELogic of logic_expr | ELogic of logic_expr
| EArith of arith_expr | EArith of arith_expr
| EString of string_expr | EString of string_expr
@ -467,7 +465,7 @@ and expr =
| EPar of expr par reg | EPar of expr par reg
| EFun of fun_expr reg | EFun of fun_expr reg
and annot_expr = expr * type_expr and annot_expr = expr * colon * type_expr
and set_expr = and set_expr =
SetInj of expr injection reg SetInj of expr injection reg
@ -545,7 +543,7 @@ and constr_expr =
and field_assign = { and field_assign = {
field_name : field_name; field_name : field_name;
equal : equal; assignment : equal;
field_expr : expr field_expr : expr
} }
@ -565,7 +563,7 @@ and update = {
and field_path_assign = { and field_path_assign = {
field_path : (field_name, dot) nsepseq; field_path : (field_name, dot) nsepseq;
equal : equal; assignment : equal;
field_expr : expr field_expr : expr
} }

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

@ -239,16 +239,15 @@ field_decl:
fun_expr: fun_expr:
ioption ("recursive") "function" parameters ":" type_expr "is" expr { "function" parameters ":" type_expr "is" expr {
let stop = expr_to_region $7 in let stop = expr_to_region $6 in
let region = cover $2 stop let region = cover $1 stop
and value = {kwd_recursive= $1; and value = {kwd_function = $1;
kwd_function = $2; param = $2;
param = $3; colon = $3;
colon = $4; ret_type = $4;
ret_type = $5; kwd_is = $5;
kwd_is = $6; return = $6}
return = $7}
in {region; value} } in {region; value} }
(* Function declarations *) (* Function declarations *)
@ -623,7 +622,6 @@ for_loop:
assign = $2; assign = $2;
kwd_to = $3; kwd_to = $3;
bound = $4; bound = $4;
kwd_step = None;
step = None; step = None;
block = $5} block = $5}
in For (ForInt {region; value}) in For (ForInt {region; value})
@ -634,8 +632,7 @@ for_loop:
assign = $2; assign = $2;
kwd_to = $3; kwd_to = $3;
bound = $4; bound = $4;
kwd_step = Some $5; step = Some ($5, $6);
step = Some $6;
block = $7} block = $7}
in For (ForInt {region; value}) in For (ForInt {region; value})
} }
@ -849,7 +846,7 @@ core_expr:
| "False" { ELogic (BoolExpr (False $1)) } | "False" { ELogic (BoolExpr (False $1)) }
| "True" { ELogic (BoolExpr (True $1)) } | "True" { ELogic (BoolExpr (True $1)) }
| "Unit" { EUnit $1 } | "Unit" { EUnit $1 }
| annot_expr { EAnnot $1 } | par(annot_expr) { EAnnot $1 }
| tuple_expr { ETuple $1 } | tuple_expr { ETuple $1 }
| list_expr { EList $1 } | list_expr { EList $1 }
| "None" { EConstr (NoneExpr $1) } | "None" { EConstr (NoneExpr $1) }
@ -891,12 +888,7 @@ fun_call_or_par_or_projection:
| fun_call { ECall $1 } | fun_call { ECall $1 }
annot_expr: annot_expr:
"(" disj_expr ":" type_expr ")" { disj_expr ":" type_expr { $1,$2,$3 }
let start = expr_to_region $2
and stop = type_expr_to_region $4 in
let region = cover start stop
and value = $2, $4
in {region; value} }
set_expr: set_expr:
injection("set",expr) { SetInj ($1 (fun region -> InjSet region)) } injection("set",expr) { SetInj ($1 (fun region -> InjSet region)) }
@ -984,7 +976,7 @@ update_record:
field_assignment: field_assignment:
field_name "=" expr { field_name "=" expr {
let region = cover $1.region (expr_to_region $3) let region = cover $1.region (expr_to_region $3)
and value = {field_name=$1; equal=$2; field_expr=$3} and value = {field_name=$1; assignment=$2; field_expr=$3}
in {region; value} } in {region; value} }
field_path_assignment: field_path_assignment:
@ -992,7 +984,7 @@ field_path_assignment:
let start = nsepseq_to_region (fun x -> x.region) $1 let start = nsepseq_to_region (fun x -> x.region) $1
and stop = expr_to_region $3 in and stop = expr_to_region $3 in
let region = cover start stop let region = cover start stop
and value = {field_path=$1; equal=$2; field_expr=$3} and value = {field_path=$1; assignment=$2; field_expr=$3}
in {region; value} } in {region; value} }
fun_call: fun_call:

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

@ -221,9 +221,8 @@ and print_fun_decl state {value; _} =
print_terminator state terminator; print_terminator state terminator;
and print_fun_expr state {value; _} = and print_fun_expr state {value; _} =
let {kwd_recursive; kwd_function; param; colon; let {kwd_function; param; colon;
ret_type; kwd_is; return} : fun_expr = value in ret_type; kwd_is; return} : fun_expr = value in
print_token_opt state kwd_recursive "recursive";
print_token state kwd_function "function"; print_token state kwd_function "function";
print_parameters state param; print_parameters state param;
print_token state colon ":"; print_token state colon ":";
@ -396,19 +395,16 @@ and print_for_loop state = function
| ForCollect for_collect -> print_for_collect state for_collect | ForCollect for_collect -> print_for_collect state for_collect
and print_for_int state ({value; _} : for_int reg) = and print_for_int state ({value; _} : for_int reg) =
let {kwd_for; assign; kwd_to; bound; kwd_step; step; block} = value in let {kwd_for; assign; kwd_to; bound; step; block} = value in
print_token state kwd_for "for"; print_token state kwd_for "for";
print_var_assign state assign; print_var_assign state assign;
print_token state kwd_to "to"; print_token state kwd_to "to";
print_expr state bound; print_expr state bound;
match kwd_step with (match step with
| None -> (); None -> ();
| Some kwd_step -> | Some (kwd_step, expr) ->
print_token state kwd_step "step"; print_token state kwd_step "step";
match step with print_expr state expr);
| None -> ();
| Some step ->
print_expr state step;
print_block state block print_block state block
and print_var_assign state {value; _} = and print_var_assign state {value; _} =
@ -464,7 +460,9 @@ and print_expr state = function
| EPar e -> print_par_expr state e | EPar e -> print_par_expr state e
| EFun e -> print_fun_expr state e | EFun e -> print_fun_expr state e
and print_annot_expr state (expr , type_expr) = and print_annot_expr state node =
let {inside; _} : annot_expr par = node in
let expr, _, type_expr = inside in
print_expr state expr; print_expr state expr;
print_type_expr state type_expr print_type_expr state type_expr
@ -621,15 +619,15 @@ and print_record_expr state =
print_ne_injection state print_field_assign print_ne_injection state print_field_assign
and print_field_assign state {value; _} = and print_field_assign state {value; _} =
let {field_name; equal; field_expr} = value in let {field_name; assignment; field_expr} = value in
print_var state field_name; print_var state field_name;
print_token state equal "="; print_token state assignment "=";
print_expr state field_expr print_expr state field_expr
and print_field_path_assign state {value; _} = and print_field_path_assign state {value; _} =
let {field_path; equal; field_expr} = value in let {field_path; assignment; field_expr} = value in
print_nsepseq state "field_path" print_var field_path; print_nsepseq state "field_path" print_var field_path;
print_token state equal "="; print_token state assignment "=";
print_expr state field_expr print_expr state field_expr
and print_update_expr state {value; _} = and print_update_expr state {value; _} =
@ -1273,7 +1271,7 @@ and pp_projection state proj =
List.iteri (apply len) selections List.iteri (apply len) selections
and pp_update state update = and pp_update state update =
pp_path state update.record; pp_path (state#pad 2 0) update.record;
pp_ne_injection pp_field_path_assign state update.updates.value pp_ne_injection pp_field_path_assign state update.updates.value
and pp_selection state = function and pp_selection state = function
@ -1314,17 +1312,27 @@ and pp_for_loop state = function
pp_for_collect state value pp_for_collect state value
and pp_for_int state for_int = and pp_for_int state for_int =
let {assign; bound; step; block; _} = for_int in
let arity =
match step with None -> 3 | Some _ -> 4 in
let () = let () =
let state = state#pad 3 0 in let state = state#pad arity 0 in
pp_node state "<init>"; pp_node state "<init>";
pp_var_assign state for_int.assign.value in pp_var_assign state assign.value in
let () = let () =
let state = state#pad 3 1 in let state = state#pad arity 1 in
pp_node state "<bound>"; pp_node state "<bound>";
pp_expr (state#pad 1 0) for_int.bound in pp_expr (state#pad 1 0) bound in
let () = let () =
let state = state#pad 3 2 in match step with
let statements = for_int.block.value.statements in None -> ()
| Some (_, expr) ->
let state = state#pad arity 2 in
pp_node state "<step>";
pp_expr (state#pad 1 0) expr in
let () =
let state = state#pad arity (arity-1) in
let statements = block.value.statements in
pp_node state "<statements>"; pp_node state "<statements>";
pp_statements state statements pp_statements state statements
in () in ()
@ -1380,7 +1388,7 @@ and pp_field_assign state {value; _} =
pp_expr (state#pad 2 1) value.field_expr pp_expr (state#pad 2 1) value.field_expr
and pp_field_path_assign state {value; _} = and pp_field_path_assign state {value; _} =
pp_node state "<field path for update>"; pp_node state "<update>";
let path = Utils.nsepseq_to_list value.field_path in let path = Utils.nsepseq_to_list value.field_path in
List.iter (pp_ident (state#pad 2 0)) path; List.iter (pp_ident (state#pad 2 0)) path;
pp_expr (state#pad 2 1) value.field_expr pp_expr (state#pad 2 1) value.field_expr
@ -1432,7 +1440,7 @@ and pp_expr state = function
pp_cond_expr state value pp_cond_expr state value
| EAnnot {value; region} -> | EAnnot {value; region} ->
pp_loc_node state "EAnnot" region; pp_loc_node state "EAnnot" region;
pp_annotated state value pp_annotated state value.inside
| ELogic e_logic -> | ELogic e_logic ->
pp_node state "ELogic"; pp_node state "ELogic";
pp_e_logic (state#pad 1 0) e_logic pp_e_logic (state#pad 1 0) e_logic
@ -1607,7 +1615,7 @@ and pp_string_expr state = function
pp_node state "Verbatim"; pp_node state "Verbatim";
pp_verbatim (state#pad 1 0) v pp_verbatim (state#pad 1 0) v
and pp_annotated state (expr, t_expr) = and pp_annotated state (expr, _, t_expr) =
pp_expr (state#pad 2 0) expr; pp_expr (state#pad 2 0) expr;
pp_type_expr (state#pad 2 1) t_expr pp_type_expr (state#pad 2 1) t_expr

250
src/passes/01-parser/pascaligo/Pretty.ml
View File

@ -34,13 +34,13 @@ and pp_attr_decl decl = pp_ne_injection pp_string decl
and pp_const_decl {value; _} = and pp_const_decl {value; _} =
let {name; const_type; init; attributes; _} = value in let {name; const_type; init; attributes; _} = value in
let start = string ("const " ^ name.value ^ " :") in let start = string ("const " ^ name.value) in
let t_expr = pp_type_expr const_type in let t_expr = pp_type_expr const_type in
let attr = match attributes with let attr = match attributes with
None -> empty None -> empty
| Some a -> hardline ^^ pp_attr_decl a | Some a -> hardline ^^ pp_attr_decl a in
in prefix 2 1 start t_expr group (start ^/^ nest 2 (string ": " ^^ t_expr))
^/^ prefix 2 1 (string "=") (pp_expr init) ^^ group (break 1 ^^ nest 2 (string "= " ^^ pp_expr init))
^^ attr ^^ attr
(* Type declarations *) (* Type declarations *)
@ -119,7 +119,15 @@ and pp_type_tuple {value; _} =
(* Function and procedure declarations *) (* Function and procedure declarations *)
and pp_fun_expr {value; _} = string "TODO:pp_fun_expr" and pp_fun_expr {value; _} =
let {param; ret_type; return; _} : fun_expr = value in
let start = string "function" in
let parameters = pp_par pp_parameters param in
let return_t = pp_type_expr ret_type in
let expr = pp_expr return in
group (start ^^ nest 2 (break 1 ^^ parameters))
^^ group (break 1 ^^ nest 2 (string ": " ^^ return_t))
^^ string " is" ^^ group (nest 4 (break 1 ^^ expr))
and pp_fun_decl {value; _} = and pp_fun_decl {value; _} =
let {kwd_recursive; fun_name; param; let {kwd_recursive; fun_name; param;
@ -128,23 +136,22 @@ and pp_fun_decl {value; _} =
match kwd_recursive with match kwd_recursive with
None -> string "function" None -> string "function"
| Some _ -> string "recursive" ^/^ string "function" in | Some _ -> string "recursive" ^/^ string "function" in
let start = start ^^ group (break 1 ^^ nest 2 (pp_ident fun_name)) in
let parameters = pp_par pp_parameters param in let parameters = pp_par pp_parameters param in
let return_t = pp_type_expr ret_type in let return_t = pp_type_expr ret_type in
let blk_opening, blk_in, blk_closing =
match block_with with
None -> empty, empty, empty
| Some (b,_) ->
hardline ^^ string "is block [", pp_block b, string "] with" in
let expr = pp_expr return in let expr = pp_expr return in
let attr = match attributes with let body =
match block_with with
None -> group (nest 2 (break 1 ^^ expr))
| Some (b,_) -> hardline ^^ pp_block b ^^ string " with"
^^ group (nest 4 (break 1 ^^ expr))
and attr =
match attributes with
None -> empty None -> empty
| Some a -> hardline ^^ pp_attr_decl a | Some a -> hardline ^^ pp_attr_decl a in
in group (start ^^ nest 2 (break 1 ^^ parameters)) prefix 2 1 start parameters
^/^ string ": " ^^ nest 2 return_t ^^ group (nest 2 (break 1 ^^ string ": " ^^ nest 2 return_t ^^ string " is"))
^^ blk_opening ^^ body ^^ attr
^^ nest 2 (break 0 ^^ blk_in)
^/^ group (blk_closing ^^ nest 4 (break 1 ^^ expr))
^^ attr
and pp_parameters p = pp_nsepseq ";" pp_param_decl p and pp_parameters p = pp_nsepseq ";" pp_param_decl p
@ -164,7 +171,10 @@ and pp_param_var {value; _} =
let t_expr = pp_type_expr param_type let t_expr = pp_type_expr param_type
in prefix 2 1 (name ^^ string " :") t_expr in prefix 2 1 (name ^^ string " :") t_expr
and pp_block {value; _} = pp_statements value.statements and pp_block {value; _} =
string "block {"
^^ nest 2 (hardline ^^ pp_statements value.statements)
^^ hardline ^^ string "}"
and pp_statements s = pp_nsepseq ";" pp_statement s and pp_statements s = pp_nsepseq ";" pp_statement s
@ -180,10 +190,10 @@ and pp_data_decl = function
and pp_var_decl {value; _} = and pp_var_decl {value; _} =
let {name; var_type; init; _} = value in let {name; var_type; init; _} = value in
let start = string ("var " ^ name.value ^ " :") in let start = string ("var " ^ name.value) in
let t_expr = pp_type_expr var_type let t_expr = pp_type_expr var_type in
in prefix 2 1 start group (start ^/^ nest 2 (string ": " ^^ t_expr))
(t_expr ^/^ prefix 2 1 (string ":=") (pp_expr init)) ^^ group (break 1 ^^ nest 2 (string ":= " ^^ pp_expr init))
and pp_instruction = function and pp_instruction = function
Cond i -> group (pp_conditional i) Cond i -> group (pp_conditional i)
@ -198,49 +208,76 @@ and pp_instruction = function
| MapRemove i -> pp_map_remove i | MapRemove i -> pp_map_remove i
| SetRemove i -> pp_set_remove i | SetRemove i -> pp_set_remove i
and pp_set_remove {value; _} = string "TODO:pp_set_remove" and pp_set_remove {value; _} =
let {element; set; _} : set_remove = value in
string "remove" ^^ group (nest 2 (break 1 ^^ pp_expr element))
^^ group (break 1 ^^ prefix 2 1 (string "from set") (pp_path set))
and pp_map_remove {value; _} = string "TODO:pp_map_remove" and pp_map_remove {value; _} =
let {key; map; _} = value in
string "remove" ^^ group (nest 2 (break 1 ^^ pp_expr key))
^^ group (break 1 ^^ prefix 2 1 (string "from map") (pp_path map))
and pp_set_patch {value; _} = string "TODO:pp_set_patch" and pp_set_patch {value; _} =
let {path; set_inj; _} = value in
let inj = pp_ne_injection pp_expr set_inj in
string "patch"
^^ group (nest 2 (break 1 ^^ pp_path path) ^/^ string "with")
^^ group (nest 2 (break 1 ^^ inj))
and pp_map_patch {value; _} = string "TODO:pp_map_patch" and pp_map_patch {value; _} =
let {path; map_inj; _} = value in
let inj = pp_ne_injection pp_binding map_inj in
string "patch"
^^ group (nest 2 (break 1 ^^ pp_path path) ^/^ string "with")
^^ group (nest 2 (break 1 ^^ inj))
and pp_binding b = string "TODO:pp_binding" and pp_binding {value; _} =
let {source; image; _} = value in
pp_expr source
^^ string " ->" ^^ group (nest 2 (break 1 ^^ pp_expr image))
and pp_record_patch {value; _} = string "TODO:pp_record_patch" and pp_record_patch {value; _} =
let {path; record_inj; _} = value in
let inj = pp_record record_inj in
string "patch"
^^ group (nest 2 (break 1 ^^ pp_path path) ^/^ string "with")
^^ group (nest 2 (break 1 ^^ inj))
and pp_cond_expr {value; _} = string "TODO:pp_cond_expr" and pp_cond_expr {value; _} =
let {test; ifso; ifnot; _} : cond_expr = value in
let test = string "if " ^^ group (nest 3 (pp_expr test))
and ifso = string "then" ^^ group (nest 2 (break 1 ^^ pp_expr ifso))
and ifnot = string "else" ^^ group (nest 2 (break 1 ^^ pp_expr ifnot))
in test ^/^ ifso ^/^ ifnot
and pp_conditional {value; _} = and pp_conditional {value; _} =
let {test; ifso; ifnot; _} : conditional = value in let {test; ifso; ifnot; _} : conditional = value in
let test = string "if " ^^ group (nest 3 (pp_expr test)) let test = string "if " ^^ group (nest 3 (pp_expr test))
and ifso = string "then" ^^ group (nest 2 (break 1 ^^ pp_if_clause ifso)) and ifso = string "then" ^^ group (nest 2 (break 1 ^^ pp_if_clause ifso))
and ifnot = and ifnot = match ifnot with
if is_clause_block ifnot then ClauseInstr _ | ClauseBlock LongBlock _ ->
string "else"
^^ group (nest 2 (break 1 ^^ pp_if_clause ifnot))
| ClauseBlock ShortBlock _ ->
string "else {" string "else {"
^^ group (nest 2 (hardline ^^ pp_if_clause ifnot)) ^^ group (nest 2 (hardline ^^ pp_if_clause ifnot))
^^ hardline ^^ string "}" ^^ hardline ^^ string "}"
else
string "else" ^^ group (nest 2 (break 1 ^^ pp_if_clause ifnot))
in test ^/^ ifso ^/^ ifnot in test ^/^ ifso ^/^ ifnot
and pp_if_clause = function and pp_if_clause = function
ClauseInstr i -> pp_instruction i ClauseInstr i -> pp_instruction i
| ClauseBlock b -> pp_clause_block b | ClauseBlock b -> pp_clause_block b
and is_clause_block = function
ClauseInstr _ -> false
| ClauseBlock _ -> true
and pp_clause_block = function and pp_clause_block = function
LongBlock b -> pp_block b LongBlock b -> pp_block b
| ShortBlock {value; _} -> Utils.(pp_statements <@ fst) value.inside | ShortBlock b -> Utils.(pp_statements <@ fst) b.value.inside
and pp_set_membership {value; _} = string "TODO:pp_set_membership" and pp_set_membership {value; _} =
let {set; element; _} : set_membership = value in
group (pp_expr set ^/^ string "contains" ^/^ pp_expr element)
and pp_case : and pp_case : 'a.('a -> document) -> 'a case Region.reg -> document =
'a.('a -> document) -> 'a case Region.reg -> document =
fun printer {value; _} -> fun printer {value; _} ->
let {expr; cases; _} = value in let {expr; cases; _} = value in
group (string "case " ^^ nest 5 (pp_expr expr) ^/^ string "of [") group (string "case " ^^ nest 5 (pp_expr expr) ^/^ string "of [")
@ -249,11 +286,12 @@ and pp_case :
and pp_cases : and pp_cases :
'a.('a -> document) -> 'a.('a -> document) ->
('a case_clause reg, vbar) Utils.nsepseq Region.reg -> document = ('a case_clause reg, vbar) Utils.nsepseq Region.reg ->
document =
fun printer {value; _} -> fun printer {value; _} ->
let head, tail = value in let head, tail = value in
let head = pp_case_clause printer head in let head = pp_case_clause printer head in
let head = if tail = [] then head else blank 2 ^^ head in let head = blank 2 ^^ head in
let rest = List.map snd tail in let rest = List.map snd tail in
let app clause = break 1 ^^ string "| " ^^ pp_case_clause printer clause let app clause = break 1 ^^ string "| " ^^ pp_case_clause printer clause
in head ^^ concat_map app rest in head ^^ concat_map app rest
@ -262,8 +300,7 @@ and pp_case_clause :
'a.('a -> document) -> 'a case_clause Region.reg -> document = 'a.('a -> document) -> 'a case_clause Region.reg -> document =
fun printer {value; _} -> fun printer {value; _} ->
let {pattern; rhs; _} = value in let {pattern; rhs; _} = value in
prefix 4 1 (pp_pattern pattern ^^ string " ->") (printer rhs) pp_pattern pattern ^^ prefix 4 1 (string " ->") (printer rhs)
and pp_assignment {value; _} = and pp_assignment {value; _} =
let {lhs; rhs; _} = value in let {lhs; rhs; _} = value in
@ -277,17 +314,37 @@ and pp_loop = function
While l -> pp_while_loop l While l -> pp_while_loop l
| For f -> pp_for_loop f | For f -> pp_for_loop f
and pp_while_loop {value; _} = string "TODO:pp_while_loop" and pp_while_loop {value; _} =
let {cond; block; _} = value in
prefix 2 1 (string "while") (pp_expr cond) ^^ hardline ^^ pp_block block
and pp_for_loop = function and pp_for_loop = function
ForInt l -> pp_for_int l ForInt l -> pp_for_int l
| ForCollect l -> pp_for_collect l | ForCollect l -> pp_for_collect l
and pp_for_int {value; _} = string "TODO:pp_for_int" and pp_for_int {value; _} =
let {assign; bound; step; block; _} = value in
let step =
match step with
None -> empty
| Some (_, e) -> prefix 2 1 (string " step") (pp_expr e) in
prefix 2 1 (string "for") (pp_var_assign assign)
^^ prefix 2 1 (string " to") (pp_expr bound)
^^ step ^^ hardline ^^ pp_block block
and pp_var_assign {value; _} = string "TODO:pp_var_assign" and pp_var_assign {value; _} =
let {name; expr; _} = value in
prefix 2 1 (pp_ident name ^^ string " :=") (pp_expr expr)
and pp_for_collect {value; _} = string "TODO:pp_for_collect" and pp_for_collect {value; _} =
let {var; bind_to; collection; expr; block; _} = value in
let binding =
match bind_to with
None -> pp_ident var
| Some (_, dest) -> pp_ident var ^^ string " -> " ^^ pp_ident dest in
prefix 2 1 (string "for") binding
^^ prefix 2 1 (string " in") (pp_collection collection ^/^ pp_expr expr)
^^ hardline ^^ pp_block block
and pp_collection = function and pp_collection = function
Map _ -> string "map" Map _ -> string "map"
@ -300,7 +357,7 @@ and pp_expr = function
ECase e -> pp_case pp_expr e ECase e -> pp_case pp_expr e
| ECond e -> group (pp_cond_expr e) | ECond e -> group (pp_cond_expr e)
| EAnnot e -> pp_annot_expr e | EAnnot e -> pp_annot_expr e
| ELogic e -> pp_logic_expr e | ELogic e -> group (pp_logic_expr e)
| EArith e -> group (pp_arith_expr e) | EArith e -> group (pp_arith_expr e)
| EString e -> pp_string_expr e | EString e -> pp_string_expr e
| EList e -> group (pp_list_expr e) | EList e -> group (pp_list_expr e)
@ -318,11 +375,14 @@ and pp_expr = function
| EPar e -> pp_par pp_expr e | EPar e -> pp_par pp_expr e
| EFun e -> pp_fun_expr e | EFun e -> pp_fun_expr e
and pp_annot_expr {value; _} = string "TODO:pp_annot_expr" and pp_annot_expr {value; _} =
let expr, _, type_expr = value.inside in
group (string "(" ^^ nest 1 (pp_expr expr ^/^ string ": "
^^ pp_type_expr type_expr ^^ string ")"))
and pp_set_expr = function and pp_set_expr = function
SetInj inj -> string "TODO:pp_set_expr:SetInj" SetInj inj -> pp_injection pp_expr inj
| SetMem mem -> string "TODO:pp_set_expr:SetMem" | SetMem mem -> pp_set_membership mem
and pp_map_expr = function and pp_map_expr = function
MapLookUp fetch -> pp_map_lookup fetch MapLookUp fetch -> pp_map_lookup fetch
@ -330,7 +390,7 @@ and pp_map_expr = function
| BigMapInj inj -> pp_injection pp_binding inj | BigMapInj inj -> pp_injection pp_binding inj
and pp_map_lookup {value; _} = and pp_map_lookup {value; _} =
pp_path value.path ^^ blank 1 ^^ pp_brackets pp_expr value.index prefix 2 1 (pp_path value.path) (pp_brackets pp_expr value.index)
and pp_path = function and pp_path = function
Name v -> pp_ident v Name v -> pp_ident v
@ -390,7 +450,7 @@ and pp_verbatim s = string "{|" ^^ pp_ident s ^^ string "|}"
and pp_list_expr = function and pp_list_expr = function
ECons e -> pp_bin_op "#" e ECons e -> pp_bin_op "#" e
| EListComp e -> group (pp_injection pp_expr e) | EListComp e -> pp_injection pp_expr e
| ENil _ -> string "nil" | ENil _ -> string "nil"
and pp_constr_expr = function and pp_constr_expr = function
@ -398,11 +458,20 @@ and pp_constr_expr = function
| NoneExpr _ -> string "None" | NoneExpr _ -> string "None"
| ConstrApp a -> pp_constr_app a | ConstrApp a -> pp_constr_app a
and pp_some_app {value; _} = string "TODO:pp_some_app" and pp_some_app {value; _} =
prefix 4 1 (string "Some") (pp_arguments (snd value))
and pp_constr_app {value; _} = string "TODO:pp_constr_app" and pp_constr_app {value; _} =
let constr, args = value in
let constr = string constr.value in
match args with
None -> constr
| Some tuple -> prefix 2 1 constr (pp_tuple_expr tuple)
and pp_field_assign {value; _} = string "TODO:pp_field_assign"
and pp_field_assign {value; _} =
let {field_name; field_expr; _} = value in
prefix 2 1 (pp_ident field_name ^^ string " =") (pp_expr field_expr)
and pp_record ne_inj = group (pp_ne_injection pp_field_assign ne_inj) and pp_record ne_inj = group (pp_ne_injection pp_field_assign ne_inj)
@ -413,9 +482,18 @@ and pp_projection {value; _} =
let fields = separate_map sep pp_selection fields in let fields = separate_map sep pp_selection fields in
group (pp_ident struct_name ^^ string "." ^^ break 0 ^^ fields) group (pp_ident struct_name ^^ string "." ^^ break 0 ^^ fields)
and pp_update {value; _} = string "TODO:pp_update" and pp_update {value; _} =
let {record; updates; _} = value in
let updates = group (pp_ne_injection pp_field_path_assign updates)
and record = pp_path record in
record ^^ string " with" ^^ nest 2 (break 1 ^^ updates)
and pp_field_path_assign {value; _} = string "TODO:pp_field_path_assign" and pp_field_path_assign {value; _} =
let {field_path; field_expr; _} = value in
let fields = Utils.nsepseq_to_list field_path
and sep = string "." ^^ break 0 in
let fields = separate_map sep pp_ident fields in
group (fields ^^ nest 2 (break 1 ^^ string "= " ^^ pp_expr field_expr))
and pp_selection = function and pp_selection = function
FieldName v -> string v.value FieldName v -> string v.value
@ -446,14 +524,13 @@ and pp_arguments v = pp_tuple_expr v
and pp_injection : and pp_injection :
'a.('a -> document) -> 'a injection reg -> document = 'a.('a -> document) -> 'a injection reg -> document =
fun printer {value; _} -> fun printer {value; _} ->
let {kind; enclosing; elements; _} = value in let {kind; elements; _} = value in
let sep = string ";" ^^ break 1 in let sep = string ";" ^^ break 1 in
let elements = Utils.sepseq_to_list elements in let elements = Utils.sepseq_to_list elements in
let elements = separate_map sep printer elements in let elements = separate_map sep printer elements in
let kwd = pp_injection_kwd kind in let kwd = pp_injection_kwd kind in
let offset = String.length kwd + 2 in group (string (kwd ^ " [")
string (kwd ^ " [") ^^ nest 2 (break 0 ^^ elements) ^^ break 0 ^^ string "]")
^^ group (nest 2 (break 0 ^^ elements ^^ string "]"))
and pp_injection_kwd = function and pp_injection_kwd = function
InjSet _ -> "set" InjSet _ -> "set"
@ -464,12 +541,12 @@ and pp_injection_kwd = function
and pp_ne_injection : and pp_ne_injection :
'a.('a -> document) -> 'a ne_injection reg -> document = 'a.('a -> document) -> 'a ne_injection reg -> document =
fun printer {value; _} -> fun printer {value; _} ->
let {kind; enclosing; ne_elements; _} = value in let {kind; ne_elements; _} = value in
let elements = pp_nsepseq ";" printer ne_elements in let elements = pp_nsepseq ";" printer ne_elements in
let kwd = pp_ne_injection_kwd kind in let kwd = pp_ne_injection_kwd kind in
let offset = String.length kwd + 2 in group (string (kwd ^ " [")
string (kwd ^ " [") ^^ group (nest 2 (break 0 ^^ elements ))
^^ group (nest 2 (break 0 ^^ elements ^^ string "]")) ^^ break 0 ^^ string "]")
and pp_ne_injection_kwd = function and pp_ne_injection_kwd = function
NEInjAttr _ -> "attributes" NEInjAttr _ -> "attributes"
@ -478,10 +555,7 @@ and pp_ne_injection_kwd = function
| NEInjRecord _ -> "record" | NEInjRecord _ -> "record"
and pp_nsepseq : and pp_nsepseq :
'a.string -> 'a.string -> ('a -> document) -> ('a, t) Utils.nsepseq -> document =
('a -> document) ->
('a, t) Utils.nsepseq ->
document =
fun sep printer elements -> fun sep printer elements ->
let elems = Utils.nsepseq_to_list elements let elems = Utils.nsepseq_to_list elements
and sep = string sep ^^ break 1 and sep = string sep ^^ break 1
@ -520,18 +594,34 @@ and pp_constr_pattern = function
and pp_psome {value=_, p; _} = and pp_psome {value=_, p; _} =
prefix 4 1 (string "Some") (pp_par pp_pattern p) prefix 4 1 (string "Some") (pp_par pp_pattern p)
and pp_pconstr_app {value; _} = string "TODO:pp_pconstr_app" and pp_pconstr_app {value; _} =
match value with
constr, None -> pp_ident constr
| constr, Some ptuple ->
prefix 4 1 (pp_ident constr) (pp_tuple_pattern ptuple)
and pp_tuple_pattern {value; _} = string "TODO:tuple_pattern" and pp_tuple_pattern {value; _} =
let head, tail = value.inside in
let rec app = function
[] -> empty
| [e] -> group (break 1 ^^ pp_pattern e)
| e::items ->
group (break 1 ^^ pp_pattern e ^^ string ",") ^^ app items in
let components =
if tail = []
then pp_pattern head
else pp_pattern head ^^ string "," ^^ app (List.map snd tail)
in string "(" ^^ nest 1 (components ^^ string ")")
and pp_list_pattern = function and pp_list_pattern = function
PListComp cmp -> pp_list_comp cmp PListComp cmp -> pp_list_comp cmp
| PNil _ -> string "nil" | PNil _ -> string "nil"
| PParCons p -> pp_ppar_cons p | PParCons p -> pp_ppar_cons p
| PCons p -> pp_nsepseq "#" pp_pattern p.value | PCons p -> nest 4 (pp_nsepseq " #" pp_pattern p.value)
and pp_list_comp {value; _} = string "TODO:pp_list_comp" and pp_list_comp e = pp_injection pp_pattern e
and pp_ppar_cons {value; _} = string "TODO:pp_ppar_cons" and pp_ppar_cons {value; _} =
let patt1, _, patt2 = value.inside in
and pp_cons {value; _} = string "TODO:pp_cons" let comp = prefix 2 1 (pp_pattern patt1 ^^ string " ::") (pp_pattern patt2)
in string "(" ^^ nest 1 (comp ^^ string ")")

30
src/passes/01-parser/pascaligo/Tests/pp.ligo
View File

@ -1,10 +1,14 @@
function incr_map (const l : list (int)) : list (int) is
List.map (function (const i : int) : int is i + 1, l)
type t is timestamp * nat -> map (string, address) type t is timestamp * nat -> map (string, address)
type u is A | B of t * int | C of int -> (string -> int) type u is A | B of t * int | C of int -> (string -> int)
type v is record aaaaaa : ttttttt; bbbbbb : record ccccccccc : string end end type v is record aaaaaa : ttttttt; bbbbbb : record ccccccccc : string end end
(*
function back (var store : store) : list (operation) * store is function back (var store : store) : list (operation) * store is
begin begin
var operations : list (operation) := list []; var operations : list (operation) := list [];
const operations : list (operation) = list [];
const a : nat = 0n; const a : nat = 0n;
x0 := record foo = "1"; bar = 4n end; x0 := record foo = "1"; bar = 4n end;
x1 := nil; x1 := nil;
@ -13,7 +17,7 @@ function back (var store : store) : list (operation) * store is
case foo of case foo of
10n -> skip 10n -> skip
end; end;
if s contains x then skip else skip; if saaa.0.1.2.a.b.b.x contains xxxxxxxxxxxxxxx[123] then skip else skip;
s := set [3_000mutez; -2; 1n]; s := set [3_000mutez; -2; 1n];
a := A; a := A;
b := B (a); b := B (a);
@ -21,12 +25,12 @@ function back (var store : store) : list (operation) * store is
d := None; d := None;
e := Some (a, B (b)); e := Some (a, B (b));
z := z.1.2; z := z.1.2;
x := map [1 -> "1"; 2 -> "2"]; x := if true then map [1 -> "1"; 2 -> "2"; 3 -> "3"; 4 -> "4"; 5 -> "5555555555555555"] else Unit;
y := a.b.c[3]; y := a.b.c[3];
a := "hello " ^ "world" ^ "!"; a := "hello " ^ "world" ^ "!";
r := record a = 0 end; r := record aaaaaaaaaaaa = 100000000; bbbbbbb = ffffff (2, aa, x, y) + 1 end;
r := r with record a = 42 end; r := r with record aaaaaaaaaaa = 444442; bbbbbbbbb = 43 + f (z) / 234 end;
patch store.backers with set [(1); f(2*3)]; patch store.backers.8.aa.33333.5 with set [(1); f(2*3); 123124234/2345];
remove (1,2,3) from set foo.bar; remove (1,2,3) from set foo.bar;
remove 3 from map foo.bar; remove 3 from map foo.bar;
patch store.backers with map [sender -> amount]; patch store.backers with map [sender -> amount];
@ -39,7 +43,7 @@ function back (var store : store) : list (operation) * store is
begin begin
acc := 2 - (if toggle then f(x) else Unit); acc := 2 - (if toggle then f(x) else Unit);
end; end;
for i := 1n to 10n for i := 1n to 10n step 2n
begin begin
acc := acc + i; acc := acc + i;
end; end;
@ -53,10 +57,11 @@ function back (var store : store) : list (operation) * store is
| False#True#Unit#0xAA#"hi"#4#nil -> skip | False#True#Unit#0xAA#"hi"#4#nil -> skip
] ]
end with (operations, store, (more_stuff, and_here_too)) end with (operations, store, (more_stuff, and_here_too))
*)
function claim (var store : store; const bar : t; const baz : u; var z : operations * store * (more_stuff * and_here_too)) : list (operation) * store * timestamp * nat -> map (string, address) is function claim (var store : store; const bar : t; const baz : u; var z : operations * store * (more_stuff * and_here_too)) : list (operation) * store * timestamp * nat -> map (string, address) is
begin begin
var operations : list (operation * map (address, map (longname, domain))) := nilllllllllll; const operations : list (operation * map (address, map (longname, domain))) = nilllllllllll;
var operations : list (operation * map (address, map (longname, domain))) := nilllllllllll;
attributes ["foo"; "inline"]; attributes ["foo"; "inline"];
if now <= store.deadline then if now <= store.deadline then
failwith ("Too soon.") failwith ("Too soon.")
@ -64,20 +69,20 @@ function back (var store : store) : list (operation) * store is
case store.backers[sender] of case store.backers[sender] of
None -> None ->
failwith ("Not a backer.") failwith ("Not a backer.")
| Some (0) -> skip
| Some (quantity) -> | Some (quantity) ->
if balance >= store.goal or store.funded then if balance >= store.goal or store.funded then
failwith ("Goal reached: no refund.") failwith ("Goal reached: no refund.")
else else
begin begin
operations.0.foo := list [transaction (unit, sender, quantity)]; operations.0.foo := list [transaction (unit, sender, quantity); transaction (foo, bar, bazzzzzzzzzzzzzzz)];
remove sender from map store.backers remove sender.0099999.fffff [fiar (abaxxasfdf)] from map store.backers.foooooo.barrrrr.01.bazzzzzzz
end end
end end
end with long_function_name (operations, store, (more_stuff, (and_here_too, well_in_here_too), hello)) end with long_function_name (operations, store, (more_stuff, (and_here_too, well_in_here_too), hello))
attributes ["inline"; "foo"] attributes ["inline"; "foo"]
(*
function withdraw (var store : store) : list (operation) * store is function withdraw (var store : store) : list (operation) * store is
begin begin
var operations : list (operation) := list end; var operations : list (operation) := list end;
@ -95,4 +100,3 @@ function withdraw (var store : store) : list (operation) * store is
nil -> (operations, (store : store)) nil -> (operations, (store : store))
| _ -> (operations, store) | _ -> (operations, store)
end end
*)

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

File diff suppressed because it is too large Load Diff

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

@ -282,20 +282,21 @@ let rec compile_expression (t:Raw.expr) : expr result =
let return x = ok x in let return x = ok x in
match t with match t with
| EAnnot a -> ( | EAnnot a -> (
let ((expr , type_expr) , loc) = r_split a in let par, loc = r_split a in
let expr, _, type_expr = par.inside in
let%bind expr' = compile_expression expr in let%bind expr' = compile_expression expr in
let%bind type_expr' = compile_type_expression type_expr in let%bind type_expr' = compile_type_expression type_expr in
return @@ e_annotation ~loc expr' type_expr' return @@ e_annotation ~loc expr' type_expr'
) )
| EVar c -> ( | EVar c -> (
let (c' , loc) = r_split c in let (c', loc) = r_split c in
match constants c' with match constants c' with
| None -> return @@ e_variable ~loc (Var.of_name c.value) | None -> return @@ e_variable ~loc (Var.of_name c.value)
| Some s -> return @@ e_constant ~loc s [] | Some s -> return @@ e_constant ~loc s []
) )
| ECall x -> ( | ECall x -> (
let ((f, args) , loc) = r_split x in let ((f, args), loc) = r_split x in
let (args , args_loc) = r_split args in let (args, args_loc) = r_split args in
let args' = npseq_to_list args.inside in let args' = npseq_to_list args.inside in
match f with match f with
| EVar name -> ( | EVar name -> (
@ -698,7 +699,7 @@ and compile_fun_expression :
loc:_ -> Raw.fun_expr -> (type_expression option * expression) result = loc:_ -> Raw.fun_expr -> (type_expression option * expression) result =
fun ~loc x -> fun ~loc x ->
let open! Raw in let open! Raw in
let {kwd_recursive;param;ret_type;return} : fun_expr = x in let {param; ret_type; return; _} : fun_expr = x in
let statements = [] in let statements = [] in
(match param.value.inside with (match param.value.inside with
a, [] -> ( a, [] -> (
@ -714,10 +715,8 @@ and compile_fun_expression :
bind_fold_right_list aux result body in bind_fold_right_list aux result body in
let binder = Var.of_name binder in let binder = Var.of_name binder in
let fun_type = t_function input_type output_type in let fun_type = t_function input_type output_type in
let expression = match kwd_recursive with let expression =
| None -> e_lambda ~loc binder (Some input_type)(Some output_type) result e_lambda ~loc binder (Some input_type)(Some output_type) result
| Some _ -> e_recursive ~loc binder fun_type
@@ {binder;input_type=Some input_type; output_type= Some output_type; result}
in in
ok (Some fun_type , expression) ok (Some fun_type , expression)
) )
@ -745,10 +744,8 @@ and compile_fun_expression :
let aux prec cur = cur (Some prec) in let aux prec cur = cur (Some prec) in
bind_fold_right_list aux result body in bind_fold_right_list aux result body in
let fun_type = t_function input_type output_type in let fun_type = t_function input_type output_type in
let expression = match kwd_recursive with let expression =
| None -> e_lambda ~loc binder (Some input_type)(Some output_type) result e_lambda ~loc binder (Some input_type)(Some output_type) result
| Some _ -> e_recursive ~loc binder fun_type
@@ {binder;input_type=Some input_type; output_type= Some output_type; result}
in in
ok (Some fun_type , expression) ok (Some fun_type , expression)
) )
@ -822,7 +819,7 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res
let%bind bound = compile_expression fi.bound in let%bind bound = compile_expression fi.bound in
let%bind step = match fi.step with let%bind step = match fi.step with
| None -> ok @@ e_int_z Z.one | None -> ok @@ e_int_z Z.one
| Some step -> compile_expression step in | Some (_, step) -> compile_expression step in
let%bind body = compile_block fi.block.value in let%bind body = compile_block fi.block.value in
let%bind body = body @@ None in let%bind body = body @@ None in
return_statement @@ e_for ~loc binder start bound step body return_statement @@ e_for ~loc binder start bound step body
@ -910,23 +907,24 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res
let%bind m = compile_cases cases in let%bind m = compile_cases cases in
return_statement @@ e_matching ~loc expr m return_statement @@ e_matching ~loc expr m
) )
| RecordPatch r -> ( | RecordPatch r ->
let reg = r.region in let reg = r.region in
let (r,loc) = r_split r in let (r,loc) = r_split r in
let aux (fa :Raw.field_assign Raw.reg) : Raw.field_path_assign Raw.reg= let aux (fa :Raw.field_assign Raw.reg) : Raw.field_path_assign Raw.reg =
{value = {field_path = (fa.value.field_name, []); equal=fa.value.equal; field_expr = fa.value.field_expr}; {value = {field_path = fa.value.field_name, [];
region = fa.region} assignment = fa.value.assignment;
in field_expr = fa.value.field_expr};
region = fa.region} in
let update : Raw.field_path_assign Raw.reg Raw.ne_injection Raw.reg = { let update : Raw.field_path_assign Raw.reg Raw.ne_injection Raw.reg = {
value = Raw.map_ne_injection aux r.record_inj.value; value = Raw.map_ne_injection aux r.record_inj.value;
region=r.record_inj.region region = r.record_inj.region} in
} in let u : Raw.update = {
let u : Raw.update = {record=r.path;kwd_with=r.kwd_with; updates=update} in record = r.path;
kwd_with = r.kwd_with;
updates = update} in
let%bind expr = compile_update {value=u;region=reg} in let%bind expr = compile_update {value=u;region=reg} in
let (name , access_path) = compile_path r.path in let (name , access_path) = compile_path r.path in
return_statement @@ e_ez_assign ~loc name access_path expr return_statement @@ e_ez_assign ~loc name access_path expr
)
| MapPatch patch -> ( | MapPatch patch -> (
let (map_p, loc) = r_split patch in let (map_p, loc) = r_split patch in
let (name, access_path) = compile_path map_p.path in let (name, access_path) = compile_path map_p.path in