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

Added more to the PascaLIGO pretty-printer.

Browse Source 
Improved the AST of PascaLIGO to better capture the struture.
This commit is contained in:
Christian Rinderknecht 2020-05-30 20:24:47 +02:00
parent 3264277310
commit 2d74681c96
11 changed files with 751 additions and 285 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
src/main/compile/helpers.ml
View File

@ -192,7 +192,7 @@ let pretty_print_pascaligo source =
let pretty_print_cameligo source =
let%bind ast = Parser.Cameligo.parse_file source in
let doc = Parser_cameligo.Pretty.make ast in
let doc = Parser_cameligo.Pretty.print ast in
let buffer = Buffer.create 131 in
let width =
match Terminal_size.get_columns () with
@ -203,7 +203,7 @@ let pretty_print_cameligo source =
let pretty_print_reasonligo source =
let%bind ast = Parser.Reasonligo.parse_file source in
let doc = Parser_cameligo.Pretty.make ast in (* TODO *)
let doc = Parser_cameligo.Pretty.print ast in (* TODO *)
let buffer = Buffer.create 131 in
let width =
match Terminal_size.get_columns () with

2
src/passes/1-parser/cameligo.ml
View File

@ -157,7 +157,7 @@ let pretty_print source =
match parse_file source with
Stdlib.Error _ as e -> e
| Ok ast ->
let doc = Pretty.make (fst ast) in
let doc = Pretty.print (fst ast) in
let buffer = Buffer.create 131 in
let width =
match Terminal_size.get_columns () with

2
src/passes/1-parser/cameligo/ParserMain.ml
View File

@ -78,7 +78,7 @@ let wrap = function
Stdlib.Ok ast ->
if IO.options#pretty then
begin
let doc = Pretty.make ast in
let doc = Pretty.print ast in
let width =
match Terminal_size.get_columns () with
None -> 60

20
src/passes/1-parser/cameligo/Pretty.ml
View File

@ -5,11 +5,13 @@ module Region = Simple_utils.Region
open! Region
open! PPrint
(*let paragraph (s : string) = flow (break 1) (words s)*)
let pp_par printer {value; _} =
string "(" ^^ nest 1 (printer value.inside ^^ string ")")
let rec make ast =
let rec print ast =
let app decl = group (pp_declaration decl) in
separate_map (hardline ^^ hardline) app (Utils.nseq_to_list ast.decl)
let decl = Utils.nseq_to_list ast.decl in
separate_map (hardline ^^ hardline) app decl
and pp_declaration = function
Let decl -> pp_let_decl decl
@ -90,8 +92,7 @@ and pp_nat {value; _} =
and pp_bytes {value; _} =
string ("0x" ^ Hex.show (snd value))
and pp_ppar {value; _} =
string "(" ^^ nest 1 (pp_pattern value.inside ^^ string ")")
and pp_ppar p = pp_par pp_pattern p
and pp_plist = function
PListComp cmp -> pp_list_comp cmp
@ -345,8 +346,7 @@ and pp_tuple_expr {value; _} =
then pp_expr head
else pp_expr head ^^ string "," ^^ app (List.map snd tail)
and pp_par_expr {value; _} =
string "(" ^^ nest 1 (pp_expr value.inside ^^ string ")")
and pp_par_expr e = pp_par pp_expr e
and pp_let_in {value; _} =
let {binding; kwd_rec; body; attributes; _} = value in
@ -425,8 +425,7 @@ and pp_field_decl {value; _} =
let t_expr = pp_type_expr field_type
in prefix 2 1 (name ^^ string " :") t_expr
and pp_type_app {value; _} =
let ctor, tuple = value in
and pp_type_app {value = ctor, tuple; _} =
prefix 2 1 (pp_type_tuple tuple) (pp_type_constr ctor)
and pp_type_tuple {value; _} =
@ -449,5 +448,4 @@ and pp_fun_type {value; _} =
let lhs, _, rhs = value in
group (pp_type_expr lhs ^^ string " ->" ^/^ pp_type_expr rhs)
and pp_type_par {value; _} =
string "(" ^^ nest 1 (pp_type_expr value.inside ^^ string ")")
and pp_type_par t = pp_par pp_type_expr t

82
src/passes/1-parser/pascaligo/AST.ml
View File

@ -109,6 +109,7 @@ type eof = Region.t
type variable = string reg
type fun_name = string reg
type type_name = string reg
type type_constr = string reg
type field_name = string reg
type map_name = string reg
type set_name = string reg
@ -181,7 +182,7 @@ and type_expr =
TProd of cartesian
| TSum of (variant reg, vbar) nsepseq reg
| TRecord of field_decl reg ne_injection reg
| TApp of (type_name * type_tuple) reg
| TApp of (type_constr * type_tuple) reg
| TFun of (type_expr * arrow * type_expr) reg
| TPar of type_expr par reg
| TVar of variable
@ -249,19 +250,14 @@ and param_var = {
}
and block = {
opening : block_opening;
enclosing : block_enclosing;
statements : statements;
terminator : semi option;
closing : block_closing
terminator : semi option
}
and block_opening =
Block of kwd_block * lbrace
| Begin of kwd_begin
and block_closing =
Block of rbrace
| End of kwd_end
and block_enclosing =
Block of kwd_block * lbrace * rbrace
| BeginEnd of kwd_begin * kwd_end
and statements = (statement, semi) nsepseq
@ -378,10 +374,10 @@ and set_membership = {
and 'a case = {
kwd_case : kwd_case;
expr : expr;
opening : opening;
kwd_of : kwd_of;
enclosing : enclosing;
lead_vbar : vbar option;
cases : ('a case_clause reg, vbar) nsepseq reg;
closing : closing
cases : ('a case_clause reg, vbar) nsepseq reg
}
and 'a case_clause = {
@ -471,34 +467,12 @@ and expr =
| EPar of expr par reg
| EFun of fun_expr reg
and annot_expr = (expr * type_expr)
and annot_expr = expr * type_expr
and set_expr =
SetInj of expr injection reg
| SetMem of set_membership reg
and 'a injection = {
opening : opening;
elements : ('a, semi) sepseq;
terminator : semi option;
closing : closing
}
and 'a ne_injection = {
opening : opening;
ne_elements : ('a, semi) nsepseq;
terminator : semi option;
closing : closing
}
and opening =
Kwd of keyword
| KwdBracket of keyword * lbracket
and closing =
End of kwd_end
| RBracket of rbracket
and map_expr =
MapLookUp of map_lookup reg
| MapInj of binding reg injection reg
@ -605,6 +579,38 @@ and fun_call = (expr * arguments) reg
and arguments = tuple_expr
(* Injections *)
and 'a injection = {
kind : injection_kwd;
enclosing : enclosing;
elements : ('a, semi) sepseq;
terminator : semi option
}
and injection_kwd =
InjSet of keyword
| InjMap of keyword
| InjBigMap of keyword
| InjList of keyword
and enclosing =
Brackets of lbracket * rbracket
| End of kwd_end
and 'a ne_injection = {
kind : ne_injection_kwd;
enclosing : enclosing;
ne_elements : ('a, semi) nsepseq;
terminator : semi option
}
and ne_injection_kwd =
NEInjAttr of keyword
| NEInjSet of keyword
| NEInjMap of keyword
| NEInjRecord of keyword
(* Patterns *)
and pattern =
@ -635,7 +641,7 @@ and list_pattern =
| PCons of (pattern, cons) nsepseq reg
(* Projecting regions *)
(* PROJECTING REGIONS *)
let rec last to_region = function
[] -> Region.ghost

168
src/passes/1-parser/pascaligo/Parser.mly
View File

@ -122,7 +122,8 @@ attr_decl:
open_attr_decl ";"? { $1 }
open_attr_decl:
ne_injection("attributes","<string>") { $1 }
ne_injection("attributes","<string>") {
$1 (fun region -> NEInjAttr region) }
(* Type declarations *)
@ -214,19 +215,19 @@ record_type:
let () = Utils.nsepseq_to_list ne_elements
|> Scoping.check_fields in
let region = cover $1 $3
and value = {opening = Kwd $1;
and value = {kind = NEInjRecord $1;
enclosing = End $3;
ne_elements;
terminator;
closing = End $3}
terminator}
in TRecord {region; value}
}
| "record" "[" sep_or_term_list(field_decl,";") "]" {
let ne_elements, terminator = $3 in
let region = cover $1 $4
and value = {opening = KwdBracket ($1,$2);
and value = {kind = NEInjRecord $1;
enclosing = Brackets ($2,$4);
ne_elements;
terminator;
closing = RBracket $4}
terminator}
in TRecord {region; value} }
field_decl:
@ -238,7 +239,7 @@ field_decl:
fun_expr:
| ioption ("recursive") "function" parameters ":" type_expr "is" 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;
@ -271,7 +272,8 @@ open_fun_decl:
attributes = None}
in {region; value}
}
| ioption ("recursive") "function" fun_name parameters ":" type_expr "is" expr {
| ioption ("recursive") "function" fun_name parameters ":" type_expr "is"
expr {
Scoping.check_reserved_name $3;
let stop = expr_to_region $8 in
let region = cover $2 stop
@ -326,19 +328,17 @@ block:
"begin" sep_or_term_list(statement,";") "end" {
let statements, terminator = $2 in
let region = cover $1 $3
and value = {opening = Begin $1;
and value = {enclosing = BeginEnd ($1,$3);
statements;
terminator;
closing = End $3}
terminator}
in {region; value}
}
| "block" "{" sep_or_term_list(statement,";") "}" {
let statements, terminator = $3 in
let region = cover $1 $4
and value = {opening = Block ($1,$2);
and value = {enclosing = Block ($1,$2,$4);
statements;
terminator;
closing = Block $4}
terminator}
in {region; value} }
statement:
@ -404,8 +404,7 @@ instruction:
set_remove:
"remove" expr "from" "set" path {
let region = cover $1 (path_to_region $5) in
let value = {
kwd_remove = $1;
let value = {kwd_remove = $1;
element = $2;
kwd_from = $3;
kwd_set = $4;
@ -415,8 +414,7 @@ set_remove:
map_remove:
"remove" expr "from" "map" path {
let region = cover $1 (path_to_region $5) in
let value = {
kwd_remove = $1;
let value = {kwd_remove = $1;
key = $2;
kwd_from = $3;
kwd_map = $4;
@ -425,82 +423,83 @@ map_remove:
set_patch:
"patch" path "with" ne_injection("set",expr) {
let region = cover $1 $4.region in
let value = {
kwd_patch = $1;
let set_inj = $4 (fun region -> NEInjSet region) in
let region = cover $1 set_inj.region in
let value = {kwd_patch = $1;
path = $2;
kwd_with = $3;
set_inj = $4}
set_inj}
in {region; value} }
map_patch:
"patch" path "with" ne_injection("map",binding) {
let region = cover $1 $4.region in
let value = {
kwd_patch = $1;
let map_inj = $4 (fun region -> NEInjMap region) in
let region = cover $1 map_inj.region in
let value = {kwd_patch = $1;
path = $2;
kwd_with = $3;
map_inj = $4}
map_inj}
in {region; value} }
injection(Kind,element):
Kind sep_or_term_list(element,";") "end" {
fun mk_kwd ->
let elements, terminator = $2 in
let region = cover $1 $3
and value = {
opening = Kwd $1;
kind = mk_kwd $1;
enclosing = End $3;
elements = Some elements;
terminator;
closing = End $3}
terminator}
in {region; value}
}
| Kind "end" {
fun mk_kwd ->
let region = cover $1 $2
and value = {
opening = Kwd $1;
and value = {kind = mk_kwd $1;
enclosing = End $2;
elements = None;
terminator = None;
closing = End $2}
terminator = None}
in {region; value}
}
| Kind "[" sep_or_term_list(element,";") "]" {
fun mk_kwd ->
let elements, terminator = $3 in
let region = cover $1 $4
and value = {
opening = KwdBracket ($1,$2);
and value = {kind = mk_kwd $1;
enclosing = Brackets ($2,$4);
elements = Some elements;
terminator;
closing = RBracket $4}
terminator}
in {region; value}
}
| Kind "[" "]" {
fun mk_kwd ->
let region = cover $1 $3
and value = {
opening = KwdBracket ($1,$2);
and value = {kind = mk_kwd $1;
enclosing = Brackets ($2,$3);
elements = None;
terminator = None;
closing = RBracket $3}
terminator = None}
in {region; value} }
ne_injection(Kind,element):
Kind sep_or_term_list(element,";") "end" {
fun mk_kwd ->
let ne_elements, terminator = $2 in
let region = cover $1 $3
and value = {
opening = Kwd $1;
and value = {kind = mk_kwd $1;
enclosing = End $3;
ne_elements;
terminator;
closing = End $3}
terminator}
in {region; value}
}
| Kind "[" sep_or_term_list(element,";") "]" {
fun mk_kwd ->
let ne_elements, terminator = $3 in
let region = cover $1 $4
and value = {
opening = KwdBracket ($1,$2);
and value = {kind = mk_kwd $1;
enclosing = Brackets ($2,$4);
ne_elements;
terminator;
closing = RBracket $4}
terminator}
in {region; value} }
binding:
@ -508,20 +507,19 @@ binding:
let start = expr_to_region $1
and stop = expr_to_region $3 in
let region = cover start stop
and value = {
source = $1;
and value = {source = $1;
arrow = $2;
image = $3}
in {region; value} }
record_patch:
"patch" path "with" ne_injection("record",field_assignment) {
let region = cover $1 $4.region in
let value = {
kwd_patch = $1;
let record_inj = $4 (fun region -> NEInjRecord region) in
let region = cover $1 record_inj.region in
let value = {kwd_patch = $1;
path = $2;
kwd_with = $3;
record_inj = $4}
record_inj}
in {region; value} }
proc_call:
@ -547,12 +545,9 @@ if_clause:
clause_block:
block { LongBlock $1 }
| "{" sep_or_term_list(statement,";") "}" {
let statements, terminator = $2 in
let region = cover $1 $3 in
let value = {lbrace = $1;
inside = statements, terminator;
rbrace = $3} in
ShortBlock {value; region} }
let value = {lbrace=$1; inside=$2; rbrace=$3}
in ShortBlock {value; region} }
case_instr:
case(if_clause) { $1 if_clause_to_region }
@ -563,10 +558,10 @@ case(rhs):
let region = cover $1 $6 in
let value = {kwd_case = $1;
expr = $2;
opening = Kwd $3;
kwd_of = $3;
enclosing = End $6;
lead_vbar = $4;
cases = $5 rhs_to_region;
closing = End $6}
cases = $5 rhs_to_region}
in {region; value}
}
| "case" expr "of" "[" "|"? cases(rhs) "]" {
@ -574,10 +569,10 @@ case(rhs):
let region = cover $1 $7 in
let value = {kwd_case = $1;
expr = $2;
opening = KwdBracket ($3,$4);
kwd_of = $3;
enclosing = Brackets ($4,$7);
lead_vbar = $5;
cases = $6 rhs_to_region;
closing = RBracket $7}
cases = $6 rhs_to_region}
in {region; value} }
cases(rhs):
@ -904,12 +899,17 @@ annot_expr:
in {region; value} }
set_expr:
injection("set",expr) { SetInj $1 }
injection("set",expr) { SetInj ($1 (fun region -> InjSet region)) }
map_expr:
map_lookup { MapLookUp $1 }
| injection("map",binding) { MapInj $1 }
| injection("big_map",binding) { BigMapInj $1 }
map_lookup {
MapLookUp $1
}
| injection("map",binding) {
MapInj ($1 (fun region -> InjMap region))
}
| injection("big_map",binding) {
BigMapInj ($1 (fun region -> InjBigMap region)) }
map_lookup:
path brackets(expr) {
@ -958,26 +958,27 @@ record_expr:
let ne_elements, terminator = $2 in
let region = cover $1 $3
and value : field_assign AST.reg ne_injection = {
opening = Kwd $1;
kind = NEInjRecord $1;
enclosing = End $3;
ne_elements;
terminator;
closing = End $3}
terminator}
in {region; value}
}
| "record" "[" sep_or_term_list(field_assignment,";") "]" {
let ne_elements, terminator = $3 in
let region = cover $1 $4
and value : field_assign AST.reg ne_injection = {
opening = KwdBracket ($1,$2);
kind = NEInjRecord $1;
enclosing = Brackets ($2,$4);
ne_elements;
terminator;
closing = RBracket $4}
terminator}
in {region; value} }
update_record:
path "with" ne_injection("record",field_path_assignment){
let region = cover (path_to_region $1) $3.region in
let value = {record=$1; kwd_with=$2; updates=$3}
path "with" ne_injection("record",field_path_assignment) {
let updates = $3 (fun region -> NEInjRecord region) in
let region = cover (path_to_region $1) updates.region in
let value = {record=$1; kwd_with=$2; updates}
in {region; value} }
field_assignment:
@ -1010,7 +1011,7 @@ arguments:
par(nsepseq(expr,",")) { $1 }
list_expr:
injection("list",expr) { EListComp $1 }
injection("list",expr) { EListComp ($1 (fun region -> InjList region)) }
| "nil" { ENil $1 }
(* Patterns *)
@ -1034,9 +1035,10 @@ core_pattern:
| constr_pattern { PConstr $1 }
list_pattern:
injection("list",core_pattern) { PListComp $1 }
| "nil" { PNil $1 }
"nil" { PNil $1 }
| par(cons_pattern) { PParCons $1 }
| injection("list",core_pattern) {
PListComp ($1 (fun region -> InjList region)) }
cons_pattern:
core_pattern "#" pattern { $1,$2,$3 }

145
src/passes/1-parser/pascaligo/ParserLog.ml
View File

@ -27,7 +27,7 @@ let mk_state ~offsets ~mode ~buffer =
val pad_node = ""
method pad_node = pad_node
(** The method [pad] updates the current padding, which is
(* The method [pad] updates the current padding, which is
comprised of two components: the padding to reach the new node
(space before reaching a subtree, then a vertical bar for it)
and the padding for the new node itself (Is it the last child
@ -44,7 +44,7 @@ let mk_state ~offsets ~mode ~buffer =
let compact state (region: Region.t) =
region#compact ~offsets:state#offsets state#mode
(** {1 Printing the tokens with their source regions} *)
(* Printing the tokens with their source regions *)
let print_nsepseq :
state -> string -> (state -> 'a -> unit) ->
@ -117,7 +117,7 @@ let rec print_tokens state ast =
print_token state eof "EOF"
and print_attr_decl state =
print_ne_injection state "attributes" print_string
print_ne_injection state print_string
and print_decl state = function
TypeDecl decl -> print_type_decl state decl
@ -170,8 +170,8 @@ and print_variant state ({value; _}: variant reg) =
and print_sum_type state {value; _} =
print_nsepseq state "|" print_variant value
and print_record_type state record_type =
print_ne_injection state "record" print_field_decl record_type
and print_record_type state =
print_ne_injection state print_field_decl
and print_type_app state {value; _} =
let type_name, type_tuple = value in
@ -256,22 +256,19 @@ and print_param_var state {value; _} =
print_type_expr state param_type
and print_block state block =
let {opening; statements; terminator; closing} = block.value in
print_block_opening state opening;
let {enclosing; statements; terminator} = block.value in
match enclosing with
Block (kwd_block, lbrace, rbrace) ->
print_token state kwd_block "block";
print_token state lbrace "{";
print_statements state statements;
print_terminator state terminator;
print_block_closing state closing
and print_block_opening state = function
Block (kwd_block, lbrace) ->
print_token state kwd_block "block";
print_token state lbrace "{"
| Begin kwd_begin ->
print_token state kwd_begin "begin"
and print_block_closing state = function
Block rbrace -> print_token state rbrace "}"
| End kwd_end -> print_token state kwd_end "end"
print_token state rbrace "}"
| BeginEnd (kwd_begin, kwd_end) ->
print_token state kwd_begin "begin";
print_statements state statements;
print_terminator state terminator;
print_token state kwd_end "end"
and print_data_decl state = function
LocalConst decl -> print_const_decl state decl
@ -344,14 +341,20 @@ and print_clause_block state = function
print_token state rbrace "}"
and print_case_instr state (node : if_clause case) =
let {kwd_case; expr; opening;
lead_vbar; cases; closing} = node in
let {kwd_case; expr; kwd_of; enclosing; lead_vbar; cases} = node in
print_token state kwd_case "case";
print_expr state expr;
print_opening state "of" opening;
print_token state kwd_of "of";
match enclosing with
Brackets (lbracket, rbracket) ->
print_token state lbracket "[";
print_token_opt state lead_vbar "|";
print_cases_instr state cases;
print_closing state closing
print_token state rbracket "]"
| End kwd_end ->
print_token_opt state lead_vbar "|";
print_cases_instr state cases;
print_token state kwd_end "end"
and print_token_opt state = function
None -> fun _ -> ()
@ -466,14 +469,20 @@ and print_annot_expr state (expr , type_expr) =
print_type_expr state type_expr
and print_case_expr state (node : expr case) =
let {kwd_case; expr; opening;
lead_vbar; cases; closing} = node in
let {kwd_case; expr; kwd_of; enclosing; lead_vbar; cases} = node in
print_token state kwd_case "case";
print_expr state expr;
print_opening state "of" opening;
print_token state kwd_of "of";
match enclosing with
Brackets (lbracket, rbracket) ->
print_token state lbracket "[";
print_token_opt state lead_vbar "|";
print_cases_expr state cases;
print_closing state closing
print_token state rbracket "]"
| End kwd_end ->
print_token_opt state lead_vbar "|";
print_cases_expr state cases;
print_token state kwd_end "end"
and print_cases_expr state {value; _} =
print_nsepseq state "|" print_case_clause_expr value
@ -486,11 +495,11 @@ and print_case_clause_expr state {value; _} =
and print_map_expr state = function
MapLookUp {value; _} -> print_map_lookup state value
| MapInj inj -> print_injection state "map" print_binding inj
| BigMapInj inj -> print_injection state "big_map" print_binding inj
| MapInj inj -> print_injection state print_binding inj
| BigMapInj inj -> print_injection state print_binding inj
and print_set_expr state = function
SetInj inj -> print_injection state "set" print_expr inj
SetInj inj -> print_injection state print_expr inj
| SetMem mem -> print_set_membership state mem
and print_set_membership state {value; _} =
@ -600,7 +609,7 @@ and print_list_expr state = function
print_expr state arg1;
print_token state op "#";
print_expr state arg2
| EListComp e -> print_injection state "list" print_expr e
| EListComp e -> print_injection state print_expr e
| ENil e -> print_nil state e
and print_constr_expr state = function
@ -608,8 +617,8 @@ and print_constr_expr state = function
| NoneExpr e -> print_none_expr state e
| ConstrApp e -> print_constr_app state e
and print_record_expr state e =
print_ne_injection state "record" print_field_assign e
and print_record_expr state =
print_ne_injection state print_field_assign
and print_field_assign state {value; _} =
let {field_name; equal; field_expr} = value in
@ -627,8 +636,7 @@ and print_update_expr state {value; _} =
let {record; kwd_with; updates} = value in
print_path state record;
print_token state kwd_with "with";
print_ne_injection state "updates field" print_field_path_assign updates
print_ne_injection state print_field_path_assign updates
and print_projection state {value; _} =
let {struct_name; selector; field_path} = value in
@ -648,21 +656,21 @@ and print_record_patch state node =
print_token state kwd_patch "patch";
print_path state path;
print_token state kwd_with "with";
print_ne_injection state "record" print_field_assign record_inj
print_ne_injection state print_field_assign record_inj
and print_set_patch state node =
let {kwd_patch; path; kwd_with; set_inj} = node in
print_token state kwd_patch "patch";
print_path state path;
print_token state kwd_with "with";
print_ne_injection state "set" print_expr set_inj
print_ne_injection state print_expr set_inj
and print_map_patch state node =
let {kwd_patch; path; kwd_with; map_inj} = node in
print_token state kwd_patch "patch";
print_path state path;
print_token state kwd_with "with";
print_ne_injection state "map" print_binding map_inj
print_ne_injection state print_binding map_inj
and print_map_remove state node =
let {kwd_remove; key; kwd_from; kwd_map; map} = node in
@ -681,35 +689,48 @@ and print_set_remove state node =
print_path state set
and print_injection :
'a.state -> string -> (state -> 'a -> unit) ->
'a injection reg -> unit =
fun state kwd print {value; _} ->
let {opening; elements; terminator; closing} = value in
print_opening state kwd opening;
'a.state -> (state -> 'a -> unit) -> 'a injection reg -> unit =
fun state print {value; _} ->
let {kind; enclosing; elements; terminator} = value in
print_injection_kwd state kind;
match enclosing with
Brackets (lbracket, rbracket) ->
print_token state lbracket "[";
print_sepseq state ";" print elements;
print_terminator state terminator;
print_closing state closing
print_token state rbracket "]"
| End kwd_end ->
print_sepseq state ";" print elements;
print_terminator state terminator;
print_token state kwd_end "end"
and print_injection_kwd state = function
InjSet kwd_set -> print_token state kwd_set "set"
| InjMap kwd_map -> print_token state kwd_map "map"
| InjBigMap kwd_big_map -> print_token state kwd_big_map "big_map"
| InjList kwd_list -> print_token state kwd_list "list"
and print_ne_injection :
'a.state -> string -> (state -> 'a -> unit) ->
'a ne_injection reg -> unit =
fun state kwd print {value; _} ->
let {opening; ne_elements; terminator; closing} = value in
print_opening state kwd opening;
'a.state -> (state -> 'a -> unit) -> 'a ne_injection reg -> unit =
fun state print {value; _} ->
let {kind; enclosing; ne_elements; terminator} = value in
print_ne_injection_kwd state kind;
match enclosing with
Brackets (lbracket, rbracket) ->
print_token state lbracket "[";
print_nsepseq state ";" print ne_elements;
print_terminator state terminator;
print_closing state closing
print_token state rbracket "]"
| End kwd_end ->
print_nsepseq state ";" print ne_elements;
print_terminator state terminator;
print_token state kwd_end "end"
and print_opening state lexeme = function
Kwd kwd ->
print_token state kwd lexeme
| KwdBracket (kwd, lbracket) ->
print_token state kwd lexeme;
print_token state lbracket "["
and print_closing state = function
RBracket rbracket -> print_token state rbracket "]"
| End kwd_end -> print_token state kwd_end "end"
and print_ne_injection_kwd state = function
NEInjAttr kwd_attributes -> print_token state kwd_attributes "attributes"
| NEInjSet kwd_set -> print_token state kwd_set "set"
| NEInjMap kwd_map -> print_token state kwd_map "map"
| NEInjRecord kwd_record -> print_token state kwd_record "record"
and print_binding state {value; _} =
let {source; arrow; image} = value in
@ -787,7 +808,7 @@ and print_patterns state {value; _} =
and print_list_pattern state = function
PListComp comp ->
print_injection state "list" print_pattern comp
print_injection state print_pattern comp
| PNil kwd_nil ->
print_token state kwd_nil "nil"
| PParCons cons ->
@ -831,7 +852,7 @@ let pattern_to_string ~offsets ~mode =
let instruction_to_string ~offsets ~mode =
to_string ~offsets ~mode print_instruction
(** {1 Pretty-printing the AST} *)
(* Pretty-printing the AST *)
let pp_ident state {value=name; region} =
let reg = compact state region in

18
src/passes/1-parser/pascaligo/ParserMain.ml
View File

@ -75,9 +75,23 @@ module Unit =
(* Main *)
let wrap = function
Stdlib.Ok _ -> flush_all ()
Stdlib.Ok ast ->
if IO.options#pretty then
begin
let doc = Pretty.print ast in
let width =
match Terminal_size.get_columns () with
None -> 60
| Some c -> c in
PPrint.ToChannel.pretty 1.0 width stdout doc;
print_newline ()
end;
flush_all ()
| Error msg ->
(flush_all (); Printf.eprintf "\027[31m%s\027[0m%!" msg.Region.value)
begin
flush_all ();
Printf.eprintf "\027[31m%s\027[0m%!" msg.Region.value
end
let () =
match IO.options#input with

425
src/passes/1-parser/pascaligo/Pretty.ml Normal file
View File

@ -0,0 +1,425 @@
[@@@warning "-42"]
open AST
module Region = Simple_utils.Region
open! Region
open! PPrint
let pp_par (printer: 'a -> document) ({value; _} : 'a par reg) =
string "(" ^^ nest 1 (printer value.inside ^^ string ")")
let rec print ast =
let app decl = group (pp_declaration decl) in
let decl = Utils.nseq_to_list ast.decl in
separate_map (hardline ^^ hardline) app decl
and pp_declaration = function
TypeDecl d -> pp_type_decl d
| ConstDecl d -> pp_const_decl d
| FunDecl d -> pp_fun_decl d
| AttrDecl d -> pp_attr_decl d
and pp_attr_decl decl = pp_ne_injection pp_string decl
and pp_const_decl {value; _} = string "TODO:pp_const_decl"
(* Type declarations *)
and pp_type_decl decl =
let {name; type_expr; _} = decl.value in
string "type " ^^ string name.value ^^ string " is"
^^ group (nest 2 (break 1 ^^ pp_type_expr type_expr))
and pp_type_expr = function
TProd t -> pp_cartesian t
| TSum t -> pp_variants t
| TRecord t -> pp_fields t
| TApp t -> pp_type_app t
| TFun t -> pp_fun_type t
| TPar t -> pp_type_par t
| TVar t -> pp_ident t
| TString s -> pp_string s
and pp_cartesian {value; _} =
let head, tail = value in
let rec app = function
[] -> empty
| [e] -> group (break 1 ^^ pp_type_expr e)
| e::items ->
group (break 1 ^^ pp_type_expr e ^^ string " *") ^^ app items
in pp_type_expr head ^^ string " *" ^^ app (List.map snd tail)
and pp_variants {value; _} =
let head, tail = value in
let head = pp_variant head in
let head = if tail = [] then head
else ifflat head (string " " ^^ head) in
let rest = List.map snd tail in
let app variant = break 1 ^^ string "| " ^^ pp_variant variant
in head ^^ concat_map app rest
and pp_variant {value; _} =
let {constr; arg} = value in
match arg with
None -> pp_ident constr
| Some (_, e) ->
prefix 4 1 (pp_ident constr ^^ string " of") (pp_type_expr e)
and pp_fields fields = pp_ne_injection pp_field_decl fields
and pp_field_decl {value; _} =
let {field_name; field_type; _} = value in
let name = pp_ident field_name in
let t_expr = pp_type_expr field_type
in prefix 2 1 (name ^^ string " :") t_expr
and pp_fun_type {value; _} =
let lhs, _, rhs = value in
group (pp_type_expr lhs ^^ string " ->" ^/^ pp_type_expr rhs)
and pp_type_par t = pp_par pp_type_expr t
and pp_type_app {value = ctor, tuple; _} =
prefix 2 1 (pp_type_constr ctor) (pp_type_tuple tuple)
and pp_type_constr ctor = string ctor.value
and pp_type_tuple {value; _} =
let head, tail = value.inside in
let rec app = function
[] -> empty
| [e] -> group (break 1 ^^ pp_type_expr e)
| e::items ->
group (break 1 ^^ pp_type_expr e ^^ string ",") ^^ app items in
if tail = []
then pp_type_expr head
else
let components =
pp_type_expr head ^^ string "," ^^ app (List.map snd tail)
in string "(" ^^ nest 1 (components ^^ string ")")
(* Function and procedure declarations *)
and pp_fun_expr {value; _} = string "TODO:pp_fun_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"
| Some _ -> string "recursive" ^/^ string "function" in
let parameters = pp_par pp_parameters param in
let return_t = pp_type_expr ret_type in
string "TODO:pp_fun_decl"
and pp_parameters p = pp_nsepseq ";" pp_param_decl p
and pp_param_decl = function
ParamConst c -> pp_param_const c
| ParamVar v -> pp_param_var v
and pp_param_const {value; _} = string "PP:pp_param_const"
and pp_param_var {value; _} = string "TODO:pp_param_var"
and pp_block {value; _} = string "TODO:pp_block"
and pp_statements s = pp_nsepseq ";" pp_statement s
and pp_statement = function
Instr s -> pp_instruction s
| Data s -> pp_data_decl s
| Attr s -> pp_attr_decl s
and pp_data_decl = function
LocalConst d -> pp_const_decl d
| LocalVar d -> pp_var_decl d
| LocalFun d -> pp_fun_decl d
and pp_var_decl decl = string "TODO:pp_var_decl"
and pp_instruction = function
Cond i -> pp_conditional i
| CaseInstr i -> pp_case pp_if_clause i
| Assign i -> pp_assignment i
| Loop i -> pp_loop i
| ProcCall i -> pp_fun_call i
| Skip _ -> string "skip"
| RecordPatch i -> pp_record_patch i
| MapPatch i -> pp_map_patch i
| SetPatch i -> pp_set_patch i
| MapRemove i -> pp_map_remove i
| SetRemove i -> pp_set_remove i
and pp_set_remove {value; _} = string "TODO:pp_set_remove"
and pp_map_remove {value; _} = string "TODO:pp_map_remove"
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_record_patch {value; _} = string "TODO:pp_record_patch"
and pp_cond_expr {value; _} = string "TODO:pp_cond_expr"
and pp_conditional {value; _} = string "TODO:pp_conditional"
and pp_if_clause = function
ClauseInstr i -> pp_instruction i
| ClauseBlock b -> pp_clause_block b
and pp_clause_block = function
LongBlock b -> pp_block b
| ShortBlock b -> pp_short_block b
and pp_short_block {value; _} = string "TODO:pp_short_block"
and pp_set_membership {value; _} = string "TODO:pp_set_membership"
and pp_case :
'a.('a -> document) -> 'a case Region.reg -> document =
fun printer case -> string "TODO:pp_case"
and pp_case_clause :
'a.('a -> document) -> 'a case_clause Region.reg -> document =
fun printer clause -> string "TODO:pp_case_clause"
and pp_assignment {value; _} = string "TODO:pp_assignment"
and pp_lhs : lhs -> document = function
Path p -> pp_path p
| MapPath p -> pp_map_lookup p
and pp_loop = function
While l -> pp_while_loop l
| For f -> pp_for_loop f
and pp_while_loop {value; _} = string "TODO:pp_while_loop"
and pp_for_loop = function
ForInt l -> pp_for_int l
| ForCollect l -> pp_for_collect l
and pp_for_int {value; _} = string "TODO:pp_for_int"
and pp_var_assign {value; _} = string "TODO:pp_var_assign"
and pp_for_collect {value; _} = string "TODO:pp_for_collect"
and pp_collection = function
Map _ -> string "map"
| Set _ -> string "set"
| List _ -> string "list"
(* Expressions *)
and pp_expr = function
ECase e -> pp_case pp_expr e
| ECond e -> pp_cond_expr e
| EAnnot e -> pp_annot_expr e
| ELogic e -> pp_logic_expr e
| EArith e -> pp_arith_expr e
| EString e -> pp_string_expr e
| EList e -> pp_list_expr e
| ESet e -> pp_set_expr e
| EConstr e -> pp_constr_expr e
| ERecord e -> pp_record e
| EProj e -> pp_projection e
| EUpdate e -> pp_update e
| EMap e -> pp_map_expr e
| EVar e -> pp_ident e
| ECall e -> pp_fun_call e
| EBytes e -> pp_bytes e
| EUnit _ -> string "Unit"
| ETuple e -> pp_tuple_expr e
| 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_set_expr = function
SetInj inj -> string "TODO:pp_set_expr:SetInj"
| SetMem mem -> string "TODO:pp_set_expr:SetMem"
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
and pp_map_lookup {value; _} = string "TODO:pp_map_lookup"
and pp_path = function
Name v -> pp_ident v
| Path p -> pp_projection p
and pp_logic_expr = function
BoolExpr e -> pp_bool_expr e
| CompExpr e -> pp_comp_expr e
and pp_bool_expr = function
Or e -> pp_bin_op "||" e
| And e -> pp_bin_op "&&" e
| Not e -> pp_un_op "not" e
| True _ -> string "true"
| False _ -> string "false"
and pp_bin_op op {value; _} =
let {arg1; arg2; _} = value
and length = String.length op + 1 in
pp_expr arg1 ^/^ string (op ^ " ") ^^ nest length (pp_expr arg2)
and pp_un_op op {value; _} =
string (op ^ " ") ^^ pp_expr value.arg
and pp_comp_expr = function
Lt e -> pp_bin_op "<" e
| Leq e -> pp_bin_op "<=" e
| Gt e -> pp_bin_op ">" e
| Geq e -> pp_bin_op ">=" e
| Equal e -> pp_bin_op "=" e
| Neq e -> pp_bin_op "<>" e
and pp_arith_expr = function
Add e -> pp_bin_op "+" e
| Sub e -> pp_bin_op "-" e
| Mult e -> pp_bin_op "*" e
| Div e -> pp_bin_op "/" e
| Mod e -> pp_bin_op "mod" e
| Neg e -> string "-" ^^ pp_expr e.value.arg
| Int e -> pp_int e
| Nat e -> pp_nat e
| Mutez e -> pp_mutez e
and pp_mutez {value; _} =
Z.to_string (snd value) ^ "mutez" |> string
and pp_string_expr = function
Cat e -> pp_bin_op "^" e
| String e -> pp_string e
| Verbatim e -> pp_verbatim e
and pp_ident {value; _} = string value
and pp_string s = string "\"" ^^ pp_ident s ^^ string "\""
and pp_verbatim s = string "{|" ^^ pp_ident s ^^ string "|}"
and pp_list_expr = function
ECons e -> pp_bin_op "#" e
| EListComp e -> group (pp_injection pp_expr e)
| ENil _ -> string "nil"
and pp_constr_expr = function
SomeApp a -> pp_some_app a
| NoneExpr _ -> string "None"
| ConstrApp a -> pp_constr_app a
and pp_some_app {value; _} = string "TODO:pp_some_app"
and pp_constr_app {value; _} = string "TODO:pp_constr_app"
and pp_field_assign {value; _} = string "TODO:pp_field_assign"
and pp_record ne_inj = group (pp_ne_injection pp_field_assign ne_inj)
and pp_projection {value; _} = string "TODO:pp_projection"
and pp_update {value; _} = string "TODO:pp_update"
and pp_field_path_assign {value; _} = string "TODO:pp_field_path_assign"
and pp_selection = function
FieldName _ -> string "TODO:pp_selection:FieldName"
| Component cmp -> cmp.value |> snd |> Z.to_string |> string
and pp_tuple_expr {value; _} = string "TODO:pp_tuple_expr"
and pp_fun_call {value; _} = string "TODO:pp_fun_call"
and pp_arguments v = pp_tuple_expr v
(* Injections *)
and pp_injection :
'a.('a -> document) -> 'a injection reg -> document =
fun printer {value; _} -> string "TODO:pp_injection"
and pp_ne_injection :
'a.('a -> document) -> 'a ne_injection reg -> document =
fun printer {value; _} ->
let {kind; enclosing; ne_elements; _} = value in
let elements = pp_nsepseq ";" printer ne_elements in
let kwd = pp_ne_injection_kwd kind in
let offset = String.length kwd + 2 in
string (kwd ^ " [")
^^ group (nest 2 (break 0 ^^ elements ^^ string "]"))
and pp_ne_injection_kwd = function
NEInjAttr _ -> "attributes"
| NEInjSet _ -> "set"
| NEInjMap _ -> "map"
| NEInjRecord _ -> "record"
and pp_nsepseq :
'a.string ->
('a -> document) ->
('a, t) Utils.nsepseq ->
document =
fun sep printer elements ->
let elems = Utils.nsepseq_to_list elements
and sep = string sep ^^ break 1
in separate_map sep printer elems
(* Patterns *)
and pp_pattern = function
PConstr p -> pp_constr_pattern p
| PVar v -> pp_ident v
| PWild _ -> string "_"
| PInt i -> pp_int i
| PNat n -> pp_nat n
| PBytes b -> pp_bytes b
| PString s -> pp_string s
| PList l -> pp_list_pattern l
| PTuple t -> pp_tuple_pattern t
and pp_int {value; _} =
string (Z.to_string (snd value))
and pp_nat {value; _} =
string (Z.to_string (snd value) ^ "n")
and pp_bytes {value; _} =
string ("0x" ^ Hex.show (snd value))
and pp_constr_pattern = function
PUnit _ -> string "Unit"
| PFalse _ -> string "False"
| PTrue _ -> string "True"
| PNone _ -> string "None"
| PSomeApp a -> pp_psome a
| PConstrApp a -> pp_pconstr_app a
and pp_psome {value=_, p; _} =
prefix 4 1 (string "Some") (pp_par pp_pattern p)
and pp_pconstr_app {value; _} = string "TODO:pp_pconstr_app"
and pp_tuple_pattern {value; _} = string "TODO:tuple_pattern"
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
and pp_list_comp {value; _} = string "TODO:pp_list_comp"
and pp_ppar_cons {value; _} = string "TODO:pp_ppar_cons"
and pp_cons {value; _} = string "TODO:pp_cons"

2
src/passes/1-parser/pascaligo/dune
View File

@ -15,7 +15,7 @@
(name parser_pascaligo)
(public_name ligo.parser.pascaligo)
(modules
Scoping AST pascaligo Parser ParserLog LexToken ParErr)
Scoping AST pascaligo Parser ParserLog LexToken ParErr Pretty)
(libraries
menhirLib
parser_shared

2
src/passes/1-parser/reasonligo.ml
View File

@ -189,7 +189,7 @@ let pretty_print source =
match parse_file source with
Stdlib.Error _ as e -> e
| Ok ast ->
let doc = Pretty.make (fst ast) in
let doc = Pretty.print (fst ast) in
let buffer = Buffer.create 131 in
let width =
match Terminal_size.get_columns () with