From 2d74681c96939202f65c8513215b0a1bfdd52348 Mon Sep 17 00:00:00 2001 From: Christian Rinderknecht Date: Sat, 30 May 2020 20:24:47 +0200 Subject: [PATCH] Added more to the PascaLIGO pretty-printer. Improved the AST of PascaLIGO to better capture the struture. --- src/main/compile/helpers.ml | 4 +- src/passes/1-parser/cameligo.ml | 2 +- src/passes/1-parser/cameligo/ParserMain.ml | 2 +- src/passes/1-parser/cameligo/Pretty.ml | 20 +- src/passes/1-parser/pascaligo/AST.ml | 126 +++--- src/passes/1-parser/pascaligo/Parser.mly | 258 ++++++------ src/passes/1-parser/pascaligo/ParserLog.ml | 177 ++++---- src/passes/1-parser/pascaligo/ParserMain.ml | 18 +- src/passes/1-parser/pascaligo/Pretty.ml | 425 ++++++++++++++++++++ src/passes/1-parser/pascaligo/dune | 2 +- src/passes/1-parser/reasonligo.ml | 2 +- 11 files changed, 751 insertions(+), 285 deletions(-) create mode 100644 src/passes/1-parser/pascaligo/Pretty.ml diff --git a/src/main/compile/helpers.ml b/src/main/compile/helpers.ml index 8e35e2887..596b6d277 100644 --- a/src/main/compile/helpers.ml +++ b/src/main/compile/helpers.ml @@ -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 diff --git a/src/passes/1-parser/cameligo.ml b/src/passes/1-parser/cameligo.ml index 9c054400e..7ef89b360 100644 --- a/src/passes/1-parser/cameligo.ml +++ b/src/passes/1-parser/cameligo.ml @@ -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 diff --git a/src/passes/1-parser/cameligo/ParserMain.ml b/src/passes/1-parser/cameligo/ParserMain.ml index 60b89c7c3..47462302d 100644 --- a/src/passes/1-parser/cameligo/ParserMain.ml +++ b/src/passes/1-parser/cameligo/ParserMain.ml @@ -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 diff --git a/src/passes/1-parser/cameligo/Pretty.ml b/src/passes/1-parser/cameligo/Pretty.ml index 6da2c7bf9..4351b7bad 100644 --- a/src/passes/1-parser/cameligo/Pretty.ml +++ b/src/passes/1-parser/cameligo/Pretty.ml @@ -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 diff --git a/src/passes/1-parser/pascaligo/AST.ml b/src/passes/1-parser/pascaligo/AST.ml index 685d5c5dd..1ed609c0f 100644 --- a/src/passes/1-parser/pascaligo/AST.ml +++ b/src/passes/1-parser/pascaligo/AST.ml @@ -106,14 +106,15 @@ type eof = Region.t (* Literals *) -type variable = string reg -type fun_name = string reg -type type_name = string reg -type field_name = string reg -type map_name = string reg -type set_name = string reg -type constr = string reg -type attribute = string reg +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 +type constr = string reg +type attribute = string reg (* Parentheses *) @@ -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 @@ -520,7 +494,7 @@ and logic_expr = and bool_expr = Or of kwd_or bin_op reg | And of kwd_and bin_op reg -| Not of kwd_not un_op reg +| Not of kwd_not un_op reg | False of c_False | True of c_True @@ -544,15 +518,15 @@ and comp_expr = | Neq of neq bin_op reg and arith_expr = - Add of plus bin_op reg -| Sub of minus bin_op reg -| Mult of times bin_op reg -| Div of slash bin_op reg -| Mod of kwd_mod bin_op reg -| Neg of minus un_op reg -| Int of (Lexer.lexeme * Z.t) reg -| Nat of (Lexer.lexeme * Z.t) reg -| Mutez of (Lexer.lexeme * Z.t) reg + Add of plus bin_op reg +| Sub of minus bin_op reg +| Mult of times bin_op reg +| Div of slash bin_op reg +| Mod of kwd_mod bin_op reg +| Neg of minus un_op reg +| Int of (Lexer.lexeme * Z.t) reg +| Nat of (Lexer.lexeme * Z.t) reg +| Mutez of (Lexer.lexeme * Z.t) reg and string_expr = Cat of cat bin_op reg @@ -584,14 +558,14 @@ and projection = { } and update = { - record : path; + record : path; kwd_with : kwd_with; - updates : field_path_assign reg ne_injection reg + updates : field_path_assign reg ne_injection reg } and field_path_assign = { - field_path : (field_name, dot) nsepseq; - equal : equal; + field_path : (field_name, dot) nsepseq; + equal : equal; field_expr : expr } @@ -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 diff --git a/src/passes/1-parser/pascaligo/Parser.mly b/src/passes/1-parser/pascaligo/Parser.mly index 669ee7dbd..753354cfd 100644 --- a/src/passes/1-parser/pascaligo/Parser.mly +++ b/src/passes/1-parser/pascaligo/Parser.mly @@ -122,7 +122,8 @@ attr_decl: open_attr_decl ";"? { $1 } open_attr_decl: - ne_injection("attributes","") { $1 } + ne_injection("attributes","") { + $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,124 +404,122 @@ instruction: set_remove: "remove" expr "from" "set" path { let region = cover $1 (path_to_region $5) in - let value = { - kwd_remove = $1; - element = $2; - kwd_from = $3; - kwd_set = $4; - set = $5} + let value = {kwd_remove = $1; + element = $2; + kwd_from = $3; + kwd_set = $4; + set = $5} in {region; value} } map_remove: "remove" expr "from" "map" path { let region = cover $1 (path_to_region $5) in - let value = { - kwd_remove = $1; - key = $2; - kwd_from = $3; - kwd_map = $4; - map = $5} + let value = {kwd_remove = $1; + key = $2; + kwd_from = $3; + kwd_map = $4; + map = $5} in {region; value} } set_patch: "patch" path "with" ne_injection("set",expr) { - let region = cover $1 $4.region in - let value = { - kwd_patch = $1; - path = $2; - kwd_with = $3; - set_inj = $4} + 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} in {region; value} } map_patch: "patch" path "with" ne_injection("map",binding) { - let region = cover $1 $4.region in - let value = { - kwd_patch = $1; - path = $2; - kwd_with = $3; - map_inj = $4} + 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} in {region; value} } injection(Kind,element): Kind sep_or_term_list(element,";") "end" { - let elements, terminator = $2 in - let region = cover $1 $3 - and value = { - opening = Kwd $1; - elements = Some elements; - terminator; - closing = End $3} - in {region; value} + fun mk_kwd -> + let elements, terminator = $2 in + let region = cover $1 $3 + and value = { + kind = mk_kwd $1; + enclosing = End $3; + elements = Some elements; + terminator} + in {region; value} } | Kind "end" { - let region = cover $1 $2 - and value = { - opening = Kwd $1; - elements = None; - terminator = None; - closing = End $2} - in {region; value} + fun mk_kwd -> + let region = cover $1 $2 + and value = {kind = mk_kwd $1; + enclosing = End $2; + elements = None; + terminator = None} + in {region; value} } | Kind "[" sep_or_term_list(element,";") "]" { - let elements, terminator = $3 in - let region = cover $1 $4 - and value = { - opening = KwdBracket ($1,$2); - elements = Some elements; - terminator; - closing = RBracket $4} - in {region; value} + fun mk_kwd -> + let elements, terminator = $3 in + let region = cover $1 $4 + and value = {kind = mk_kwd $1; + enclosing = Brackets ($2,$4); + elements = Some elements; + terminator} + in {region; value} } | Kind "[" "]" { - let region = cover $1 $3 - and value = { - opening = KwdBracket ($1,$2); - elements = None; - terminator = None; - closing = RBracket $3} - in {region; value} } + fun mk_kwd -> + let region = cover $1 $3 + and value = {kind = mk_kwd $1; + enclosing = Brackets ($2,$3); + elements = None; + terminator = None} + in {region; value} } ne_injection(Kind,element): Kind sep_or_term_list(element,";") "end" { - let ne_elements, terminator = $2 in - let region = cover $1 $3 - and value = { - opening = Kwd $1; - ne_elements; - terminator; - closing = End $3} - in {region; value} + fun mk_kwd -> + let ne_elements, terminator = $2 in + let region = cover $1 $3 + and value = {kind = mk_kwd $1; + enclosing = End $3; + ne_elements; + terminator} + in {region; value} } | Kind "[" sep_or_term_list(element,";") "]" { - let ne_elements, terminator = $3 in - let region = cover $1 $4 - and value = { - opening = KwdBracket ($1,$2); - ne_elements; - terminator; - closing = RBracket $4} - in {region; value} } + fun mk_kwd -> + let ne_elements, terminator = $3 in + let region = cover $1 $4 + and value = {kind = mk_kwd $1; + enclosing = Brackets ($2,$4); + ne_elements; + terminator} + in {region; value} } binding: expr "->" expr { let start = expr_to_region $1 and stop = expr_to_region $3 in let region = cover start stop - and value = { - source = $1; - arrow = $2; - image = $3} + 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; - path = $2; - kwd_with = $3; - record_inj = $4} + 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} 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); - ne_elements; - terminator; - closing = RBracket $4} - in {region; value} } + let ne_elements, terminator = $3 in + let region = cover $1 $4 + and value : field_assign AST.reg ne_injection = { + kind = NEInjRecord $1; + enclosing = Brackets ($2,$4); + ne_elements; + 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,8 +1011,8 @@ arguments: par(nsepseq(expr,",")) { $1 } list_expr: - injection("list",expr) { EListComp $1 } -| "nil" { ENil $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 } diff --git a/src/passes/1-parser/pascaligo/ParserLog.ml b/src/passes/1-parser/pascaligo/ParserLog.ml index eb694f48b..6ae1ca0ac 100644 --- a/src/passes/1-parser/pascaligo/ParserLog.ml +++ b/src/passes/1-parser/pascaligo/ParserLog.ml @@ -27,11 +27,11 @@ let mk_state ~offsets ~mode ~buffer = val pad_node = "" method pad_node = pad_node - (** 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 - of its parent?). + (* 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 + of its parent?). *) method pad arity rank = {< pad_path = @@ -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; - 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" + 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_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_opt state lead_vbar "|"; - print_cases_instr state cases; - print_closing state closing + 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_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_opt state lead_vbar "|"; - print_cases_expr state cases; - print_closing state closing + 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_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; - print_sepseq state ";" print elements; - print_terminator state terminator; - print_closing state closing + '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_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; - print_nsepseq state ";" print ne_elements; - print_terminator state terminator; - print_closing state closing + '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_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 @@ -952,8 +973,8 @@ and pp_type_expr state = function let fields = Utils.nsepseq_to_list value.ne_elements in List.iteri (List.length fields |> apply) fields | TString s -> - pp_node state "TString"; - pp_string (state#pad 1 0) s + pp_node state "TString"; + pp_string (state#pad 1 0) s and pp_cartesian state {value; _} = let apply len rank = diff --git a/src/passes/1-parser/pascaligo/ParserMain.ml b/src/passes/1-parser/pascaligo/ParserMain.ml index f0485222b..65533dc14 100644 --- a/src/passes/1-parser/pascaligo/ParserMain.ml +++ b/src/passes/1-parser/pascaligo/ParserMain.ml @@ -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 diff --git a/src/passes/1-parser/pascaligo/Pretty.ml b/src/passes/1-parser/pascaligo/Pretty.ml new file mode 100644 index 000000000..091ffeeb8 --- /dev/null +++ b/src/passes/1-parser/pascaligo/Pretty.ml @@ -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" diff --git a/src/passes/1-parser/pascaligo/dune b/src/passes/1-parser/pascaligo/dune index ca4865ae9..5aa59af6d 100644 --- a/src/passes/1-parser/pascaligo/dune +++ b/src/passes/1-parser/pascaligo/dune @@ -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 diff --git a/src/passes/1-parser/reasonligo.ml b/src/passes/1-parser/reasonligo.ml index 5a7b1b2f1..0f2f15e95 100644 --- a/src/passes/1-parser/reasonligo.ml +++ b/src/passes/1-parser/reasonligo.ml @@ -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