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
parent
6f56b297f2
commit
77920a1c58
@ -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;
|
||||
|
||||
@ -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 {
|
||||
|
||||
@ -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,14 +168,15 @@ 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
|
||||
in if kwd_else#is_ghost
|
||||
then test ^/^ ifso
|
||||
else test ^/^ ifso ^/^ ifnot
|
||||
|
||||
and pp_annot_expr {value; _} =
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)) }
|
||||
|
||||
@ -221,9 +221,8 @@ 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 ":";
|
||||
@ -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
|
||||
|
||||
|
||||
@ -32,13 +32,13 @@ 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)
|
||||
| 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,7 +117,15 @@ 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;
|
||||
@ -126,23 +134,23 @@ and pp_fun_decl {value; _} =
|
||||
match kwd_recursive with
|
||||
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
|
||||
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_if_clause ifnot))
|
||||
^^ group (nest 2 (hardline ^^ pp_clause_block b))
|
||||
^^ hardline ^^ string "}"
|
||||
else
|
||||
string "else" ^^ group (nest 2 (break 1 ^^ pp_if_clause ifnot))
|
||||
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"
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user