Fixed parsing of lambdas (cannot be recursive) in PascaLIGO.

Added more to the pretty-printing of PascaLIGO.
Improved pretty-printing of CameLIGO.
This commit is contained in:
Christian Rinderknecht 2020-06-05 23:24:49 +02:00
parent 6f56b297f2
commit 77920a1c58
7 changed files with 130 additions and 105 deletions

View File

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

View File

@ -583,7 +583,10 @@ core_expr:
| record_expr { ERecord $1 }
| update_record { EUpdate $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_name "." module_fun {

View File

@ -41,8 +41,9 @@ and pp_verbatim s = string "{|" ^^ pp_ident s ^^ string "|}"
and pp_let_binding (binding : let_binding) =
let {binders; lhs_type; let_rhs; _} = binding in
let patterns = Utils.nseq_to_list binders in
let patterns = group (separate_map (break 1) pp_pattern patterns) in
let head, tail = binders in
let patterns =
group (nest 2 (separate_map (break 1) pp_pattern (head::tail))) in
let lhs =
patterns ^^
match lhs_type with
@ -95,11 +96,11 @@ and pp_ppar p = pp_par pp_pattern p
and pp_plist = function
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_cons {value; _} =
and pp_pcons {value; _} =
let patt1, _, patt2 = value in
prefix 2 1 (pp_pattern patt1 ^^ string " ::") (pp_pattern patt2)
@ -126,14 +127,15 @@ and pp_ptyped {value; _} =
and pp_type_decl decl =
let {name; type_expr; _} = decl.value in
let padding = match type_expr with TSum _ -> 0 | _ -> 2 in
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
ECase e -> pp_case_expr e
| ECond e -> group (pp_cond_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)
| EString e -> pp_string_expr e
| EList e -> group (pp_list_expr e)
@ -166,15 +168,16 @@ and pp_cases {value; _} =
and pp_clause {value; _} =
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; _} =
let {test; ifso; kwd_else; ifnot; _} = 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 if kwd_else#is_ghost then test ^/^ ifso
else test ^/^ ifso ^/^ ifnot
in if kwd_else#is_ghost
then test ^/^ ifso
else test ^/^ ifso ^/^ ifnot
and pp_annot_expr {value; _} =
let expr, _, type_expr = value.inside in
@ -420,7 +423,7 @@ and pp_field_decl {value; _} =
in prefix 2 1 (name ^^ string " :") t_expr
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; _} =
let head, tail = value.inside in

View File

@ -206,7 +206,6 @@ and type_tuple = (type_expr, comma) nsepseq par reg
(* Function and procedure declarations *)
and fun_expr = {
kwd_recursive: kwd_recursive option;
kwd_function : kwd_function;
param : parameters;
colon : colon;
@ -448,7 +447,7 @@ and collection =
and expr =
ECase of expr case reg
| ECond of cond_expr reg
| EAnnot of annot_expr reg
| EAnnot of annot_expr par reg
| ELogic of logic_expr
| EArith of arith_expr
| EString of string_expr
@ -467,7 +466,7 @@ and expr =
| EPar of expr par reg
| EFun of fun_expr reg
and annot_expr = expr * type_expr
and annot_expr = expr * colon * type_expr
and set_expr =
SetInj of expr injection reg

View File

@ -239,16 +239,15 @@ field_decl:
fun_expr:
ioption ("recursive") "function" parameters ":" type_expr "is" expr {
let stop = expr_to_region $7 in
let region = cover $2 stop
and value = {kwd_recursive= $1;
kwd_function = $2;
param = $3;
colon = $4;
ret_type = $5;
kwd_is = $6;
return = $7}
"function" parameters ":" type_expr "is" expr {
let stop = expr_to_region $6 in
let region = cover $1 stop
and value = {kwd_function = $1;
param = $2;
colon = $3;
ret_type = $4;
kwd_is = $5;
return = $6}
in {region; value} }
(* Function declarations *)
@ -849,7 +848,7 @@ core_expr:
| "False" { ELogic (BoolExpr (False $1)) }
| "True" { ELogic (BoolExpr (True $1)) }
| "Unit" { EUnit $1 }
| annot_expr { EAnnot $1 }
| par(annot_expr) { EAnnot $1 }
| tuple_expr { ETuple $1 }
| list_expr { EList $1 }
| "None" { EConstr (NoneExpr $1) }
@ -891,12 +890,7 @@ fun_call_or_par_or_projection:
| fun_call { ECall $1 }
annot_expr:
"(" disj_expr ":" type_expr ")" {
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} }
disj_expr ":" type_expr { $1,$2,$3 }
set_expr:
injection("set",expr) { SetInj ($1 (fun region -> InjSet region)) }

View File

@ -180,9 +180,9 @@ and print_type_app state {value; _} =
and print_type_fun state {value; _} =
let type_expr_a, arrow, type_expr_b = value in
print_type_expr state type_expr_a;
print_token state arrow "->";
print_type_expr state type_expr_b
print_type_expr state type_expr_a;
print_token state arrow "->";
print_type_expr state type_expr_b
and print_par_type state {value; _} =
let {lpar; inside; rpar} = value in
@ -206,12 +206,12 @@ and print_fun_decl state {value; _} =
let {kwd_function; fun_name; param; colon;
ret_type; kwd_is; block_with;
return; terminator; _} = value in
print_token state kwd_function "function";
print_var state fun_name;
print_parameters state param;
print_token state colon ":";
print_type_expr state ret_type;
print_token state kwd_is "is";
print_token state kwd_function "function";
print_var state fun_name;
print_parameters state param;
print_token state colon ":";
print_type_expr state ret_type;
print_token state kwd_is "is";
(match block_with with
None -> ()
| Some (block, kwd_with) ->
@ -221,15 +221,14 @@ and print_fun_decl state {value; _} =
print_terminator state terminator;
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
print_token_opt state kwd_recursive "recursive";
print_token state kwd_function "function";
print_parameters state param;
print_token state colon ":";
print_type_expr state ret_type;
print_token state kwd_is "is";
print_expr state return
print_token state kwd_function "function";
print_parameters state param;
print_token state colon ":";
print_type_expr state ret_type;
print_token state kwd_is "is";
print_expr state return
and print_parameters state {value; _} =
let {lpar; inside; rpar} = value in
@ -260,10 +259,10 @@ and print_block state block =
match enclosing with
Block (kwd_block, lbrace, rbrace) ->
print_token state kwd_block "block";
print_token state lbrace "{";
print_token state lbrace "{";
print_statements state statements;
print_terminator state terminator;
print_token state rbrace "}"
print_token state rbrace "}"
| BeginEnd (kwd_begin, kwd_end) ->
print_token state kwd_begin "begin";
print_statements state statements;
@ -464,7 +463,9 @@ and print_expr state = function
| EPar e -> print_par_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_type_expr state type_expr
@ -1432,7 +1433,7 @@ and pp_expr state = function
pp_cond_expr state value
| EAnnot {value; region} ->
pp_loc_node state "EAnnot" region;
pp_annotated state value
pp_annotated state value.inside
| ELogic e_logic ->
pp_node state "ELogic";
pp_e_logic (state#pad 1 0) e_logic
@ -1607,7 +1608,7 @@ and pp_string_expr state = function
pp_node state "Verbatim";
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_type_expr (state#pad 2 1) t_expr

View File

@ -32,14 +32,14 @@ and pp_attr_decl decl = pp_ne_injection pp_string decl
and pp_const_decl {value; _} =
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 attr = match attributes with
None -> empty
| Some a -> hardline ^^ pp_attr_decl a
in prefix 2 1 start t_expr
^/^ prefix 2 1 (string "=") (pp_expr init)
^^ attr
| Some a -> hardline ^^ pp_attr_decl a in
group (start ^/^ nest 2 (string ": " ^^ t_expr))
^^ group (break 1 ^^ nest 2 (string "= " ^^ pp_expr init))
^^ attr
(* Type declarations *)
@ -117,32 +117,40 @@ and pp_type_tuple {value; _} =
(* 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; _} =
let {kwd_recursive; fun_name; param;
ret_type; block_with; return; attributes; _} = value in
let start =
match kwd_recursive with
None -> string "function"
None -> string "function"
| 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 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 attr = match attributes with
let body =
match block_with with
None -> group (nest 2 (break 1 ^^ expr))
| Some (b,_) -> hardline ^^ string "block ["
^^ nest 2 (hardline ^^ pp_block b)
^^ hardline
^^ group (string "] with" ^^ nest 4 (break 1 ^^ expr))
and attr = match attributes with
None -> empty
| Some a -> hardline ^^ pp_attr_decl a
in group (start ^^ nest 2 (break 1 ^^ parameters))
^/^ string ": " ^^ nest 2 return_t
^^ blk_opening
^^ nest 2 (break 0 ^^ blk_in)
^/^ group (blk_closing ^^ nest 4 (break 1 ^^ expr))
^^ attr
| Some a -> hardline ^^ pp_attr_decl a in
prefix 2 1 start parameters
^^ group (nest 2 (break 1 ^^ string ": " ^^ return_t ^^ string " is"))
^^ body ^^ attr
and pp_parameters p = pp_nsepseq ";" pp_param_decl p
@ -178,10 +186,10 @@ and pp_data_decl = function
and pp_var_decl {value; _} =
let {name; var_type; init; _} = value in
let start = string ("var " ^ name.value ^ " :") in
let t_expr = pp_type_expr var_type
in prefix 2 1 start
(t_expr ^/^ prefix 2 1 (string ":=") (pp_expr init))
let start = string ("var " ^ name.value) in
let t_expr = pp_type_expr var_type in
group (start ^/^ nest 2 (string ": " ^^ t_expr))
^^ group (break 1 ^^ nest 2 (string ":= " ^^ pp_expr init))
and pp_instruction = function
Cond i -> group (pp_conditional i)
@ -196,41 +204,52 @@ and pp_instruction = function
| MapRemove i -> pp_map_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))
^/^ string "from set" ^^ group (nest 2 (break 1 ^^ 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))
^/^ string "from map" ^^ group (nest 2 (break 1 ^^ pp_path map))
and pp_set_patch {value; _} = string "TODO:pp_set_patch"
and pp_map_patch {value; _} = string "TODO:pp_map_patch"
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_cond_expr {value; _} = string "TODO:pp_cond_expr"
and pp_cond_expr {value; _} =
let {test; ifso; kwd_else; 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; _} =
let {test; ifso; ifnot; _} : conditional = value in
let test = string "if " ^^ group (nest 3 (pp_expr test))
and ifso = string "then" ^^ group (nest 2 (break 1 ^^ pp_if_clause ifso))
and ifnot =
if is_clause_block ifnot then
string "else {"
^^ group (nest 2 (hardline ^^ pp_if_clause ifnot))
^^ hardline ^^ string "}"
else
string "else" ^^ group (nest 2 (break 1 ^^ pp_if_clause ifnot))
and ifnot = match ifnot with
ClauseInstr i ->
string "else"
^^ group (nest 2 (break 1 ^^ pp_instruction i))
| ClauseBlock b ->
string "else {"
^^ group (nest 2 (hardline ^^ pp_clause_block b))
^^ hardline ^^ string "}"
in test ^/^ ifso ^/^ ifnot
and pp_if_clause = function
ClauseInstr i -> pp_instruction i
| ClauseBlock b -> pp_clause_block b
and is_clause_block = function
ClauseInstr _ -> false
| ClauseBlock _ -> true
and pp_clause_block = function
LongBlock b -> pp_block b
| ShortBlock {value; _} -> Utils.(pp_statements <@ fst) value.inside
@ -251,7 +270,7 @@ and pp_cases :
fun printer {value; _} ->
let head, tail = value 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 app clause = break 1 ^^ string "| " ^^ pp_case_clause printer clause
in head ^^ concat_map app rest
@ -260,8 +279,7 @@ and pp_case_clause :
'a.('a -> document) -> 'a case_clause Region.reg -> document =
fun printer {value; _} ->
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; _} =
let {lhs; rhs; _} = value in
@ -298,7 +316,7 @@ and pp_expr = function
ECase e -> pp_case pp_expr e
| ECond e -> group (pp_cond_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)
| EString e -> pp_string_expr e
| EList e -> group (pp_list_expr e)
@ -316,7 +334,10 @@ and pp_expr = function
| EPar e -> pp_par pp_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
SetInj inj -> string "TODO:pp_set_expr:SetInj"
@ -324,11 +345,11 @@ and pp_set_expr = function
and pp_map_expr = function
MapLookUp fetch -> pp_map_lookup fetch
| MapInj inj -> pp_injection pp_binding inj
| BigMapInj inj -> pp_injection pp_binding inj
| MapInj inj -> group (pp_injection pp_binding inj)
| BigMapInj inj -> group (pp_injection pp_binding inj)
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
Name v -> pp_ident v
@ -451,7 +472,8 @@ and pp_injection :
let kwd = pp_injection_kwd kind in
let offset = String.length kwd + 2 in
string (kwd ^ " [")
^^ group (nest 2 (break 0 ^^ elements ^^ string "]"))
^^ group (nest 2 (break 0 ^^ elements))
^^ break 0 ^^ string "]"
and pp_injection_kwd = function
InjSet _ -> "set"
@ -467,7 +489,8 @@ and pp_ne_injection :
let kwd = pp_ne_injection_kwd kind in
let offset = String.length kwd + 2 in
string (kwd ^ " [")
^^ group (nest 2 (break 0 ^^ elements ^^ string "]"))
^^ group (nest 2 (break 0 ^^ elements ))
^^ break 0 ^^ string "]"
and pp_ne_injection_kwd = function
NEInjAttr _ -> "attributes"
@ -526,9 +549,9 @@ and pp_list_pattern = function
PListComp cmp -> pp_list_comp cmp
| PNil _ -> string "nil"
| 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 = group (pp_injection pp_pattern e)
and pp_ppar_cons {value; _} = string "TODO:pp_ppar_cons"