From 0226b9f23cc24446d4744b5516fb610471630ae3 Mon Sep 17 00:00:00 2001 From: Christian Rinderknecht Date: Fri, 13 Dec 2019 12:21:52 +0100 Subject: [PATCH] Refactoring of comments (for [dune build @doc]). Refactoring of parsing command-line arguments * The type [options] is now abstract and implemented as an object type to avoid struggling with scoping and type inference when record types share some common field names. Refactoring of ParserLog for PascaLIGO and CameLIGO * The immediate motivation behind that refactoring was to remove the use of a couple of global references. A consequence is that we have a nicer and more compact code, by threading a state. The files [pascaligo/Tests/pp.ligo] and [ligodity/Tests/pp.mligo]. * Another consequence is that the choice of making strings from AST nodes depends on the CLI (offsets? mode?). After this refactoring, that choice is hardcoded in the simplifiers in a few places (TODO), waiting for a general solution that would have all CL options flow through the compiler. * I removed the use of vendors [x_option.ml], [x_map.ml] and [x_list.ml] when handling optional values. (Less dependencies this way.) Refactoring of the ASTs * I removed the node [local_decl], which was set to [[]] already in a previous commit (which removed local declarations as being redundant, as statements could already be instructions or declarations). * I changed [StrLit] to [String] in the AST of CameLIGO and ReasonLIGO. * I also changed the type [fun_expr] so now either a block is present, and therefore followed by the [with] keyword, or it is not. (Before, the presence of a block was not enforced in the type with the presence of the keyword.) Notes * [LexerMain.ml] and [ParserMain.ml] for CameLIGO and PascaLIGO are almost identical and differ in the same way (language name and file extension), which suggests that they should be in the [shared] folder and instanciated as a functor in the future (TODO). * I removed the blank characters at the end of many lines in the parser of ReasonLIGO. --- src/passes/1-parser/ligodity/AST.ml | 4 +- src/passes/1-parser/ligodity/AST.mli | 2 +- src/passes/1-parser/ligodity/LexerMain.ml | 41 +- src/passes/1-parser/ligodity/Parser.mly | 2 +- src/passes/1-parser/ligodity/ParserLog.ml | 1365 +++++------ src/passes/1-parser/ligodity/ParserLog.mli | 39 +- src/passes/1-parser/ligodity/ParserMain.ml | 87 +- src/passes/1-parser/ligodity/Tests/pp.mligo | 26 + src/passes/1-parser/pascaligo/.Lexer.ml.tag | 1 - src/passes/1-parser/pascaligo/.links | 3 - src/passes/1-parser/pascaligo/AST.ml | 14 +- src/passes/1-parser/pascaligo/AST.mli | 10 +- src/passes/1-parser/pascaligo/LexerMain.ml | 41 +- src/passes/1-parser/pascaligo/Parser.mly | 31 +- src/passes/1-parser/pascaligo/ParserLog.ml | 2024 ++++++++--------- src/passes/1-parser/pascaligo/ParserLog.mli | 43 +- src/passes/1-parser/pascaligo/ParserMain.ml | 87 +- .../1-parser/pascaligo/Stubs/Simple_utils.ml | 1 - src/passes/1-parser/pascaligo/Tests/pp.ligo | 10 +- src/passes/1-parser/reasonligo/Parser.mly | 346 +-- src/passes/1-parser/shared/EvalOpt.ml | 46 +- src/passes/1-parser/shared/EvalOpt.mli | 80 +- src/passes/1-parser/shared/Lexer.mll | 1 + src/passes/1-parser/shared/LexerLog.ml | 5 +- src/passes/2-simplify/ligodity.ml | 12 +- src/passes/2-simplify/pascaligo.ml | 45 +- 26 files changed, 2215 insertions(+), 2151 deletions(-) create mode 100644 src/passes/1-parser/ligodity/Tests/pp.mligo delete mode 100644 src/passes/1-parser/pascaligo/.Lexer.ml.tag diff --git a/src/passes/1-parser/ligodity/AST.ml b/src/passes/1-parser/ligodity/AST.ml index d45498505..a25d1ef8c 100644 --- a/src/passes/1-parser/ligodity/AST.ml +++ b/src/passes/1-parser/ligodity/AST.ml @@ -268,7 +268,7 @@ and list_expr = and string_expr = Cat of cat bin_op reg -| StrLit of string reg +| String of string reg and constr_expr = ENone of c_None @@ -422,7 +422,7 @@ let arith_expr_to_region = function | Nat {region; _} -> region let string_expr_to_region = function - StrLit {region;_} | Cat {region;_} -> region + String {region;_} | Cat {region;_} -> region let list_expr_to_region = function ECons {region; _} | EListComp {region; _} diff --git a/src/passes/1-parser/ligodity/AST.mli b/src/passes/1-parser/ligodity/AST.mli index 405f5f2f6..1705cfb18 100644 --- a/src/passes/1-parser/ligodity/AST.mli +++ b/src/passes/1-parser/ligodity/AST.mli @@ -256,7 +256,7 @@ and list_expr = and string_expr = Cat of cat bin_op reg (* e1 ^ e2 *) -| StrLit of string reg (* "foo" *) +| String of string reg (* "foo" *) and constr_expr = ENone of c_None diff --git a/src/passes/1-parser/ligodity/LexerMain.ml b/src/passes/1-parser/ligodity/LexerMain.ml index a708432d0..80ae8b00d 100644 --- a/src/passes/1-parser/ligodity/LexerMain.ml +++ b/src/passes/1-parser/ligodity/LexerMain.ml @@ -1,43 +1,40 @@ -(* Driver for the lexer of Ligodity *) +(** Driver for the LIGO lexer *) -(* Error printing and exception tracing *) +let extension = ".mligo" +let options = EvalOpt.read "CameLIGO" extension +(** Error printing and exception tracing +*) let () = Printexc.record_backtrace true -(* Running the lexer on the source *) - -let options = EvalOpt.read "CameLIGO" ".mligo" - -open EvalOpt - let external_ text = Utils.highlight (Printf.sprintf "External error: %s" text); exit 1;; -(* Path for CPP inclusions (#include) *) +(** {1 Preprocessing the input source and opening the input channels} *) +(** Path for CPP inclusions (#include) +*) let lib_path = - match options.libs with + match options#libs with [] -> "" | libs -> let mk_I dir path = Printf.sprintf " -I %s%s" dir path in List.fold_right mk_I libs "" -(* Preprocessing the input source and opening the input channels *) - let prefix = - match options.input with + match options#input with None | Some "-" -> "temp" | Some file -> Filename.(file |> basename |> remove_extension) -let suffix = ".pp.mligo" +let suffix = ".pp" ^ extension let pp_input = - if Utils.String.Set.mem "cpp" options.verbose + if Utils.String.Set.mem "cpp" options#verbose then prefix ^ suffix else let pp_input, pp_out = Filename.open_temp_file prefix suffix in close_out pp_out; pp_input let cpp_cmd = - match options.input with + match options#input with None | Some "-" -> Printf.sprintf "cpp -traditional-cpp%s - > %s" lib_path pp_input @@ -46,16 +43,14 @@ let cpp_cmd = lib_path file pp_input let () = - if Utils.String.Set.mem "cpp" options.verbose + if Utils.String.Set.mem "cpp" options#verbose then Printf.eprintf "%s\n%!" cpp_cmd; if Sys.command cpp_cmd <> 0 then external_ (Printf.sprintf "the command \"%s\" failed." cpp_cmd) -(* Running the lexer on the input file *) +(** {1 Running the lexer on the input file} *) -module Lexer = Lexer.Make (LexToken) +module Log = LexerLog.Make (Lexer.Make (LexToken)) -module Log = LexerLog.Make (Lexer) - -let () = Log.trace ~offsets:options.offsets - options.mode (Some pp_input) options.cmd +let () = Log.trace ~offsets:options#offsets + options#mode (Some pp_input) options#cmd diff --git a/src/passes/1-parser/ligodity/Parser.mly b/src/passes/1-parser/ligodity/Parser.mly index 3ad5f1218..61e4b8599 100644 --- a/src/passes/1-parser/ligodity/Parser.mly +++ b/src/passes/1-parser/ligodity/Parser.mly @@ -690,7 +690,7 @@ core_expr: | Nat { EArith (Nat $1) } | Ident | module_field { EVar $1 } | projection { EProj $1 } -| String { EString (StrLit $1) } +| String { EString (String $1) } | unit { EUnit $1 } | False { ELogic (BoolExpr (False $1)) } | True { ELogic (BoolExpr (True $1)) } diff --git a/src/passes/1-parser/ligodity/ParserLog.ml b/src/passes/1-parser/ligodity/ParserLog.ml index e05d8e7ca..334ee11be 100644 --- a/src/passes/1-parser/ligodity/ParserLog.ml +++ b/src/passes/1-parser/ligodity/ParserLog.ml @@ -3,1014 +3,1055 @@ open AST open! Region -(* Printing the tokens with their source locations *) - let sprintf = Printf.sprintf -let offsets = ref true -let mode = ref `Point +type state = < + offsets : bool; + mode : [`Point | `Byte]; + buffer : Buffer.t; + pad_path : string; + pad_node : string; + pad : int -> int -> state +> -let compact (region: Region.t) = - region#compact ~offsets:!offsets !mode +let mk_state ~offsets ~mode ~buffer = + object + method offsets = offsets; + method mode = mode; + method buffer = buffer + val pad_path = "" + method pad_path = pad_path + val pad_node = "" + method pad_node = pad_node -let print_nsepseq buffer sep print (head,tail) = - let print_aux ((sep_reg:Region.t), item) = - let sep_line = sprintf "%s: %s\n" (compact sep_reg) sep - in Buffer.add_string buffer sep_line; - print buffer item - in print buffer head; List.iter print_aux tail + (** 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 = + pad_node ^ (if rank = arity-1 then "`-- " else "|-- "); + pad_node = + pad_node ^ (if rank = arity-1 then " " else "| ") + >} + end -let print_sepseq buffer sep print = function - None -> () -| Some seq -> print_nsepseq buffer sep print seq +let compact state (region: Region.t) = + region#compact ~offsets:state#offsets state#mode -let print_csv buffer print {value; _} = - print_nsepseq buffer "," print value +(** {1 Printing the tokens with their source regions} *) -let print_token buffer (reg: Region.t) conc = - let line = sprintf "%s: %s\n" (compact reg) conc - in Buffer.add_string buffer line +let print_nsepseq : + state -> string -> (state -> 'a -> unit) -> + ('a, Region.t) Utils.nsepseq -> unit = + fun state sep print (head, tail) -> + let print_aux (sep_reg, item) = + let sep_line = + sprintf "%s: %s\n" (compact state sep_reg) sep in + Buffer.add_string state#buffer sep_line; + print state item + in print state head; List.iter print_aux tail -let print_var buffer Region.{region; value} = - let line = sprintf "%s: Ident %s\n" (compact region) value - in Buffer.add_string buffer line +let print_sepseq : + state -> string -> (state -> 'a -> unit) -> + ('a, Region.t) Utils.sepseq -> unit = + fun state sep print -> function + None -> () + | Some seq -> print_nsepseq state sep print seq -let print_constr buffer {region; value=lexeme} = - let line = sprintf "%s: Constr \"%s\"\n" - (compact region) lexeme - in Buffer.add_string buffer line +let print_csv state print {value; _} = + print_nsepseq state "," print value -let print_pvar buffer Region.{region; value} = - let line = sprintf "%s: PVar %s\n" (compact region) value - in Buffer.add_string buffer line +let print_token state region lexeme = + let line = + sprintf "%s: %s\n" (compact state region) lexeme + in Buffer.add_string state#buffer line -let print_uident buffer Region.{region; value} = - let line = sprintf "%s: Uident %s\n" (compact region) value - in Buffer.add_string buffer line +let print_var state {region; value} = + let line = + sprintf "%s: Ident %s\n" + (compact state region) value + in Buffer.add_string state#buffer line -let print_string buffer Region.{region; value} = - let line = sprintf "%s: StrLit %s\n" (compact region) value - in Buffer.add_string buffer line +let print_constr state {region; value} = + let line = + sprintf "%s: Constr \"%s\"\n" + (compact state region) value + in Buffer.add_string state#buffer line -let print_bytes buffer Region.{region; value=lexeme, abstract} = - let line = sprintf "%s: Bytes (\"%s\", \"0x%s\")\n" - (compact region) lexeme (Hex.to_string abstract) - in Buffer.add_string buffer line +let print_pvar state {region; value} = + let line = + sprintf "%s: PVar %s\n" + (compact state region) value + in Buffer.add_string state#buffer line -let print_int buffer Region.{region; value=lex,z} = - let line = sprintf "Int %s (%s)" lex (Z.to_string z) - in print_token buffer region line +let print_uident state {region; value} = + let line = + sprintf "%s: Uident %s\n" + (compact state region) value + in Buffer.add_string state#buffer line -let print_nat buffer {region; value = lexeme, abstract} = - let line = sprintf "%s: Nat (\"%s\", %s)\n" - (compact region) lexeme - (Z.to_string abstract) - in Buffer.add_string buffer line +let print_string state {region; value} = + let line = + sprintf "%s: String %s\n" + (compact state region) value + in Buffer.add_string state#buffer line -let rec print_tokens buffer {decl;eof} = - Utils.nseq_iter (print_statement buffer) decl; - print_token buffer eof "EOF" +let print_bytes state {region; value} = + let lexeme, abstract = value in + let line = + sprintf "%s: Bytes (\"%s\", \"0x%s\")\n" + (compact state region) lexeme + (Hex.to_string abstract) + in Buffer.add_string state#buffer line -and print_statement buffer = function +let print_int state {region; value} = + let lexeme, abstract = value in + let line = + sprintf "%s: Int (\"%s\", %s)\n" + (compact state region) lexeme + (Z.to_string abstract) + in Buffer.add_string state#buffer line + +let print_nat state {region; value} = + let lexeme, abstract = value in + let line = + sprintf "%s: Nat (\"%s\", %s)\n" + (compact state region) lexeme + (Z.to_string abstract) + in Buffer.add_string state#buffer line + +let rec print_tokens state {decl;eof} = + Utils.nseq_iter (print_statement state) decl; + print_token state eof "EOF" + +and print_statement state = function Let {value=kwd_let, let_binding; _} -> - print_token buffer kwd_let "let"; - print_let_binding buffer let_binding + print_token state kwd_let "let"; + print_let_binding state let_binding | TypeDecl {value={kwd_type; name; eq; type_expr}; _} -> - print_token buffer kwd_type "type"; - print_var buffer name; - print_token buffer eq "="; - print_type_expr buffer type_expr + print_token state kwd_type "type"; + print_var state name; + print_token state eq "="; + print_type_expr state type_expr -and print_type_expr buffer = function - TProd prod -> print_cartesian buffer prod -| TSum {value; _} -> print_nsepseq buffer "|" print_variant value -| TRecord t -> print_rec_type_expr buffer t -| TApp app -> print_type_app buffer app -| TPar par -> print_type_par buffer par -| TVar var -> print_var buffer var -| TFun t -> print_fun_type buffer t +and print_type_expr state = function + TProd prod -> print_cartesian state prod +| TSum {value; _} -> print_nsepseq state "|" print_variant value +| TRecord t -> print_rec_type_expr state t +| TApp app -> print_type_app state app +| TPar par -> print_type_par state par +| TVar var -> print_var state var +| TFun t -> print_fun_type state t -and print_fun_type buffer {value; _} = +and print_fun_type state {value; _} = let domain, arrow, range = value in - print_type_expr buffer domain; - print_token buffer arrow "->"; - print_type_expr buffer range + print_type_expr state domain; + print_token state arrow "->"; + print_type_expr state range -and print_type_app buffer {value; _} = +and print_type_app state {value; _} = let type_constr, type_tuple = value in - print_type_tuple buffer type_tuple; - print_var buffer type_constr + print_type_tuple state type_tuple; + print_var state type_constr -and print_type_tuple buffer {value; _} = +and print_type_tuple state {value; _} = let {lpar; inside; rpar} = value in - print_token buffer lpar "("; - print_nsepseq buffer "," print_type_expr inside; - print_token buffer rpar ")" + print_token state lpar "("; + print_nsepseq state "," print_type_expr inside; + print_token state rpar ")" -and print_type_par buffer {value={lpar;inside=t;rpar}; _} = - print_token buffer lpar "("; - print_type_expr buffer t; - print_token buffer rpar ")" +and print_type_par state {value={lpar;inside=t;rpar}; _} = + print_token state lpar "("; + print_type_expr state t; + print_token state rpar ")" -and print_projection buffer {value; _} = +and print_projection state {value; _} = let {struct_name; selector; field_path} = value in - print_var buffer struct_name; - print_token buffer selector "."; - print_nsepseq buffer "." print_selection field_path + print_var state struct_name; + print_token state selector "."; + print_nsepseq state "." print_selection field_path -and print_selection buffer = function - FieldName id -> print_var buffer id -| Component c -> print_int buffer c +and print_selection state = function + FieldName id -> print_var state id +| Component c -> print_int state c -and print_cartesian buffer Region.{value;_} = - print_nsepseq buffer "*" print_type_expr value +and print_cartesian state Region.{value;_} = + print_nsepseq state "*" print_type_expr value -and print_variant buffer {value = {constr; arg}; _} = - print_uident buffer constr; +and print_variant state {value = {constr; arg}; _} = + print_uident state constr; match arg with None -> () | Some (kwd_of, t_expr) -> - print_token buffer kwd_of "of"; - print_type_expr buffer t_expr + print_token state kwd_of "of"; + print_type_expr state t_expr -and print_rec_type_expr buffer {value; _} = +and print_rec_type_expr state {value; _} = let {compound; ne_elements; terminator} = value in - print_open_compound buffer compound; - print_nsepseq buffer ";" print_field_decl ne_elements; - print_terminator buffer terminator; - print_close_compound buffer compound + print_open_compound state compound; + print_nsepseq state ";" print_field_decl ne_elements; + print_terminator state terminator; + print_close_compound state compound -and print_field_decl buffer {value; _} = +and print_field_decl state {value; _} = let {field_name; colon; field_type} = value - in print_var buffer field_name; - print_token buffer colon ":"; - print_type_expr buffer field_type + in print_var state field_name; + print_token state colon ":"; + print_type_expr state field_type and print_injection : - 'a.Buffer.t -> (Buffer.t -> 'a -> unit) -> 'a injection reg -> unit = - fun buffer print {value; _} -> + 'a.state -> (state -> 'a -> unit) -> 'a injection reg -> unit = + fun state print {value; _} -> let {compound; elements; terminator} = value in - print_open_compound buffer compound; - print_sepseq buffer ";" print elements; - print_terminator buffer terminator; - print_close_compound buffer compound + print_open_compound state compound; + print_sepseq state ";" print elements; + print_terminator state terminator; + print_close_compound state compound and print_ne_injection : - 'a.Buffer.t -> (Buffer.t -> 'a -> unit) -> 'a ne_injection reg -> unit = - fun buffer print {value; _} -> + 'a.state -> (state -> 'a -> unit) -> 'a ne_injection reg -> unit = + fun state print {value; _} -> let {compound; ne_elements; terminator} = value in - print_open_compound buffer compound; - print_nsepseq buffer ";" print ne_elements; - print_terminator buffer terminator; - print_close_compound buffer compound + print_open_compound state compound; + print_nsepseq state ";" print ne_elements; + print_terminator state terminator; + print_close_compound state compound -and print_open_compound buffer = function - BeginEnd (kwd_begin,_) -> print_token buffer kwd_begin "begin" -| Braces (lbrace,_) -> print_token buffer lbrace "{" -| Brackets (lbracket,_) -> print_token buffer lbracket "[" +and print_open_compound state = function + BeginEnd (kwd_begin,_) -> print_token state kwd_begin "begin" +| Braces (lbrace,_) -> print_token state lbrace "{" +| Brackets (lbracket,_) -> print_token state lbracket "[" -and print_close_compound buffer = function - BeginEnd (_,kwd_end) -> print_token buffer kwd_end "end" -| Braces (_,rbrace) -> print_token buffer rbrace "}" -| Brackets (_,rbracket) -> print_token buffer rbracket "]" +and print_close_compound state = function + BeginEnd (_,kwd_end) -> print_token state kwd_end "end" +| Braces (_,rbrace) -> print_token state rbrace "}" +| Brackets (_,rbracket) -> print_token state rbracket "]" -and print_terminator buffer = function - Some semi -> print_token buffer semi ";" +and print_terminator state = function + Some semi -> print_token state semi ";" | None -> () -and print_let_binding buffer {binders; lhs_type; eq; let_rhs} = - let () = Utils.nseq_iter (print_pattern buffer) binders in +and print_let_binding state {binders; lhs_type; eq; let_rhs} = + let () = Utils.nseq_iter (print_pattern state) binders in let () = match lhs_type with None -> () | Some (colon, type_expr) -> - print_token buffer colon ":"; - print_type_expr buffer type_expr in - let () = print_token buffer eq "=" - in print_expr buffer let_rhs + print_token state colon ":"; + print_type_expr state type_expr in + let () = print_token state eq "=" + in print_expr state let_rhs -and print_pattern buffer = function +and print_pattern state = function PTuple ptuple -> - print_csv buffer print_pattern ptuple + print_csv state print_pattern ptuple | PList p -> - print_list_pattern buffer p + print_list_pattern state p | PVar v -> - print_pvar buffer v -| PInt i -> print_int buffer i -| PNat i -> print_nat buffer i -| PBytes b -> print_bytes buffer b -| PString s -> print_string buffer s -| PWild wild -> print_token buffer wild "_" + print_pvar state v +| PInt i -> print_int state i +| PNat i -> print_nat state i +| PBytes b -> print_bytes state b +| PString s -> print_string state s +| PWild wild -> print_token state wild "_" | PPar {value={lpar;inside=p;rpar}; _} -> - print_token buffer lpar "("; - print_pattern buffer p; - print_token buffer rpar ")" + print_token state lpar "("; + print_pattern state p; + print_token state rpar ")" | PConstr p -> - print_constr_pattern buffer p + print_constr_pattern state p | PRecord r -> - print_record_pattern buffer r + print_record_pattern state r | PTyped t -> - print_typed_pattern buffer t -| PUnit p -> print_unit buffer p -| PFalse kwd_false -> print_token buffer kwd_false "false" -| PTrue kwd_true -> print_token buffer kwd_true "true" + print_typed_pattern state t +| PUnit p -> print_unit state p +| PFalse kwd_false -> print_token state kwd_false "false" +| PTrue kwd_true -> print_token state kwd_true "true" -and print_list_pattern buffer = function - PListComp p -> print_injection buffer print_pattern p -| PCons p -> print_raw buffer p +and print_list_pattern state = function + PListComp p -> print_injection state print_pattern p +| PCons p -> print_raw state p -and print_raw buffer {value=p1,c,p2; _} = - print_pattern buffer p1; - print_token buffer c "::"; - print_pattern buffer p2 +and print_raw state {value=p1,c,p2; _} = + print_pattern state p1; + print_token state c "::"; + print_pattern state p2 -and print_typed_pattern buffer {value; _} = +and print_typed_pattern state {value; _} = let {pattern; colon; type_expr} = value in - print_pattern buffer pattern; - print_token buffer colon ":"; - print_type_expr buffer type_expr + print_pattern state pattern; + print_token state colon ":"; + print_type_expr state type_expr -and print_record_pattern buffer record_pattern = - print_ne_injection buffer print_field_pattern record_pattern +and print_record_pattern state record_pattern = + print_ne_injection state print_field_pattern record_pattern -and print_field_pattern buffer {value; _} = +and print_field_pattern state {value; _} = let {field_name; eq; pattern} = value in - print_var buffer field_name; - print_token buffer eq "="; - print_pattern buffer pattern + print_var state field_name; + print_token state eq "="; + print_pattern state pattern -and print_constr_pattern buffer = function - PNone p -> print_none_pattern buffer p -| PSomeApp p -> print_some_app_pattern buffer p -| PConstrApp p -> print_constr_app_pattern buffer p +and print_constr_pattern state = function + PNone p -> print_none_pattern state p +| PSomeApp p -> print_some_app_pattern state p +| PConstrApp p -> print_constr_app_pattern state p -and print_none_pattern buffer value = - print_token buffer value "None" +and print_none_pattern state value = + print_token state value "None" -and print_some_app_pattern buffer {value; _} = +and print_some_app_pattern state {value; _} = let c_Some, argument = value in - print_token buffer c_Some "Some"; - print_pattern buffer argument + print_token state c_Some "Some"; + print_pattern state argument -and print_constr_app_pattern buffer node = +and print_constr_app_pattern state node = let {value=constr, p_opt; _} = node in - print_uident buffer constr; + print_uident state constr; match p_opt with None -> () - | Some pattern -> print_pattern buffer pattern + | Some pattern -> print_pattern state pattern -and print_expr buffer = function - ELetIn let_in -> print_let_in buffer let_in -| ECond cond -> print_conditional buffer cond -| ETuple tuple -> print_csv buffer print_expr tuple -| ECase case -> print_match_expr buffer case -| EFun e -> print_fun_expr buffer e -| EAnnot e -> print_annot_expr buffer e -| ELogic e -> print_logic_expr buffer e -| EArith e -> print_arith_expr buffer e -| EString e -> print_string_expr buffer e -| ECall e -> print_fun_call buffer e -| EVar v -> print_var buffer v -| EProj p -> print_projection buffer p -| EUnit e -> print_unit buffer e -| EBytes b -> print_bytes buffer b -| EPar e -> print_expr_par buffer e -| EList e -> print_list_expr buffer e -| ESeq seq -> print_sequence buffer seq -| ERecord e -> print_record_expr buffer e -| EConstr e -> print_constr_expr buffer e +and print_expr state = function + ELetIn let_in -> print_let_in state let_in +| ECond cond -> print_conditional state cond +| ETuple tuple -> print_csv state print_expr tuple +| ECase case -> print_match_expr state case +| EFun e -> print_fun_expr state e +| EAnnot e -> print_annot_expr state e +| ELogic e -> print_logic_expr state e +| EArith e -> print_arith_expr state e +| EString e -> print_string_expr state e +| ECall e -> print_fun_call state e +| EVar v -> print_var state v +| EProj p -> print_projection state p +| EUnit e -> print_unit state e +| EBytes b -> print_bytes state b +| EPar e -> print_expr_par state e +| EList e -> print_list_expr state e +| ESeq seq -> print_sequence state seq +| ERecord e -> print_record_expr state e +| EConstr e -> print_constr_expr state e -and print_constr_expr buffer = function - ENone e -> print_none_expr buffer e -| ESomeApp e -> print_some_app_expr buffer e -| EConstrApp e -> print_constr_app_expr buffer e +and print_constr_expr state = function + ENone e -> print_none_expr state e +| ESomeApp e -> print_some_app_expr state e +| EConstrApp e -> print_constr_app_expr state e -and print_none_expr buffer value = print_token buffer value "None" +and print_none_expr state value = print_token state value "None" -and print_some_app_expr buffer {value; _} = +and print_some_app_expr state {value; _} = let c_Some, argument = value in - print_token buffer c_Some "Some"; - print_expr buffer argument + print_token state c_Some "Some"; + print_expr state argument -and print_constr_app_expr buffer {value; _} = +and print_constr_app_expr state {value; _} = let constr, argument = value in - print_constr buffer constr; + print_constr state constr; match argument with None -> () - | Some arg -> print_expr buffer arg + | Some arg -> print_expr state arg -and print_expr_par buffer {value; _} = +and print_expr_par state {value; _} = let {lpar;inside=e;rpar} = value in - print_token buffer lpar "("; - print_expr buffer e; - print_token buffer rpar ")" + print_token state lpar "("; + print_expr state e; + print_token state rpar ")" -and print_unit buffer {value=lpar,rpar; _} = - print_token buffer lpar "("; - print_token buffer rpar ")" +and print_unit state {value=lpar,rpar; _} = + print_token state lpar "("; + print_token state rpar ")" -and print_fun_call buffer {value=f,l; _} = - print_expr buffer f; - Utils.nseq_iter (print_expr buffer) l +and print_fun_call state {value=f,l; _} = + print_expr state f; + Utils.nseq_iter (print_expr state) l -and print_annot_expr buffer {value=e,t; _} = - print_expr buffer e; - print_token buffer Region.ghost ":"; - print_type_expr buffer t +and print_annot_expr state {value=e,t; _} = + print_expr state e; + print_token state Region.ghost ":"; + print_type_expr state t -and print_list_expr buffer = function +and print_list_expr state = function ECons {value={arg1;op;arg2}; _} -> - print_expr buffer arg1; - print_token buffer op "::"; - print_expr buffer arg2 + print_expr state arg1; + print_token state op "::"; + print_expr state arg2 | EListComp e -> if e.value.elements = None - then print_token buffer e.region "[]" - else print_injection buffer print_expr e + then print_token state e.region "[]" + else print_injection state print_expr e (* | Append {value=e1,append,e2; _} -> - print_expr buffer e1; - print_token buffer append "@"; - print_expr buffer e2 + print_expr state e1; + print_token state append "@"; + print_expr state e2 *) -and print_arith_expr buffer = function +and print_arith_expr state = function Add {value={arg1;op;arg2}; _} -> - print_expr buffer arg1; - print_token buffer op "+"; - print_expr buffer arg2 + print_expr state arg1; + print_token state op "+"; + print_expr state arg2 | Sub {value={arg1;op;arg2}; _} -> - print_expr buffer arg1; - print_token buffer op "-"; - print_expr buffer arg2 + print_expr state arg1; + print_token state op "-"; + print_expr state arg2 | Mult {value={arg1;op;arg2}; _} -> - print_expr buffer arg1; - print_token buffer op "*"; - print_expr buffer arg2 + print_expr state arg1; + print_token state op "*"; + print_expr state arg2 | Div {value={arg1;op;arg2}; _} -> - print_expr buffer arg1; - print_token buffer op "/"; - print_expr buffer arg2 + print_expr state arg1; + print_token state op "/"; + print_expr state arg2 | Mod {value={arg1;op;arg2}; _} -> - print_expr buffer arg1; - print_token buffer op "mod"; - print_expr buffer arg2 + print_expr state arg1; + print_token state op "mod"; + print_expr state arg2 | Neg {value={op;arg}; _} -> - print_token buffer op "-"; - print_expr buffer arg + print_token state op "-"; + print_expr state arg | Int {region; value=lex,z} -> let line = sprintf "Int %s (%s)" lex (Z.to_string z) - in print_token buffer region line + in print_token state region line | Mutez {region; value=lex,z} -> let line = sprintf "Mutez %s (%s)" lex (Z.to_string z) - in print_token buffer region line + in print_token state region line | Nat {region; value=lex,z} -> let line = sprintf "Nat %s (%s)" lex (Z.to_string z) - in print_token buffer region line + in print_token state region line -and print_string_expr buffer = function +and print_string_expr state = function Cat {value={arg1;op;arg2}; _} -> - print_expr buffer arg1; - print_token buffer op "^"; - print_expr buffer arg2 -| StrLit s -> - print_string buffer s + print_expr state arg1; + print_token state op "^"; + print_expr state arg2 +| String s -> + print_string state s -and print_logic_expr buffer = function - BoolExpr e -> print_bool_expr buffer e -| CompExpr e -> print_comp_expr buffer e +and print_logic_expr state = function + BoolExpr e -> print_bool_expr state e +| CompExpr e -> print_comp_expr state e -and print_bool_expr buffer = function +and print_bool_expr state = function Or {value={arg1;op;arg2}; _} -> - print_expr buffer arg1; - print_token buffer op "||"; - print_expr buffer arg2 + print_expr state arg1; + print_token state op "||"; + print_expr state arg2 | And {value={arg1;op;arg2}; _} -> - print_expr buffer arg1; - print_token buffer op "&&"; - print_expr buffer arg2 + print_expr state arg1; + print_token state op "&&"; + print_expr state arg2 | Not {value={op;arg}; _} -> - print_token buffer op "not"; - print_expr buffer arg + print_token state op "not"; + print_expr state arg | True kwd_true -> - print_token buffer kwd_true "true" + print_token state kwd_true "true" | False kwd_false -> - print_token buffer kwd_false "false" + print_token state kwd_false "false" -and print_comp_expr buffer = function +and print_comp_expr state = function Lt {value={arg1;op;arg2}; _} -> - print_expr buffer arg1; - print_token buffer op "<"; - print_expr buffer arg2 + print_expr state arg1; + print_token state op "<"; + print_expr state arg2 | Leq {value={arg1;op;arg2}; _} -> - print_expr buffer arg1; - print_token buffer op "<="; - print_expr buffer arg2 + print_expr state arg1; + print_token state op "<="; + print_expr state arg2 | Gt {value={arg1;op;arg2}; _} -> - print_expr buffer arg1; - print_token buffer op ">"; - print_expr buffer arg2 + print_expr state arg1; + print_token state op ">"; + print_expr state arg2 | Geq {value={arg1;op;arg2}; _} -> - print_expr buffer arg1; - print_token buffer op ">="; - print_expr buffer arg2 + print_expr state arg1; + print_token state op ">="; + print_expr state arg2 | Neq {value={arg1;op;arg2}; _} -> - print_expr buffer arg1; - print_token buffer op "<>"; - print_expr buffer arg2 + print_expr state arg1; + print_token state op "<>"; + print_expr state arg2 | Equal {value={arg1;op;arg2}; _} -> - print_expr buffer arg1; - print_token buffer op "="; - print_expr buffer arg2 + print_expr state arg1; + print_token state op "="; + print_expr state arg2 -and print_record_expr buffer e = - print_ne_injection buffer print_field_assign e +and print_record_expr state e = + print_ne_injection state print_field_assign e -and print_field_assign buffer {value; _} = +and print_field_assign state {value; _} = let {field_name; assignment; field_expr} = value in - print_var buffer field_name; - print_token buffer assignment "="; - print_expr buffer field_expr + print_var state field_name; + print_token state assignment "="; + print_expr state field_expr -and print_sequence buffer seq = - print_injection buffer print_expr seq +and print_sequence state seq = + print_injection state print_expr seq -and print_match_expr buffer {value; _} = +and print_match_expr state {value; _} = let {kwd_match; expr; kwd_with; lead_vbar; cases} = value in - print_token buffer kwd_match "match"; - print_expr buffer expr; - print_token buffer kwd_with "with"; - print_token_opt buffer lead_vbar "|"; - print_cases buffer cases + print_token state kwd_match "match"; + print_expr state expr; + print_token state kwd_with "with"; + print_token_opt state lead_vbar "|"; + print_cases state cases -and print_token_opt buffer = function +and print_token_opt state = function None -> fun _ -> () -| Some region -> print_token buffer region +| Some region -> print_token state region -and print_cases buffer {value; _} = - print_nsepseq buffer "|" print_case_clause value +and print_cases state {value; _} = + print_nsepseq state "|" print_case_clause value -and print_case_clause buffer {value; _} = +and print_case_clause state {value; _} = let {pattern; arrow; rhs} = value in - print_pattern buffer pattern; - print_token buffer arrow "->"; - print_expr buffer rhs + print_pattern state pattern; + print_token state arrow "->"; + print_expr state rhs -and print_let_in buffer {value; _} = +and print_let_in state {value; _} = let {kwd_let; binding; kwd_in; body} = value in - print_token buffer kwd_let "let"; - print_let_binding buffer binding; - print_token buffer kwd_in "in"; - print_expr buffer body + print_token state kwd_let "let"; + print_let_binding state binding; + print_token state kwd_in "in"; + print_expr state body -and print_fun_expr buffer {value; _} = +and print_fun_expr state {value; _} = let {kwd_fun; binders; lhs_type; arrow; body} = value in - let () = print_token buffer kwd_fun "fun" in - let () = Utils.nseq_iter (print_pattern buffer) binders in + let () = print_token state kwd_fun "fun" in + let () = Utils.nseq_iter (print_pattern state) binders in let () = match lhs_type with None -> () | Some (colon, type_expr) -> - print_token buffer colon ":"; - print_type_expr buffer type_expr in + print_token state colon ":"; + print_type_expr state type_expr in let () = - print_token buffer arrow "->" - in print_expr buffer body + print_token state arrow "->" + in print_expr state body -and print_conditional buffer {value; _} = +and print_conditional state {value; _} = let {kwd_if; test; kwd_then; ifso; kwd_else; ifnot} = value in - print_token buffer ghost "("; - print_token buffer kwd_if "if"; - print_expr buffer test; - print_token buffer kwd_then "then"; - print_expr buffer ifso; - print_token buffer kwd_else "else"; - print_expr buffer ifnot; - print_token buffer ghost ")" + print_token state ghost "("; + print_token state kwd_if "if"; + print_expr state test; + print_token state kwd_then "then"; + print_expr state ifso; + print_token state kwd_else "else"; + print_expr state ifnot; + print_token state ghost ")" (* Conversion to string *) -let to_string printer node = +let to_string ~offsets ~mode printer node = let buffer = Buffer.create 131 in - printer buffer node; - Buffer.contents buffer + let state = mk_state ~offsets ~mode ~buffer in + let () = printer state node + in Buffer.contents buffer -let tokens_to_string = to_string print_tokens -let pattern_to_string = to_string print_pattern -let expr_to_string = to_string print_expr +let tokens_to_string ~offsets ~mode = + to_string ~offsets ~mode print_tokens +let pattern_to_string ~offsets ~mode = + to_string ~offsets ~mode print_pattern +let expr_to_string ~offsets ~mode = + to_string ~offsets ~mode print_expr -(* Pretty-printing the AST *) +(** {1 Pretty-printing the AST} *) -let mk_pad len rank pc = - pc ^ (if rank = len-1 then "`-- " else "|-- "), - pc ^ (if rank = len-1 then " " else "| ") +let pp_ident state {value=name; region} = + let reg = compact state region in + let node = sprintf "%s%s (%s)\n" state#pad_path name reg + in Buffer.add_string state#buffer node -let pp_ident buffer ~pad:(pd,_) Region.{value=name; region} = - let node = sprintf "%s%s (%s)\n" pd name (region#compact `Byte) - in Buffer.add_string buffer node +let pp_node state name = + let node = sprintf "%s%s\n" state#pad_path name + in Buffer.add_string state#buffer node -let pp_node buffer ~pad:(pd,_) name = - let node = sprintf "%s%s\n" pd name - in Buffer.add_string buffer node +let pp_string state = pp_ident state -let pp_string buffer = pp_ident buffer +let pp_loc_node state name region = + pp_ident state {value=name; region} -let pp_loc_node buffer ~pad name region = - pp_ident buffer ~pad Region.{value=name; region} - -let rec pp_ast buffer ~pad:(_,pc as pad) {decl; _} = +let rec pp_ast state {decl; _} = let apply len rank = - let pad = mk_pad len rank pc in - pp_declaration buffer ~pad in + pp_declaration (state#pad len rank) in let decls = Utils.nseq_to_list decl in - pp_node buffer ~pad ""; + pp_node state ""; List.iteri (List.length decls |> apply) decls -and pp_declaration buffer ~pad = function +and pp_declaration state = function Let {value; region} -> - pp_loc_node buffer ~pad "Let" region; - pp_let_binding buffer ~pad (snd value) + pp_loc_node state "Let" region; + pp_let_binding state (snd value) | TypeDecl {value; region} -> - pp_loc_node buffer ~pad "TypeDecl" region; - pp_type_decl buffer ~pad value + pp_loc_node state "TypeDecl" region; + pp_type_decl state value -and pp_let_binding buffer ~pad:(_,pc) node = +and pp_let_binding state node = let {binders; lhs_type; let_rhs; _} = node in let fields = if lhs_type = None then 2 else 3 in let () = - let pad = mk_pad fields 0 pc in - pp_node buffer ~pad ""; - pp_binders buffer ~pad binders in + let state = state#pad fields 0 in + pp_node state ""; + pp_binders state binders in let () = match lhs_type with None -> () | Some (_, type_expr) -> - let _, pc as pad = mk_pad fields 1 pc in - pp_node buffer ~pad ""; - pp_type_expr buffer ~pad:(mk_pad 1 0 pc) type_expr in + let state = state#pad fields 1 in + pp_node state ""; + pp_type_expr (state#pad 1 0) type_expr in let () = - let _, pc as pad = mk_pad fields (fields - 1) pc in - pp_node buffer ~pad ""; - pp_expr buffer ~pad:(mk_pad 1 0 pc) let_rhs + let state = state#pad fields (fields - 1) in + pp_node state ""; + pp_expr (state#pad 1 0) let_rhs in () -and pp_type_decl buffer ~pad:(_,pc) decl = - pp_ident buffer ~pad:(mk_pad 2 0 pc) decl.name; - pp_type_expr buffer ~pad:(mk_pad 2 1 pc) decl.type_expr +and pp_type_decl state decl = + pp_ident (state#pad 2 0) decl.name; + pp_type_expr (state#pad 2 1) decl.type_expr -and pp_binders buffer ~pad:(_,pc) patterns = - let patterns = Utils.nseq_to_list patterns in - let arity = List.length patterns in - let apply len rank = - pp_pattern buffer ~pad:(mk_pad len rank pc) +and pp_binders state patterns = + let patterns = Utils.nseq_to_list patterns in + let arity = List.length patterns in + let apply len rank = pp_pattern (state#pad len rank) in List.iteri (apply arity) patterns -and pp_pattern buffer ~pad:(_,pc as pad) = function +and pp_pattern state = function PConstr p -> - pp_node buffer ~pad "PConstr"; - pp_constr_pattern buffer ~pad:(mk_pad 1 0 pc) p + pp_node state "PConstr"; + pp_constr_pattern (state#pad 1 0) p | PVar v -> - pp_node buffer ~pad "PVar"; - pp_ident buffer ~pad:(mk_pad 1 0 pc) v + pp_node state "PVar"; + pp_ident (state#pad 1 0) v | PWild region -> - pp_loc_node buffer ~pad "PWild" region + pp_loc_node state "PWild" region | PInt i -> - pp_node buffer ~pad "PInt"; - pp_int buffer ~pad i + pp_node state "PInt"; + pp_int state i | PNat n -> - pp_node buffer ~pad "PNat"; - pp_int buffer ~pad n + pp_node state "PNat"; + pp_int state n | PBytes b -> - pp_node buffer ~pad "PBytes"; - pp_bytes buffer ~pad b + pp_node state "PBytes"; + pp_bytes state b | PString s -> - pp_node buffer ~pad "PString"; - pp_string buffer ~pad:(mk_pad 1 0 pc) s + pp_node state "PString"; + pp_string (state#pad 1 0) s | PUnit {region; _} -> - pp_loc_node buffer ~pad "PUnit" region + pp_loc_node state "PUnit" region | PFalse region -> - pp_loc_node buffer ~pad "PFalse" region + pp_loc_node state "PFalse" region | PTrue region -> - pp_loc_node buffer ~pad "PTrue" region + pp_loc_node state "PTrue" region | PList plist -> - pp_node buffer ~pad "PList"; - pp_list_pattern buffer ~pad:(mk_pad 1 0 pc) plist + pp_node state "PList"; + pp_list_pattern (state#pad 1 0) plist | PTuple t -> - pp_loc_node buffer ~pad "PTuple" t.region; - pp_tuple_pattern buffer ~pad:(mk_pad 1 0 pc) t.value + pp_loc_node state "PTuple" t.region; + pp_tuple_pattern (state#pad 1 0) t.value | PPar {value; _} -> - pp_node buffer ~pad "PPar"; - pp_pattern buffer ~pad:(mk_pad 1 0 pc) value.inside + pp_node state "PPar"; + pp_pattern (state#pad 1 0) value.inside | PRecord {value; _} -> - pp_node buffer ~pad "PRecord"; - pp_ne_injection pp_field_pattern buffer ~pad value + pp_node state "PRecord"; + pp_ne_injection pp_field_pattern state value | PTyped {value; _} -> - pp_node buffer ~pad "PTyped"; - pp_typed_pattern buffer ~pad value + pp_node state "PTyped"; + pp_typed_pattern state value -and pp_field_pattern buffer ~pad:(_,pc as pad) {value; _} = - pp_node buffer ~pad value.field_name.value; - pp_pattern buffer ~pad:(mk_pad 1 0 pc) value.pattern +and pp_field_pattern state {value; _} = + pp_node state value.field_name.value; + pp_pattern (state#pad 1 0) value.pattern -and pp_typed_pattern buffer ~pad:(_,pc) node = - pp_pattern buffer ~pad:(mk_pad 2 0 pc) node.pattern; - pp_type_expr buffer ~pad:(mk_pad 2 1 pc) node.type_expr +and pp_typed_pattern state node = + pp_pattern (state#pad 2 0) node.pattern; + pp_type_expr (state#pad 2 1) node.type_expr -and pp_tuple_pattern buffer ~pad:(_,pc) tuple = - let patterns = Utils.nsepseq_to_list tuple in - let length = List.length patterns in - let apply len rank = - pp_pattern buffer ~pad:(mk_pad len rank pc) +and pp_tuple_pattern state tuple = + let patterns = Utils.nsepseq_to_list tuple in + let length = List.length patterns in + let apply len rank = pp_pattern (state#pad len rank) in List.iteri (apply length) patterns -and pp_list_pattern buffer ~pad:(_,pc as pad) = function +and pp_list_pattern state = function PCons {value; region} -> let pat1, _, pat2 = value in - pp_loc_node buffer ~pad "PCons" region; - pp_pattern buffer ~pad:(mk_pad 2 0 pc) pat1; - pp_pattern buffer ~pad:(mk_pad 2 1 pc) pat2 + pp_loc_node state "PCons" region; + pp_pattern (state#pad 2 0) pat1; + pp_pattern (state#pad 2 1) pat2 | PListComp {value; region} -> - pp_loc_node buffer ~pad "PListComp" region; + pp_loc_node state "PListComp" region; if value.elements = None - then pp_node buffer ~pad:(mk_pad 1 0 pc) "" - else pp_injection pp_pattern buffer ~pad value + then pp_node (state#pad 1 0) "" + else pp_injection pp_pattern state value and pp_injection : - 'a.(Buffer.t -> pad:(string*string) -> 'a -> unit) - -> Buffer.t -> pad:(string*string) -> 'a injection -> unit = - fun printer buffer ~pad:(_,pc) inj -> - let elements = Utils.sepseq_to_list inj.elements in - let length = List.length elements in - let apply len rank = printer buffer ~pad:(mk_pad len rank pc) + 'a.(state -> 'a -> unit) -> state -> 'a injection -> unit = + fun printer state inj -> + let elements = Utils.sepseq_to_list inj.elements in + let length = List.length elements in + let apply len rank = printer (state#pad len rank) in List.iteri (apply length) elements and pp_ne_injection : - 'a.(Buffer.t -> pad:(string*string) -> 'a -> unit) - -> Buffer.t -> pad:(string*string) -> 'a ne_injection -> unit = - fun printer buffer ~pad:(_,pc) inj -> - let ne_elements = Utils.nsepseq_to_list inj.ne_elements in - let length = List.length ne_elements in - let apply len rank = printer buffer ~pad:(mk_pad len rank pc) + 'a.(state -> 'a -> unit) -> state -> 'a ne_injection -> unit = + fun printer state inj -> + let ne_elements = Utils.nsepseq_to_list inj.ne_elements in + let length = List.length ne_elements in + let apply len rank = printer (state#pad len rank) in List.iteri (apply length) ne_elements -and pp_bytes buffer ~pad:(_,pc) {value=lexeme,hex; region} = - pp_loc_node buffer ~pad:(mk_pad 2 0 pc) lexeme region; - pp_node buffer ~pad:(mk_pad 2 1 pc) (Hex.to_string hex) +and pp_bytes state {value=lexeme,hex; region} = + pp_loc_node (state#pad 2 0) lexeme region; + pp_node (state#pad 2 1) (Hex.to_string hex) -and pp_int buffer ~pad:(_,pc) {value=lexeme,z; region} = - pp_loc_node buffer ~pad:(mk_pad 2 0 pc) lexeme region; - pp_node buffer ~pad:(mk_pad 2 1 pc) (Z.to_string z) +and pp_int state {value=lexeme,z; region} = + pp_loc_node (state#pad 2 0) lexeme region; + pp_node (state#pad 2 1) (Z.to_string z) -and pp_constr_pattern buffer ~pad:(_,pc as pad) = function +and pp_constr_pattern state = function PNone region -> - pp_loc_node buffer ~pad "PNone" region + pp_loc_node state "PNone" region | PSomeApp {value=_,param; region} -> - pp_loc_node buffer ~pad "PSomeApp" region; - pp_pattern buffer ~pad:(mk_pad 1 0 pc) param + pp_loc_node state "PSomeApp" region; + pp_pattern (state#pad 1 0) param | PConstrApp {value; region} -> - pp_loc_node buffer ~pad "PConstrApp" region; - pp_constr_app_pattern buffer ~pad:(mk_pad 1 0 pc) value + pp_loc_node state "PConstrApp" region; + pp_constr_app_pattern (state#pad 1 0) value -and pp_constr_app_pattern buffer ~pad (constr, pat_opt) = - pp_ident buffer ~pad constr; +and pp_constr_app_pattern state (constr, pat_opt) = + pp_ident state constr; match pat_opt with None -> () - | Some pat -> pp_pattern buffer ~pad pat + | Some pat -> pp_pattern state pat -and pp_expr buffer ~pad:(_,pc as pad) = function +and pp_expr state = function ECase {value; region} -> - pp_loc_node buffer ~pad "ECase" region; - pp_case pp_expr buffer ~pad value + pp_loc_node state "ECase" region; + pp_case pp_expr state value | ECond {value; region} -> - pp_loc_node buffer ~pad "ECond" region; - pp_cond_expr buffer ~pad value + pp_loc_node state "ECond" region; + pp_cond_expr state value | EAnnot {value; region} -> - pp_loc_node buffer ~pad "EAnnot" region; - pp_annotated buffer ~pad value + pp_loc_node state "EAnnot" region; + pp_annotated state value | ELogic e_logic -> - pp_node buffer ~pad "ELogic"; - pp_e_logic buffer ~pad:(mk_pad 1 0 pc) e_logic + pp_node state "ELogic"; + pp_e_logic (state#pad 1 0) e_logic | EArith e_arith -> - pp_node buffer ~pad "EArith"; - pp_arith_expr buffer ~pad:(mk_pad 1 0 pc) e_arith + pp_node state "EArith"; + pp_arith_expr (state#pad 1 0) e_arith | EString e_string -> - pp_node buffer ~pad "EString"; - pp_string_expr buffer ~pad:(mk_pad 1 0 pc) e_string + pp_node state "EString"; + pp_string_expr (state#pad 1 0) e_string | EList e_list -> - pp_node buffer ~pad "EList"; - pp_list_expr buffer ~pad:(mk_pad 1 0 pc) e_list + pp_node state "EList"; + pp_list_expr (state#pad 1 0) e_list | EConstr e_constr -> - pp_node buffer ~pad "EConstr"; - pp_constr_expr buffer ~pad:(mk_pad 1 0 pc) e_constr + pp_node state "EConstr"; + pp_constr_expr (state#pad 1 0) e_constr | ERecord {value; region} -> - pp_loc_node buffer ~pad "ERecord" region; - pp_ne_injection pp_field_assign buffer ~pad value + pp_loc_node state "ERecord" region; + pp_ne_injection pp_field_assign state value | EProj {value; region} -> - pp_loc_node buffer ~pad "EProj" region; - pp_projection buffer ~pad value + pp_loc_node state "EProj" region; + pp_projection state value | EVar v -> - pp_node buffer ~pad "EVar"; - pp_ident buffer ~pad:(mk_pad 1 0 pc) v + pp_node state "EVar"; + pp_ident (state#pad 1 0) v | ECall {value; region} -> - pp_loc_node buffer ~pad "ECall" region; - pp_fun_call buffer ~pad value + pp_loc_node state "ECall" region; + pp_fun_call state value | EBytes b -> - pp_node buffer ~pad "EBytes"; - pp_bytes buffer ~pad b + pp_node state "EBytes"; + pp_bytes state b | EUnit u -> - pp_loc_node buffer ~pad "EUnit" u.region + pp_loc_node state "EUnit" u.region | ETuple e_tuple -> - pp_node buffer ~pad "ETuple"; - pp_tuple_expr buffer ~pad e_tuple + pp_node state "ETuple"; + pp_tuple_expr state e_tuple | EPar {value; region} -> - pp_loc_node buffer ~pad "EPar" region; - pp_expr buffer ~pad:(mk_pad 1 0 pc) value.inside + pp_loc_node state "EPar" region; + pp_expr (state#pad 1 0) value.inside | ELetIn {value; region} -> - pp_loc_node buffer ~pad "ELetIn" region; - pp_let_in buffer ~pad value + pp_loc_node state "ELetIn" region; + pp_let_in state value | EFun {value; region} -> - pp_loc_node buffer ~pad "EFun" region; - pp_fun_expr buffer ~pad value + pp_loc_node state "EFun" region; + pp_fun_expr state value | ESeq {value; region} -> - pp_loc_node buffer ~pad "ESeq" region; - pp_injection pp_expr buffer ~pad value + pp_loc_node state "ESeq" region; + pp_injection pp_expr state value -and pp_fun_expr buffer ~pad:(_,pc) node = +and pp_fun_expr state node = let {binders; lhs_type; body; _} = node in let fields = if lhs_type = None then 2 else 3 in let () = - let pad = mk_pad fields 0 pc in - pp_node buffer ~pad ""; - pp_binders buffer ~pad binders in + let state = state#pad fields 0 in + pp_node state ""; + pp_binders state binders in let () = match lhs_type with None -> () | Some (_, type_expr) -> - let _, pc as pad = mk_pad fields 1 pc in - pp_node buffer ~pad ""; - pp_type_expr buffer ~pad:(mk_pad 1 0 pc) type_expr in + let state = state#pad fields 1 in + pp_node state ""; + pp_type_expr (state#pad 1 0) type_expr in let () = - let pad = mk_pad fields (fields - 1) pc in - pp_node buffer ~pad ""; - pp_expr buffer ~pad:(mk_pad 1 0 pc) body + let state = state#pad fields (fields - 1) in + pp_node state ""; + pp_expr (state#pad 1 0) body in () -and pp_let_in buffer ~pad:(_,pc) node = +and pp_let_in state node = let {binding; body; _} = node in let {binders; lhs_type; let_rhs; _} = binding in let fields = if lhs_type = None then 3 else 4 in let () = - let pad = mk_pad fields 0 pc in - pp_node buffer ~pad ""; - pp_binders buffer ~pad binders in + let state = state#pad fields 0 in + pp_node state ""; + pp_binders state binders in let () = match lhs_type with None -> () | Some (_, type_expr) -> - let _, pc as pad = mk_pad fields 1 pc in - pp_node buffer ~pad ""; - pp_type_expr buffer ~pad:(mk_pad 1 0 pc) type_expr in + let state = state#pad fields 1 in + pp_node state ""; + pp_type_expr (state#pad 1 0) type_expr in let () = - let _, pc as pad = mk_pad fields (fields - 2) pc in - pp_node buffer ~pad ""; - pp_expr buffer ~pad:(mk_pad 1 0 pc) let_rhs in + let state = state#pad fields (fields - 2) in + pp_node state ""; + pp_expr (state#pad 1 0) let_rhs in let () = - let _, pc as pad = mk_pad fields (fields - 1) pc in - pp_node buffer ~pad ""; - pp_expr buffer ~pad:(mk_pad 1 0 pc) body + let state = state#pad fields (fields - 1) in + pp_node state ""; + pp_expr (state#pad 1 0) body in () -and pp_tuple_expr buffer ~pad:(_,pc) {value; _} = - let exprs = Utils.nsepseq_to_list value in - let length = List.length exprs in - let apply len rank = - pp_expr buffer ~pad:(mk_pad len rank pc) +and pp_tuple_expr state {value; _} = + let exprs = Utils.nsepseq_to_list value in + let length = List.length exprs in + let apply len rank = pp_expr (state#pad len rank) in List.iteri (apply length) exprs -and pp_fun_call buffer ~pad:(_,pc) (fun_expr, args) = - let args = Utils.nseq_to_list args in - let arity = List.length args in - let apply len rank = - pp_expr buffer ~pad:(mk_pad len rank pc) - in pp_expr buffer ~pad:(mk_pad (1+arity) 0 pc) fun_expr; +and pp_fun_call state (fun_expr, args) = + let args = Utils.nseq_to_list args in + let arity = List.length args in + let apply len rank = pp_expr (state#pad len rank) + in pp_expr (state#pad (1+arity) 0) fun_expr; List.iteri (apply arity) args -and pp_projection buffer ~pad:(_,pc) proj = - let selections = Utils.nsepseq_to_list proj.field_path in - let len = List.length selections in - let apply len rank = - pp_selection buffer ~pad:(mk_pad len rank pc) in - pp_ident buffer ~pad:(mk_pad (1+len) 0 pc) proj.struct_name; +and pp_projection state proj = + let selections = Utils.nsepseq_to_list proj.field_path in + let len = List.length selections in + let apply len rank = pp_selection (state#pad len rank) in + pp_ident (state#pad (1+len) 0) proj.struct_name; List.iteri (apply len) selections -and pp_selection buffer ~pad:(_,pc as pad) = function +and pp_selection state = function FieldName fn -> - pp_node buffer ~pad "FieldName"; - pp_ident buffer ~pad:(mk_pad 1 0 pc) fn + pp_node state "FieldName"; + pp_ident (state#pad 1 0) fn | Component c -> - pp_node buffer ~pad "Component"; - pp_int buffer ~pad c + pp_node state "Component"; + pp_int state c -and pp_field_assign buffer ~pad:(_,pc as pad) {value; _} = - pp_node buffer ~pad ""; - pp_ident buffer ~pad:(mk_pad 2 0 pc) value.field_name; - pp_expr buffer ~pad:(mk_pad 2 1 pc) value.field_expr +and pp_field_assign state {value; _} = + pp_node state ""; + pp_ident (state#pad 2 0) value.field_name; + pp_expr (state#pad 2 1) value.field_expr -and pp_constr_expr buffer ~pad:(_,pc as pad) = function +and pp_constr_expr state = function ENone region -> - pp_loc_node buffer ~pad "ENone" region + pp_loc_node state "ENone" region | ESomeApp {value=_,arg; region} -> - pp_loc_node buffer ~pad "ESomeApp" region; - pp_expr buffer ~pad:(mk_pad 1 0 pc) arg + pp_loc_node state "ESomeApp" region; + pp_expr (state#pad 1 0) arg | EConstrApp {value; region} -> - pp_loc_node buffer ~pad "EConstrApp" region; - pp_constr_app_expr buffer ~pad value + pp_loc_node state "EConstrApp" region; + pp_constr_app_expr state value -and pp_constr_app_expr buffer ~pad:(_,pc) (constr, expr_opt) = +and pp_constr_app_expr state (constr, expr_opt) = match expr_opt with - None -> pp_ident buffer ~pad:(mk_pad 1 0 pc) constr + None -> pp_ident (state#pad 1 0) constr | Some expr -> - pp_ident buffer ~pad:(mk_pad 2 0 pc) constr; - pp_expr buffer ~pad:(mk_pad 2 1 pc) expr + pp_ident (state#pad 2 0) constr; + pp_expr (state#pad 2 1) expr -and pp_list_expr buffer ~pad:(_,pc as pad) = function +and pp_list_expr state = function ECons {value; region} -> - pp_loc_node buffer ~pad "Cons" region; - pp_expr buffer ~pad:(mk_pad 2 0 pc) value.arg1; - pp_expr buffer ~pad:(mk_pad 2 1 pc) value.arg2 + pp_loc_node state "Cons" region; + pp_expr (state#pad 2 0) value.arg1; + pp_expr (state#pad 2 1) value.arg2 | EListComp {value; region} -> - pp_loc_node buffer ~pad "List" region; + pp_loc_node state "List" region; if value.elements = None - then pp_node buffer ~pad:(mk_pad 1 0 pc) "" - else pp_injection pp_expr buffer ~pad value + then pp_node (state#pad 1 0) "" + else pp_injection pp_expr state value -and pp_string_expr buffer ~pad:(_,pc as pad) = function +and pp_string_expr state = function Cat {value; region} -> - pp_loc_node buffer ~pad "Cat" region; - pp_expr buffer ~pad:(mk_pad 2 0 pc) value.arg1; - pp_expr buffer ~pad:(mk_pad 2 1 pc) value.arg2; -| StrLit s -> - pp_node buffer ~pad "StrLit"; - pp_string buffer ~pad:(mk_pad 1 0 pc) s + pp_loc_node state "Cat" region; + pp_expr (state#pad 2 0) value.arg1; + pp_expr (state#pad 2 1) value.arg2; +| String s -> + pp_node state "String"; + pp_string (state#pad 1 0) s -and pp_arith_expr buffer ~pad:(_,pc as pad) = function +and pp_arith_expr state = function Add {value; region} -> - pp_bin_op "Add" region buffer ~pad value + pp_bin_op "Add" region state value | Sub {value; region} -> - pp_bin_op "Sub" region buffer ~pad value + pp_bin_op "Sub" region state value | Mult {value; region} -> - pp_bin_op "Mult" region buffer ~pad value + pp_bin_op "Mult" region state value | Div {value; region} -> - pp_bin_op "Div" region buffer ~pad value + pp_bin_op "Div" region state value | Mod {value; region} -> - pp_bin_op "Mod" region buffer ~pad value + pp_bin_op "Mod" region state value | Neg {value; region} -> - pp_loc_node buffer ~pad "Neg" region; - pp_expr buffer ~pad:(mk_pad 1 0 pc) value.arg; + pp_loc_node state "Neg" region; + pp_expr (state#pad 1 0) value.arg; | Int i -> - pp_node buffer ~pad "Int"; - pp_int buffer ~pad i + pp_node state "Int"; + pp_int state i | Nat n -> - pp_node buffer ~pad "Nat"; - pp_int buffer ~pad n + pp_node state "Nat"; + pp_int state n | Mutez m -> - pp_node buffer ~pad "Mutez"; - pp_int buffer ~pad m + pp_node state "Mutez"; + pp_int state m -and pp_e_logic buffer ~pad:(_,pc as pad) = function +and pp_e_logic state = function BoolExpr e -> - pp_node buffer ~pad "BoolExpr"; - pp_bool_expr buffer ~pad:(mk_pad 1 0 pc) e + pp_node state "BoolExpr"; + pp_bool_expr (state#pad 1 0) e | CompExpr e -> - pp_node buffer ~pad "CompExpr"; - pp_comp_expr buffer ~pad:(mk_pad 1 0 pc) e + pp_node state "CompExpr"; + pp_comp_expr (state#pad 1 0) e -and pp_bool_expr buffer ~pad:(_,pc as pad) = function +and pp_bool_expr state = function Or {value; region} -> - pp_bin_op "Or" region buffer ~pad value + pp_bin_op "Or" region state value | And {value; region} -> - pp_bin_op "And" region buffer ~pad value + pp_bin_op "And" region state value | Not {value; _} -> - pp_node buffer ~pad "Not"; - pp_expr buffer ~pad:(mk_pad 1 0 pc) value.arg + pp_node state "Not"; + pp_expr (state#pad 1 0) value.arg | False region -> - pp_loc_node buffer ~pad "False" region + pp_loc_node state "False" region | True region -> - pp_loc_node buffer ~pad "True" region + pp_loc_node state "True" region -and pp_comp_expr buffer ~pad = function +and pp_comp_expr state = function Lt {value; region} -> - pp_bin_op "Lt" region buffer ~pad value + pp_bin_op "Lt" region state value | Leq {value; region} -> - pp_bin_op "Leq" region buffer ~pad value + pp_bin_op "Leq" region state value | Gt {value; region} -> - pp_bin_op "Gt" region buffer ~pad value + pp_bin_op "Gt" region state value | Geq {value; region} -> - pp_bin_op "Geq" region buffer ~pad value + pp_bin_op "Geq" region state value | Equal {value; region} -> - pp_bin_op "Equal" region buffer ~pad value + pp_bin_op "Equal" region state value | Neq {value; region} -> - pp_bin_op "Neq" region buffer ~pad value + pp_bin_op "Neq" region state value -and pp_bin_op node region buffer ~pad:(_,pc as pad) op = - pp_loc_node buffer ~pad node region; - pp_expr buffer ~pad:(mk_pad 2 0 pc) op.arg1; - pp_expr buffer ~pad:(mk_pad 2 1 pc) op.arg2 +and pp_bin_op node region state op = + pp_loc_node state node region; + pp_expr (state#pad 2 0) op.arg1; + pp_expr (state#pad 2 1) op.arg2 -and pp_annotated buffer ~pad:(_,pc) (expr, t_expr) = - pp_expr buffer ~pad:(mk_pad 2 0 pc) expr; - pp_type_expr buffer ~pad:(mk_pad 2 1 pc) 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 -and pp_cond_expr buffer ~pad:(_,pc) (cond: cond_expr) = +and pp_cond_expr state (cond: cond_expr) = let () = - let _, pc as pad = mk_pad 3 0 pc in - pp_node buffer ~pad ""; - pp_expr buffer ~pad:(mk_pad 1 0 pc) cond.test in + let state = state#pad 3 0 in + pp_node state ""; + pp_expr (state#pad 1 0) cond.test in let () = - let _, pc as pad = mk_pad 3 1 pc in - pp_node buffer ~pad ""; - pp_expr buffer ~pad:(mk_pad 1 0 pc) cond.ifso in + let state = state#pad 3 1 in + pp_node state ""; + pp_expr (state#pad 1 0) cond.ifso in let () = - let _, pc as pad = mk_pad 3 2 pc in - pp_node buffer ~pad ""; - pp_expr buffer ~pad:(mk_pad 1 0 pc) cond.ifnot + let state = state#pad 3 2 in + pp_node state ""; + pp_expr (state#pad 1 0) cond.ifnot in () and pp_case : - 'a.(Buffer.t -> pad:(string*string) -> 'a -> unit) - -> Buffer.t -> pad:(string*string) -> 'a case -> unit = - fun printer buffer ~pad:(_,pc) case -> + 'a.(state -> 'a -> unit) -> state -> 'a case -> unit = + fun printer state case -> let clauses = Utils.nsepseq_to_list case.cases.value in let clauses = List.map (fun {value; _} -> value) clauses in let length = List.length clauses + 1 in let apply len rank = - pp_case_clause printer buffer ~pad:(mk_pad len (rank+1) pc) - in pp_expr buffer ~pad:(mk_pad length 0 pc) case.expr; + pp_case_clause printer (state#pad len (rank+1)) + in pp_expr (state#pad length 0) case.expr; List.iteri (apply length) clauses and pp_case_clause : - 'a.(Buffer.t -> pad:(string*string) -> 'a -> unit) - -> Buffer.t -> pad:(string*string) -> 'a case_clause -> unit = - fun printer buffer ~pad:(_,pc as pad) clause -> - pp_node buffer ~pad ""; - pp_pattern buffer ~pad:(mk_pad 2 0 pc) clause.pattern; - printer buffer ~pad:(mk_pad 2 1 pc) clause.rhs + 'a.(state -> 'a -> unit) -> state -> 'a case_clause -> unit = + fun printer state clause -> + pp_node state ""; + pp_pattern (state#pad 2 0) clause.pattern; + printer (state#pad 2 1) clause.rhs -and pp_type_expr buffer ~pad:(_,pc as pad) = function +and pp_type_expr state = function TProd {value; region} -> - pp_loc_node buffer ~pad "TProd" region; - pp_cartesian buffer ~pad value + pp_loc_node state "TProd" region; + pp_cartesian state value | TSum {value; region} -> - pp_loc_node buffer ~pad "TSum" region; + pp_loc_node state "TSum" region; let apply len rank variant = - let pad = mk_pad len rank pc in - pp_variant buffer ~pad variant.value in + let state = state#pad len rank in + pp_variant state variant.value in let variants = Utils.nsepseq_to_list value in List.iteri (List.length variants |> apply) variants | TRecord {value; region} -> - pp_loc_node buffer ~pad "TRecord" region; - pp_ne_injection pp_field_decl buffer ~pad value + pp_loc_node state "TRecord" region; + pp_ne_injection pp_field_decl state value | TApp {value=name,tuple; region} -> - pp_loc_node buffer ~pad "TApp" region; - pp_ident buffer ~pad:(mk_pad 1 0 pc) name; - pp_type_tuple buffer ~pad:(mk_pad 2 1 pc) tuple + pp_loc_node state "TApp" region; + pp_ident (state#pad 1 0) name; + pp_type_tuple (state#pad 2 1) tuple | TFun {value; region} -> - pp_loc_node buffer ~pad "TFun" region; + pp_loc_node state "TFun" region; let apply len rank = - let pad = mk_pad len rank pc in - pp_type_expr buffer ~pad in + pp_type_expr (state#pad len rank) in let domain, _, range = value in List.iteri (apply 2) [domain; range] | TPar {value={inside;_}; region} -> - pp_loc_node buffer ~pad "TPar" region; - pp_type_expr buffer ~pad:(mk_pad 1 0 pc) inside + pp_loc_node state "TPar" region; + pp_type_expr (state#pad 1 0) inside | TVar v -> - pp_node buffer ~pad "TVar"; - pp_ident buffer ~pad:(mk_pad 1 0 pc) v + pp_node state "TVar"; + pp_ident (state#pad 1 0) v -and pp_type_tuple buffer ~pad:(_,pc) {value; _} = - let components = Utils.nsepseq_to_list value.inside in - let apply len rank = - pp_type_expr buffer ~pad:(mk_pad len rank pc) +and pp_type_tuple state {value; _} = + let components = Utils.nsepseq_to_list value.inside in + let apply len rank = pp_type_expr (state#pad len rank) in List.iteri (List.length components |> apply) components -and pp_field_decl buffer ~pad:(_,pc as pad) {value; _} = - pp_ident buffer ~pad value.field_name; - pp_type_expr buffer ~pad:(mk_pad 1 0 pc) value.field_type +and pp_field_decl state {value; _} = + pp_ident state value.field_name; + pp_type_expr (state#pad 1 0) value.field_type -and pp_cartesian buffer ~pad:(_,pc) t_exprs = - let t_exprs = Utils.nsepseq_to_list t_exprs in - let arity = List.length t_exprs in - let apply len rank = - pp_type_expr buffer ~pad:(mk_pad len rank pc) +and pp_cartesian state t_exprs = + let t_exprs = Utils.nsepseq_to_list t_exprs in + let arity = List.length t_exprs in + let apply len rank = pp_type_expr (state#pad len rank) in List.iteri (apply arity) t_exprs -and pp_variant buffer ~pad:(_,pc as pad) {constr; arg} = - pp_ident buffer ~pad constr; +and pp_variant state {constr; arg} = + pp_ident state constr; match arg with None -> () - | Some (_,c) -> - pp_type_expr buffer ~pad:(mk_pad 1 0 pc) c - -let pp_ast buffer = pp_ast buffer ~pad:("","") + | Some (_,c) -> pp_type_expr (state#pad 1 0) c diff --git a/src/passes/1-parser/ligodity/ParserLog.mli b/src/passes/1-parser/ligodity/ParserLog.mli index 65409cc09..bae31ee93 100644 --- a/src/passes/1-parser/ligodity/ParserLog.mli +++ b/src/passes/1-parser/ligodity/ParserLog.mli @@ -1,23 +1,30 @@ -(* Printing the AST *) +(** Printing the AST *) -val offsets : bool ref -val mode : [`Byte | `Point] ref +(** The type [state] captures the state that is threaded in the + printing iterators in this module. +*) +type state -(* Printing the tokens reconstructed from the AST. This is very useful +val mk_state : + offsets:bool -> mode:[`Point|`Byte] -> buffer:Buffer.t -> state + +(** {1 Printing tokens from the AST in a buffer} + + Printing the tokens reconstructed from the AST. This is very useful for debugging, as the output of [print_token ast] can be textually - compared to that of [Lexer.trace] (see module [LexerMain]). The - optional parameter [undo] is bound to [true] if the caller wants - the AST to be unparsed before printing (those nodes that have been - normalised with function [norm_let] and [norm_fun]). *) + compared to that of [Lexer.trace] (see module [LexerMain]). *) -val print_tokens : Buffer.t -> AST.t -> unit -val print_pattern : Buffer.t -> AST.pattern -> unit -val print_expr : Buffer.t -> AST.expr -> unit +val print_tokens : state -> AST.t -> unit +val print_pattern : state -> AST.pattern -> unit +val print_expr : state -> AST.expr -> unit -val tokens_to_string : AST.t -> string -val pattern_to_string : AST.pattern -> string -val expr_to_string : AST.expr -> string +val tokens_to_string : + offsets:bool -> mode:[`Point|`Byte] -> AST.t -> string +val pattern_to_string : + offsets:bool -> mode:[`Point|`Byte] -> AST.pattern -> string +val expr_to_string : + offsets:bool -> mode:[`Point|`Byte] -> AST.expr -> string -(* Pretty-printing of the AST *) +(** {1 Pretty-printing of the AST} *) -val pp_ast : Buffer.t -> AST.t -> unit +val pp_ast : state -> AST.t -> unit diff --git a/src/passes/1-parser/ligodity/ParserMain.ml b/src/passes/1-parser/ligodity/ParserMain.ml index f57c86264..e683b15d1 100644 --- a/src/passes/1-parser/ligodity/ParserMain.ml +++ b/src/passes/1-parser/ligodity/ParserMain.ml @@ -1,27 +1,24 @@ -(* Driver for the parser of Ligodity *) +(** Driver for the parser of CameLIGO *) -(* Error printing and exception tracing *) +let extension = ".mligo" +let options = EvalOpt.read "CameLIGO" extension +(** Error printing and exception tracing +*) let () = Printexc.record_backtrace true -(* Reading the command-line options *) - -let options = EvalOpt.read "CameLIGO" ".mligo" - -open EvalOpt - -(* Auxiliary functions *) - +(** Auxiliary functions +*) let sprintf = Printf.sprintf -(* Extracting the input file *) - +(** Extracting the input file +*) let file = - match options.input with + match options#input with None | Some "-" -> false | Some _ -> true -(* Error printing and exception tracing *) +(** {1 Error printing and exception tracing} *) let () = Printexc.record_backtrace true @@ -35,35 +32,35 @@ let error_to_string = function | _ -> assert false let print_error ?(offsets=true) mode Region.{region; value} ~file = - let msg = error_to_string value in - let reg = region#to_string ~file ~offsets mode in + let msg = error_to_string value in + let reg = region#to_string ~file ~offsets mode in Utils.highlight (sprintf "Parse error %s:\n%s%!" reg msg) -(* Path for CPP inclusions (#include) *) +(** {1 Preprocessing the input source and opening the input channels} *) +(** Path for CPP inclusions (#include) +*) let lib_path = - match options.libs with + match options#libs with [] -> "" | libs -> let mk_I dir path = Printf.sprintf " -I %s%s" dir path - in List.fold_right mk_I libs "" - -(* Preprocessing the input source and opening the input channels *) + in List.fold_right mk_I libs "" let prefix = - match options.input with + match options#input with None | Some "-" -> "temp" | Some file -> Filename.(file |> basename |> remove_extension) -let suffix = ".pp.mligo" +let suffix = ".pp" ^ extension let pp_input = - if Utils.String.Set.mem "cpp" options.verbose + if Utils.String.Set.mem "cpp" options#verbose then prefix ^ suffix else let pp_input, pp_out = Filename.open_temp_file prefix suffix in close_out pp_out; pp_input let cpp_cmd = - match options.input with + match options#input with None | Some "-" -> Printf.sprintf "cpp -traditional-cpp%s - > %s" lib_path pp_input @@ -72,12 +69,12 @@ let cpp_cmd = lib_path file pp_input let () = - if Utils.String.Set.mem "cpp" options.verbose + if Utils.String.Set.mem "cpp" options#verbose then Printf.eprintf "%s\n%!" cpp_cmd; if Sys.command cpp_cmd <> 0 then external_ (Printf.sprintf "the command \"%s\" failed." cpp_cmd) -(* Instanciating the lexer *) +(** {1 Instanciating the lexer} *) module Lexer = Lexer.Make (LexToken) @@ -88,45 +85,49 @@ let Lexer.{read; buffer; get_pos; get_last; close} = and cout = stdout -let log = Log.output_token ~offsets:options.offsets - options.mode options.cmd cout +let log = Log.output_token ~offsets:options#offsets + options#mode options#cmd cout and close_all () = close (); close_out cout -(* Tokeniser *) +(** {1 Tokeniser} *) let tokeniser = read ~log -(* Main *) +(** {1 Main} *) let () = try let ast = Parser.contract tokeniser buffer in - if Utils.String.Set.mem "ast" options.verbose + if Utils.String.Set.mem "ast" options#verbose then let buffer = Buffer.create 131 in + let state = ParserLog.mk_state + ~offsets:options#offsets + ~mode:options#mode + ~buffer in begin - ParserLog.offsets := options.offsets; - ParserLog.mode := options.mode; - ParserLog.pp_ast buffer ast; + ParserLog.pp_ast state ast; Buffer.output_buffer stdout buffer end - else if Utils.String.Set.mem "ast-tokens" options.verbose + else if Utils.String.Set.mem "ast-tokens" options#verbose then let buffer = Buffer.create 131 in + let state = ParserLog.mk_state + ~offsets:options#offsets + ~mode:options#mode + ~buffer in begin - ParserLog.offsets := options.offsets; - ParserLog.mode := options.mode; - ParserLog.print_tokens buffer ast; + ParserLog.print_tokens state ast; Buffer.output_buffer stdout buffer end with Lexer.Error err -> close_all (); - Lexer.print_error ~offsets:options.offsets - options.mode err ~file + Lexer.print_error ~offsets:options#offsets + options#mode err ~file | Parser.Error -> let region = get_last () in let error = Region.{region; value=ParseError} in let () = close_all () in - print_error ~offsets:options.offsets - options.mode error ~file + print_error ~offsets:options#offsets + options#mode error ~file | Sys_error msg -> Utils.highlight msg diff --git a/src/passes/1-parser/ligodity/Tests/pp.mligo b/src/passes/1-parser/ligodity/Tests/pp.mligo new file mode 100644 index 000000000..99aff4f23 --- /dev/null +++ b/src/passes/1-parser/ligodity/Tests/pp.mligo @@ -0,0 +1,26 @@ +type q = {a: int; b: {c: string}} +type r = int list +type s = (int, address) map +type t = int +type u = {a: int; b: t * char} +type v = int * (string * address) +type w = timestamp * nat -> (string, address) map +type x = A | B of t * int | C of int -> (string -> int) + +let x = 4 +let y : t = (if true then -3 + f x x else 0) - 1 +let f (x: int) y = (x : int) +let z : (t) = y +let w = + match f 3 with + None -> [] + | Some (1::[2;3]) -> [4;5]::[] +let n : nat = 0n +let a = A +let b = B a +let c = C (a, B (a)) +let d = None +let e = Some (a, B b) +let z = z.1.2 +let v = "hello" ^ "world" ^ "!" +let w = Map.literal [(1,"1"); (2,"2")] diff --git a/src/passes/1-parser/pascaligo/.Lexer.ml.tag b/src/passes/1-parser/pascaligo/.Lexer.ml.tag deleted file mode 100644 index 051eeceb0..000000000 --- a/src/passes/1-parser/pascaligo/.Lexer.ml.tag +++ /dev/null @@ -1 +0,0 @@ -ocamlc: -w -42 diff --git a/src/passes/1-parser/pascaligo/.links b/src/passes/1-parser/pascaligo/.links index 3c0ffd08a..f0fdfb646 100644 --- a/src/passes/1-parser/pascaligo/.links +++ b/src/passes/1-parser/pascaligo/.links @@ -4,9 +4,6 @@ $HOME/git/ligo/vendors/ligo-utils/simple-utils/pos.mli $HOME/git/ligo/vendors/ligo-utils/simple-utils/pos.ml $HOME/git/ligo/vendors/ligo-utils/simple-utils/region.mli $HOME/git/ligo/vendors/ligo-utils/simple-utils/region.ml -$HOME/git/ligo/vendors/ligo-utils/simple-utils/x_map.ml -$HOME/git/ligo/vendors/ligo-utils/simple-utils/x_list.ml -$HOME/git/ligo/vendors/ligo-utils/simple-utils/x_option.ml ../shared/Lexer.mli ../shared/Lexer.mll ../shared/Error.mli diff --git a/src/passes/1-parser/pascaligo/AST.ml b/src/passes/1-parser/pascaligo/AST.ml index 5431362ff..ebd02bf73 100644 --- a/src/passes/1-parser/pascaligo/AST.ml +++ b/src/passes/1-parser/pascaligo/AST.ml @@ -217,10 +217,8 @@ and fun_expr = { colon : colon; ret_type : type_expr; kwd_is : kwd_is; - local_decls : local_decl list; - block : block reg option; - kwd_with : kwd_with option; - return : expr; + block_with : (block reg * kwd_with) option; + return : expr } and fun_decl = { @@ -269,9 +267,6 @@ and statement = Instr of instruction | Data of data_decl -and local_decl = -| LocalData of data_decl - and data_decl = LocalConst of const_decl reg | LocalVar of var_decl reg @@ -757,11 +752,6 @@ let pattern_to_region = function | PList PCons {region; _} | PTuple {region; _} -> region -let local_decl_to_region = function -| LocalData LocalFun {region; _} -| LocalData LocalConst {region; _} -| LocalData LocalVar {region; _} -> region - let lhs_to_region : lhs -> Region.t = function Path path -> path_to_region path | MapPath {region; _} -> region diff --git a/src/passes/1-parser/pascaligo/AST.mli b/src/passes/1-parser/pascaligo/AST.mli index 2d0b0fca8..6f1243fc1 100644 --- a/src/passes/1-parser/pascaligo/AST.mli +++ b/src/passes/1-parser/pascaligo/AST.mli @@ -208,10 +208,8 @@ and fun_expr = { colon : colon; ret_type : type_expr; kwd_is : kwd_is; - local_decls : local_decl list; - block : block reg option; - kwd_with : kwd_with option; - return : expr; + block_with : (block reg * kwd_with) option; + return : expr } and fun_decl = { @@ -260,9 +258,6 @@ and statement = Instr of instruction | Data of data_decl -and local_decl = -| LocalData of data_decl - and data_decl = LocalConst of const_decl reg | LocalVar of var_decl reg @@ -615,7 +610,6 @@ val type_expr_to_region : type_expr -> Region.t val expr_to_region : expr -> Region.t val instr_to_region : instruction -> Region.t val pattern_to_region : pattern -> Region.t -val local_decl_to_region : local_decl -> Region.t val path_to_region : path -> Region.t val lhs_to_region : lhs -> Region.t val rhs_to_region : rhs -> Region.t diff --git a/src/passes/1-parser/pascaligo/LexerMain.ml b/src/passes/1-parser/pascaligo/LexerMain.ml index f0f8614d0..9838fcbc4 100644 --- a/src/passes/1-parser/pascaligo/LexerMain.ml +++ b/src/passes/1-parser/pascaligo/LexerMain.ml @@ -1,43 +1,40 @@ -(* Driver for the lexer of PascaLIGO *) +(** Driver for the LIGO lexer *) -(* Error printing and exception tracing *) +let extension = ".ligo" +let options = EvalOpt.read "PascaLIGO" extension +(** Error printing and exception tracing +*) let () = Printexc.record_backtrace true -(* Running the lexer on the source *) - -let options = EvalOpt.read "PascaLIGO" ".ligo" - -open EvalOpt - let external_ text = Utils.highlight (Printf.sprintf "External error: %s" text); exit 1;; -(* Path for CPP inclusions (#include) *) +(** {1 Preprocessing the input source and opening the input channels} *) +(** Path for CPP inclusions (#include) +*) let lib_path = - match options.libs with + match options#libs with [] -> "" | libs -> let mk_I dir path = Printf.sprintf " -I %s%s" dir path in List.fold_right mk_I libs "" -(* Preprocessing the input source and opening the input channels *) - let prefix = - match options.input with + match options#input with None | Some "-" -> "temp" | Some file -> Filename.(file |> basename |> remove_extension) -let suffix = ".pp.ligo" +let suffix = ".pp" ^ extension let pp_input = - if Utils.String.Set.mem "cpp" options.verbose + if Utils.String.Set.mem "cpp" options#verbose then prefix ^ suffix else let pp_input, pp_out = Filename.open_temp_file prefix suffix in close_out pp_out; pp_input let cpp_cmd = - match options.input with + match options#input with None | Some "-" -> Printf.sprintf "cpp -traditional-cpp%s - > %s" lib_path pp_input @@ -46,16 +43,14 @@ let cpp_cmd = lib_path file pp_input let () = - if Utils.String.Set.mem "cpp" options.verbose + if Utils.String.Set.mem "cpp" options#verbose then Printf.eprintf "%s\n%!" cpp_cmd; if Sys.command cpp_cmd <> 0 then external_ (Printf.sprintf "the command \"%s\" failed." cpp_cmd) -(* Running the lexer on the input file *) +(** {1 Running the lexer on the input file} *) -module Lexer = Lexer.Make (LexToken) +module Log = LexerLog.Make (Lexer.Make (LexToken)) -module Log = LexerLog.Make (Lexer) - -let () = Log.trace ~offsets:options.offsets - options.mode (Some pp_input) options.cmd +let () = Log.trace ~offsets:options#offsets + options#mode (Some pp_input) options#cmd diff --git a/src/passes/1-parser/pascaligo/Parser.mly b/src/passes/1-parser/pascaligo/Parser.mly index 0b206bd98..01eb227fb 100644 --- a/src/passes/1-parser/pascaligo/Parser.mly +++ b/src/passes/1-parser/pascaligo/Parser.mly @@ -252,12 +252,9 @@ fun_expr: colon = $4; ret_type = $5; kwd_is = $6; - local_decls = []; - block = Some $7; - kwd_with = Some $8; - return = $9; - } - in {region;value}} + block_with = Some ($7, $8); + return = $9} + in {region;value} } | Function option(fun_name) parameters COLON type_expr Is expr { let stop = expr_to_region $7 in @@ -269,11 +266,8 @@ fun_expr: colon = $4; ret_type = $5; kwd_is = $6; - local_decls = []; - block = None; - kwd_with = None; - return = $7; - } + block_with = None; + return = $7} in {region;value}} @@ -288,20 +282,17 @@ fun_decl: | None -> $1.region in let region = cover $1.region stop and value = { - fun_expr = $1; - terminator = $2; - } - in {region;value}} + fun_expr = $1; + terminator = $2} + in {region; value} } open_fun_decl: fun_expr { let region = $1.region and value = { - fun_expr = $1; - terminator = None; - } - in {region;value}} - + fun_expr = $1; + terminator = None} + in {region; value} } parameters: par(nsepseq(param_decl,SEMI)) { $1 } diff --git a/src/passes/1-parser/pascaligo/ParserLog.ml b/src/passes/1-parser/pascaligo/ParserLog.ml index 6eedd5e1d..69369e7c5 100644 --- a/src/passes/1-parser/pascaligo/ParserLog.ml +++ b/src/passes/1-parser/pascaligo/ParserLog.ml @@ -1,1513 +1,1501 @@ [@@@warning "-42"] -open Utils open AST open! Region -(* Printing the tokens with their source regions *) - let sprintf = Printf.sprintf -let offsets = ref true -let mode = ref `Point +type state = < + offsets : bool; + mode : [`Point | `Byte]; + buffer : Buffer.t; + pad_path : string; + pad_node : string; + pad : int -> int -> state +> -let compact (region: Region.t) = - region#compact ~offsets:!offsets !mode +let mk_state ~offsets ~mode ~buffer = + object + method offsets = offsets; + method mode = mode; + method buffer = buffer + val pad_path = "" + method pad_path = pad_path + 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?). + *) + method pad arity rank = + {< pad_path = + pad_node ^ (if rank = arity-1 then "`-- " else "|-- "); + pad_node = + pad_node ^ (if rank = arity-1 then " " else "| ") + >} + end + +let compact state (region: Region.t) = + region#compact ~offsets:state#offsets state#mode + +(** {1 Printing the tokens with their source regions} *) let print_nsepseq : - Buffer.t -> string -> (Buffer.t -> 'a -> unit) -> - ('a, Region.t) nsepseq -> unit = - fun buffer sep print (head, tail) -> + state -> string -> (state -> 'a -> unit) -> + ('a, Region.t) Utils.nsepseq -> unit = + fun state sep print (head, tail) -> let print_aux (sep_reg, item) = - let sep_line = sprintf "%s: %s\n" (compact sep_reg) sep in - Buffer.add_string buffer sep_line; - print buffer item - in print buffer head; List.iter print_aux tail + let sep_line = + sprintf "%s: %s\n" (compact state sep_reg) sep in + Buffer.add_string state#buffer sep_line; + print state item + in print state head; List.iter print_aux tail let print_sepseq : - Buffer.t -> string -> (Buffer.t -> 'a -> unit) -> - ('a, Region.t) sepseq -> unit = - fun buffer sep print -> function + state -> string -> (state -> 'a -> unit) -> + ('a, Region.t) Utils.sepseq -> unit = + fun state sep print -> function None -> () - | Some seq -> print_nsepseq buffer sep print seq + | Some seq -> print_nsepseq state sep print seq -let print_token buffer region lexeme = - let line = sprintf "%s: %s\n"(compact region) lexeme - in Buffer.add_string buffer line +let print_token state region lexeme = + let line = + sprintf "%s: %s\n"(compact state region) lexeme + in Buffer.add_string state#buffer line -let print_var buffer {region; value=lexeme} = - let line = sprintf "%s: Ident \"%s\"\n" - (compact region) lexeme - in Buffer.add_string buffer line +let print_var state {region; value} = + let line = + sprintf "%s: Ident \"%s\"\n" + (compact state region) value + in Buffer.add_string state#buffer line -let print_constr buffer {region; value=lexeme} = - let line = sprintf "%s: Constr \"%s\"\n" - (compact region) lexeme - in Buffer.add_string buffer line +let print_constr state {region; value} = + let line = + sprintf "%s: Constr \"%s\"\n" + (compact state region) value + in Buffer.add_string state#buffer line -let print_string buffer {region; value=lexeme} = - let line = sprintf "%s: String %s\n" - (compact region) lexeme - in Buffer.add_string buffer line +let print_string state {region; value} = + let line = + sprintf "%s: String %s\n" + (compact state region) value + in Buffer.add_string state#buffer line -let print_bytes buffer {region; value = lexeme, abstract} = - let line = sprintf "%s: Bytes (\"%s\", \"0x%s\")\n" - (compact region) lexeme - (Hex.to_string abstract) - in Buffer.add_string buffer line +let print_bytes state {region; value} = + let lexeme, abstract = value in + let line = + sprintf "%s: Bytes (\"%s\", \"0x%s\")\n" + (compact state region) lexeme + (Hex.to_string abstract) + in Buffer.add_string state#buffer line -let print_int buffer {region; value = lexeme, abstract} = - let line = sprintf "%s: Int (\"%s\", %s)\n" - (compact region) lexeme - (Z.to_string abstract) - in Buffer.add_string buffer line +let print_int state {region; value} = + let lexeme, abstract = value in + let line = + sprintf "%s: Int (\"%s\", %s)\n" + (compact state region) lexeme + (Z.to_string abstract) + in Buffer.add_string state#buffer line -let print_nat buffer {region; value = lexeme, abstract} = - let line = sprintf "%s: Nat (\"%s\", %s)\n" - (compact region) lexeme - (Z.to_string abstract) - in Buffer.add_string buffer line +let print_nat state {region; value} = + let lexeme, abstract = value in + let line = + sprintf "%s: Nat (\"%s\", %s)\n" + (compact state region) lexeme + (Z.to_string abstract) + in Buffer.add_string state#buffer line -(* Main printing function *) - -let rec print_tokens buffer ast = +let rec print_tokens state ast = let {decl; eof} = ast in - Utils.nseq_iter (print_decl buffer) decl; - print_token buffer eof "EOF" + Utils.nseq_iter (print_decl state) decl; + print_token state eof "EOF" -and print_decl buffer = function - TypeDecl decl -> print_type_decl buffer decl -| ConstDecl decl -> print_const_decl buffer decl -| FunDecl decl -> print_fun_decl buffer decl +and print_decl state = function + TypeDecl decl -> print_type_decl state decl +| ConstDecl decl -> print_const_decl state decl +| FunDecl decl -> print_fun_decl state decl -and print_const_decl buffer {value; _} = +and print_const_decl state {value; _} = let {kwd_const; name; colon; const_type; equal; init; terminator} = value in - print_token buffer kwd_const "const"; - print_var buffer name; - print_token buffer colon ":"; - print_type_expr buffer const_type; - print_token buffer equal "="; - print_expr buffer init; - print_terminator buffer terminator + print_token state kwd_const "const"; + print_var state name; + print_token state colon ":"; + print_type_expr state const_type; + print_token state equal "="; + print_expr state init; + print_terminator state terminator -and print_type_decl buffer {value; _} = +and print_type_decl state {value; _} = let {kwd_type; name; kwd_is; type_expr; terminator} = value in - print_token buffer kwd_type "type"; - print_var buffer name; - print_token buffer kwd_is "is"; - print_type_expr buffer type_expr; - print_terminator buffer terminator + print_token state kwd_type "type"; + print_var state name; + print_token state kwd_is "is"; + print_type_expr state type_expr; + print_terminator state terminator -and print_type_expr buffer = function - TProd cartesian -> print_cartesian buffer cartesian -| TSum sum_type -> print_sum_type buffer sum_type -| TRecord record_type -> print_record_type buffer record_type -| TApp type_app -> print_type_app buffer type_app -| TFun type_fun -> print_type_fun buffer type_fun -| TPar par_type -> print_par_type buffer par_type -| TVar type_var -> print_var buffer type_var +and print_type_expr state = function + TProd cartesian -> print_cartesian state cartesian +| TSum sum_type -> print_sum_type state sum_type +| TRecord record_type -> print_record_type state record_type +| TApp type_app -> print_type_app state type_app +| TFun type_fun -> print_type_fun state type_fun +| TPar par_type -> print_par_type state par_type +| TVar type_var -> print_var state type_var -and print_cartesian buffer {value; _} = - print_nsepseq buffer "*" print_type_expr value +and print_cartesian state {value; _} = + print_nsepseq state "*" print_type_expr value -and print_variant buffer ({value; _}: variant reg) = +and print_variant state ({value; _}: variant reg) = let {constr; arg} = value in - print_constr buffer constr; + print_constr state constr; match arg with None -> () | Some (kwd_of, t_expr) -> - print_token buffer kwd_of "of"; - print_type_expr buffer t_expr + print_token state kwd_of "of"; + print_type_expr state t_expr -and print_sum_type buffer {value; _} = - print_nsepseq buffer "|" print_variant value +and print_sum_type state {value; _} = + print_nsepseq state "|" print_variant value -and print_record_type buffer record_type = - print_ne_injection buffer "record" print_field_decl record_type +and print_record_type state record_type = + print_ne_injection state "record" print_field_decl record_type -and print_type_app buffer {value; _} = +and print_type_app state {value; _} = let type_name, type_tuple = value in - print_var buffer type_name; - print_type_tuple buffer type_tuple + print_var state type_name; + print_type_tuple state type_tuple -and print_type_fun buffer {value; _} = +and print_type_fun state {value; _} = let type_expr_a, arrow, type_expr_b = value in - print_type_expr buffer type_expr_a; - print_token buffer arrow "->"; - print_type_expr buffer type_expr_b + print_type_expr state type_expr_a; + print_token state arrow "->"; + print_type_expr state type_expr_b -and print_par_type buffer {value; _} = +and print_par_type state {value; _} = let {lpar; inside; rpar} = value in - print_token buffer lpar "("; - print_type_expr buffer inside; - print_token buffer rpar ")" + print_token state lpar "("; + print_type_expr state inside; + print_token state rpar ")" -and print_field_decl buffer {value; _} = +and print_field_decl state {value; _} = let {field_name; colon; field_type} = value in - print_var buffer field_name; - print_token buffer colon ":"; - print_type_expr buffer field_type + print_var state field_name; + print_token state colon ":"; + print_type_expr state field_type -and print_type_tuple buffer {value; _} = +and print_type_tuple state {value; _} = let {lpar; inside; rpar} = value in - print_token buffer lpar "("; - print_nsepseq buffer "," print_type_expr inside; - print_token buffer rpar ")" + print_token state lpar "("; + print_nsepseq state "," print_type_expr inside; + print_token state rpar ")" -and print_fun_expr buffer {value; _} = +and print_fun_expr state {value; _} = let {kwd_function; name; param; colon; - ret_type; kwd_is; local_decls; - block; kwd_with; return;} = value in - let anonymous_name = Region.wrap_ghost "#anonymous" in - print_token buffer kwd_function "function"; - print_var buffer @@ Simple_utils.Option.unopt ~default:anonymous_name name; - print_parameters buffer param; - print_token buffer colon ":"; - print_type_expr buffer ret_type; - print_token buffer kwd_is "is"; - print_local_decls buffer local_decls; - print_block buffer block; - match kwd_with with - | Some kwd_with -> - print_token buffer kwd_with "with"; - | None -> (); - print_expr buffer return; + ret_type; kwd_is; block_with; return} = value in + print_token state kwd_function "function"; + (match name with + None -> print_var state (Region.wrap_ghost "#anon") + | Some var -> print_var state var); + print_parameters state param; + print_token state colon ":"; + print_type_expr state ret_type; + print_token state kwd_is "is"; + (match block_with with + None -> () + | Some (block, kwd_with) -> + print_block state block; + print_token state kwd_with "with"); + print_expr state return; -and print_fun_decl buffer {value; _} = +and print_fun_decl state {value; _} = let {fun_expr ; terminator;} = value in - print_fun_expr buffer fun_expr; - print_terminator buffer terminator; + print_fun_expr state fun_expr; + print_terminator state terminator; -and print_parameters buffer {value; _} = +and print_parameters state {value; _} = let {lpar; inside; rpar} = value in - print_token buffer lpar "("; - print_nsepseq buffer ";" print_param_decl inside; - print_token buffer rpar ")" + print_token state lpar "("; + print_nsepseq state ";" print_param_decl inside; + print_token state rpar ")" -and print_param_decl buffer = function - ParamConst param_const -> print_param_const buffer param_const -| ParamVar param_var -> print_param_var buffer param_var +and print_param_decl state = function + ParamConst param_const -> print_param_const state param_const +| ParamVar param_var -> print_param_var state param_var -and print_param_const buffer {value; _} = +and print_param_const state {value; _} = let {kwd_const; var; colon; param_type} = value in - print_token buffer kwd_const "const"; - print_var buffer var; - print_token buffer colon ":"; - print_type_expr buffer param_type + print_token state kwd_const "const"; + print_var state var; + print_token state colon ":"; + print_type_expr state param_type -and print_param_var buffer {value; _} = +and print_param_var state {value; _} = let {kwd_var; var; colon; param_type} = value in - print_token buffer kwd_var "var"; - print_var buffer var; - print_token buffer colon ":"; - print_type_expr buffer param_type + print_token state kwd_var "var"; + print_var state var; + print_token state colon ":"; + print_type_expr state param_type -and print_block buffer reg = - match reg with - | Some reg -> - let value = reg.value in - let {opening; statements; terminator; closing} = value in - print_block_opening buffer opening; - print_statements buffer statements; - print_terminator buffer terminator; - print_block_closing buffer closing - | None -> () +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 buffer = function +and print_block_opening state = function Block (kwd_block, lbrace) -> - print_token buffer kwd_block "block"; - print_token buffer lbrace "{" + print_token state kwd_block "block"; + print_token state lbrace "{" | Begin kwd_begin -> - print_token buffer kwd_begin "begin" + print_token state kwd_begin "begin" -and print_block_closing buffer = function - Block rbrace -> print_token buffer rbrace "}" -| End kwd_end -> print_token buffer kwd_end "end" +and print_block_closing state = function + Block rbrace -> print_token state rbrace "}" +| End kwd_end -> print_token state kwd_end "end" -and print_local_decls buffer sequence = - List.iter (print_local_decl buffer) sequence +and print_data_decl state = function + LocalConst decl -> print_const_decl state decl +| LocalVar decl -> print_var_decl state decl +| LocalFun decl -> print_fun_decl state decl -and print_local_decl buffer = function -| LocalData decl -> print_data_decl buffer decl - -and print_data_decl buffer = function - LocalConst decl -> print_const_decl buffer decl -| LocalVar decl -> print_var_decl buffer decl -| LocalFun decl -> print_fun_decl buffer decl - -and print_var_decl buffer {value; _} = +and print_var_decl state {value; _} = let {kwd_var; name; colon; var_type; assign; init; terminator} = value in - print_token buffer kwd_var "var"; - print_var buffer name; - print_token buffer colon ":"; - print_type_expr buffer var_type; - print_token buffer assign ":="; - print_expr buffer init; - print_terminator buffer terminator + print_token state kwd_var "var"; + print_var state name; + print_token state colon ":"; + print_type_expr state var_type; + print_token state assign ":="; + print_expr state init; + print_terminator state terminator -and print_statements buffer sequence = - print_nsepseq buffer ";" print_statement sequence +and print_statements state sequence = + print_nsepseq state ";" print_statement sequence -and print_statement buffer = function - Instr instr -> print_instruction buffer instr -| Data data -> print_data_decl buffer data +and print_statement state = function + Instr instr -> print_instruction state instr +| Data data -> print_data_decl state data -and print_instruction buffer = function - Cond {value; _} -> print_conditional buffer value -| CaseInstr {value; _} -> print_case_instr buffer value -| Assign assign -> print_assignment buffer assign -| Loop loop -> print_loop buffer loop -| ProcCall fun_call -> print_fun_call buffer fun_call -| Skip kwd_skip -> print_token buffer kwd_skip "skip" -| RecordPatch {value; _} -> print_record_patch buffer value -| MapPatch {value; _} -> print_map_patch buffer value -| SetPatch {value; _} -> print_set_patch buffer value -| MapRemove {value; _} -> print_map_remove buffer value -| SetRemove {value; _} -> print_set_remove buffer value +and print_instruction state = function + Cond {value; _} -> print_conditional state value +| CaseInstr {value; _} -> print_case_instr state value +| Assign assign -> print_assignment state assign +| Loop loop -> print_loop state loop +| ProcCall fun_call -> print_fun_call state fun_call +| Skip kwd_skip -> print_token state kwd_skip "skip" +| RecordPatch {value; _} -> print_record_patch state value +| MapPatch {value; _} -> print_map_patch state value +| SetPatch {value; _} -> print_set_patch state value +| MapRemove {value; _} -> print_map_remove state value +| SetRemove {value; _} -> print_set_remove state value -and print_cond_expr buffer (node: cond_expr) = - print_token buffer node.kwd_if "if"; - print_expr buffer node.test; - print_token buffer node.kwd_then "then"; - print_expr buffer node.ifso; - print_terminator buffer node.terminator; - print_token buffer node.kwd_else "else"; - print_expr buffer node.ifnot +and print_cond_expr state (node: cond_expr) = + print_token state node.kwd_if "if"; + print_expr state node.test; + print_token state node.kwd_then "then"; + print_expr state node.ifso; + print_terminator state node.terminator; + print_token state node.kwd_else "else"; + print_expr state node.ifnot -and print_conditional buffer (node: conditional) = - print_token buffer node.kwd_if "if"; - print_expr buffer node.test; - print_token buffer node.kwd_then "then"; - print_if_clause buffer node.ifso; - print_terminator buffer node.terminator; - print_token buffer node.kwd_else "else"; - print_if_clause buffer node.ifnot +and print_conditional state (node: conditional) = + print_token state node.kwd_if "if"; + print_expr state node.test; + print_token state node.kwd_then "then"; + print_if_clause state node.ifso; + print_terminator state node.terminator; + print_token state node.kwd_else "else"; + print_if_clause state node.ifnot -and print_if_clause buffer = function - ClauseInstr instr -> print_instruction buffer instr -| ClauseBlock block -> print_clause_block buffer block +and print_if_clause state = function + ClauseInstr instr -> print_instruction state instr +| ClauseBlock block -> print_clause_block state block -and print_clause_block buffer = function - LongBlock block -> print_block buffer (Some block) - | ShortBlock {value; _} -> +and print_clause_block state = function + LongBlock block -> + print_block state block +| ShortBlock {value; _} -> let {lbrace; inside; rbrace} = value in let statements, terminator = inside in - print_token buffer lbrace "{"; - print_statements buffer statements; - print_terminator buffer terminator; - print_token buffer rbrace "}" + print_token state lbrace "{"; + print_statements state statements; + print_terminator state terminator; + print_token state rbrace "}" -and print_case_instr buffer (node : if_clause case) = +and print_case_instr state (node : if_clause case) = let {kwd_case; expr; opening; lead_vbar; cases; closing} = node in - print_token buffer kwd_case "case"; - print_expr buffer expr; - print_opening buffer "of" opening; - print_token_opt buffer lead_vbar "|"; - print_cases_instr buffer cases; - print_closing buffer closing + 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 -and print_token_opt buffer = function +and print_token_opt state = function None -> fun _ -> () -| Some region -> print_token buffer region +| Some region -> print_token state region -and print_cases_instr buffer {value; _} = - print_nsepseq buffer "|" print_case_clause_instr value +and print_cases_instr state {value; _} = + print_nsepseq state "|" print_case_clause_instr value -and print_case_clause_instr buffer {value; _} = +and print_case_clause_instr state {value; _} = let {pattern; arrow; rhs} = value in - print_pattern buffer pattern; - print_token buffer arrow "->"; - print_if_clause buffer rhs + print_pattern state pattern; + print_token state arrow "->"; + print_if_clause state rhs -and print_assignment buffer {value; _} = +and print_assignment state {value; _} = let {lhs; assign; rhs} = value in - print_lhs buffer lhs; - print_token buffer assign ":="; - print_rhs buffer rhs + print_lhs state lhs; + print_token state assign ":="; + print_rhs state rhs -and print_rhs buffer e = print_expr buffer e +and print_rhs state e = print_expr state e -and print_lhs buffer = function - Path path -> print_path buffer path -| MapPath {value; _} -> print_map_lookup buffer value +and print_lhs state = function + Path path -> print_path state path +| MapPath {value; _} -> print_map_lookup state value -and print_loop buffer = function - While {value; _} -> print_while_loop buffer value -| For for_loop -> print_for_loop buffer for_loop +and print_loop state = function + While {value; _} -> print_while_loop state value +| For for_loop -> print_for_loop state for_loop -and print_while_loop buffer value = +and print_while_loop state value = let {kwd_while; cond; block} = value in - print_token buffer kwd_while "while"; - print_expr buffer cond; - print_block buffer (Some block) + print_token state kwd_while "while"; + print_expr state cond; + print_block state block -and print_for_loop buffer = function - ForInt for_int -> print_for_int buffer for_int -| ForCollect for_collect -> print_for_collect buffer for_collect +and print_for_loop state = function + ForInt for_int -> print_for_int state for_int +| ForCollect for_collect -> print_for_collect state for_collect -and print_for_int buffer ({value; _} : for_int reg) = +and print_for_int state ({value; _} : for_int reg) = let {kwd_for; assign; kwd_to; bound; block} = value in - print_token buffer kwd_for "for"; - print_var_assign buffer assign; - print_token buffer kwd_to "to"; - print_expr buffer bound; - print_block buffer (Some block) + print_token state kwd_for "for"; + print_var_assign state assign; + print_token state kwd_to "to"; + print_expr state bound; + print_block state block -and print_var_assign buffer {value; _} = +and print_var_assign state {value; _} = let {name; assign; expr} = value in - print_var buffer name; - print_token buffer assign ":="; - print_expr buffer expr + print_var state name; + print_token state assign ":="; + print_expr state expr -and print_for_collect buffer ({value; _} : for_collect reg) = +and print_for_collect state ({value; _} : for_collect reg) = let {kwd_for; var; bind_to; kwd_in; collection; expr; block} = value in - print_token buffer kwd_for "for"; - print_var buffer var; - print_bind_to buffer bind_to; - print_token buffer kwd_in "in"; - print_collection buffer collection; - print_expr buffer expr; - print_block buffer (Some block) + print_token state kwd_for "for"; + print_var state var; + print_bind_to state bind_to; + print_token state kwd_in "in"; + print_collection state collection; + print_expr state expr; + print_block state block -and print_collection buffer = function +and print_collection state = function Map kwd_map -> - print_token buffer kwd_map "map" + print_token state kwd_map "map" | Set kwd_set -> - print_token buffer kwd_set "set" + print_token state kwd_set "set" | List kwd_list -> - print_token buffer kwd_list "list" + print_token state kwd_list "list" -and print_bind_to buffer = function +and print_bind_to state = function Some (arrow, variable) -> - print_token buffer arrow "->"; - print_var buffer variable + print_token state arrow "->"; + print_var state variable | None -> () -and print_expr buffer = function - ECase {value;_} -> print_case_expr buffer value -| ECond {value;_} -> print_cond_expr buffer value -| EAnnot {value;_} -> print_annot_expr buffer value -| ELogic e -> print_logic_expr buffer e -| EArith e -> print_arith_expr buffer e -| EString e -> print_string_expr buffer e -| EList e -> print_list_expr buffer e -| ESet e -> print_set_expr buffer e -| EConstr e -> print_constr_expr buffer e -| ERecord e -> print_record_expr buffer e -| EProj e -> print_projection buffer e -| EMap e -> print_map_expr buffer e -| EVar v -> print_var buffer v -| ECall e -> print_fun_call buffer e -| EBytes b -> print_bytes buffer b -| EUnit r -> print_token buffer r "Unit" -| ETuple e -> print_tuple_expr buffer e -| EPar e -> print_par_expr buffer e -| EFun e -> print_fun_expr buffer e +and print_expr state = function + ECase {value;_} -> print_case_expr state value +| ECond {value;_} -> print_cond_expr state value +| EAnnot {value;_} -> print_annot_expr state value +| ELogic e -> print_logic_expr state e +| EArith e -> print_arith_expr state e +| EString e -> print_string_expr state e +| EList e -> print_list_expr state e +| ESet e -> print_set_expr state e +| EConstr e -> print_constr_expr state e +| ERecord e -> print_record_expr state e +| EProj e -> print_projection state e +| EMap e -> print_map_expr state e +| EVar v -> print_var state v +| ECall e -> print_fun_call state e +| EBytes b -> print_bytes state b +| EUnit r -> print_token state r "Unit" +| ETuple e -> print_tuple_expr state e +| EPar e -> print_par_expr state e +| EFun e -> print_fun_expr state e -and print_annot_expr buffer (expr , type_expr) = - print_expr buffer expr; - print_type_expr buffer type_expr +and print_annot_expr state (expr , type_expr) = + print_expr state expr; + print_type_expr state type_expr -and print_case_expr buffer (node : expr case) = +and print_case_expr state (node : expr case) = let {kwd_case; expr; opening; lead_vbar; cases; closing} = node in - print_token buffer kwd_case "case"; - print_expr buffer expr; - print_opening buffer "of" opening; - print_token_opt buffer lead_vbar "|"; - print_cases_expr buffer cases; - print_closing buffer closing + 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 -and print_cases_expr buffer {value; _} = - print_nsepseq buffer "|" print_case_clause_expr value +and print_cases_expr state {value; _} = + print_nsepseq state "|" print_case_clause_expr value -and print_case_clause_expr buffer {value; _} = +and print_case_clause_expr state {value; _} = let {pattern; arrow; rhs} = value in - print_pattern buffer pattern; - print_token buffer arrow "->"; - print_expr buffer rhs + print_pattern state pattern; + print_token state arrow "->"; + print_expr state rhs -and print_map_expr buffer = function - MapLookUp {value; _} -> print_map_lookup buffer value -| MapInj inj -> print_injection buffer "map" print_binding inj -| BigMapInj inj -> print_injection buffer "big_map" print_binding inj +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 -and print_set_expr buffer = function - SetInj inj -> print_injection buffer "set" print_expr inj -| SetMem mem -> print_set_membership buffer mem +and print_set_expr state = function + SetInj inj -> print_injection state "set" print_expr inj +| SetMem mem -> print_set_membership state mem -and print_set_membership buffer {value; _} = +and print_set_membership state {value; _} = let {set; kwd_contains; element} = value in - print_expr buffer set; - print_token buffer kwd_contains "contains"; - print_expr buffer element + print_expr state set; + print_token state kwd_contains "contains"; + print_expr state element -and print_map_lookup buffer {path; index} = +and print_map_lookup state {path; index} = let {lbracket; inside; rbracket} = index.value in - print_path buffer path; - print_token buffer lbracket "["; - print_expr buffer inside; - print_token buffer rbracket "]" + print_path state path; + print_token state lbracket "["; + print_expr state inside; + print_token state rbracket "]" -and print_path buffer = function - Name var -> print_var buffer var -| Path path -> print_projection buffer path +and print_path state = function + Name var -> print_var state var +| Path path -> print_projection state path -and print_logic_expr buffer = function - BoolExpr e -> print_bool_expr buffer e -| CompExpr e -> print_comp_expr buffer e +and print_logic_expr state = function + BoolExpr e -> print_bool_expr state e +| CompExpr e -> print_comp_expr state e -and print_bool_expr buffer = function +and print_bool_expr state = function Or {value = {arg1; op; arg2}; _} -> - print_expr buffer arg1; - print_token buffer op "||"; - print_expr buffer arg2 + print_expr state arg1; + print_token state op "||"; + print_expr state arg2 | And {value = {arg1; op; arg2}; _} -> - print_expr buffer arg1; - print_token buffer op "&&"; - print_expr buffer arg2 + print_expr state arg1; + print_token state op "&&"; + print_expr state arg2 | Not {value = {op; arg}; _} -> - print_token buffer op "not"; - print_expr buffer arg + print_token state op "not"; + print_expr state arg | False region -> - print_token buffer region "False" + print_token state region "False" | True region -> - print_token buffer region "True" + print_token state region "True" -and print_comp_expr buffer = function +and print_comp_expr state = function Lt {value = {arg1; op; arg2}; _} -> - print_expr buffer arg1; - print_token buffer op "<"; - print_expr buffer arg2 + print_expr state arg1; + print_token state op "<"; + print_expr state arg2 | Leq {value = {arg1; op; arg2}; _} -> - print_expr buffer arg1; - print_token buffer op "<="; - print_expr buffer arg2 + print_expr state arg1; + print_token state op "<="; + print_expr state arg2 | Gt {value = {arg1; op; arg2}; _} -> - print_expr buffer arg1; - print_token buffer op ">"; - print_expr buffer arg2 + print_expr state arg1; + print_token state op ">"; + print_expr state arg2 | Geq {value = {arg1; op; arg2}; _} -> - print_expr buffer arg1; - print_token buffer op ">="; - print_expr buffer arg2 + print_expr state arg1; + print_token state op ">="; + print_expr state arg2 | Equal {value = {arg1; op; arg2}; _} -> - print_expr buffer arg1; - print_token buffer op "="; - print_expr buffer arg2 + print_expr state arg1; + print_token state op "="; + print_expr state arg2 | Neq {value = {arg1; op; arg2}; _} -> - print_expr buffer arg1; - print_token buffer op "=/="; - print_expr buffer arg2 + print_expr state arg1; + print_token state op "=/="; + print_expr state arg2 -and print_arith_expr buffer = function +and print_arith_expr state = function Add {value = {arg1; op; arg2}; _} -> - print_expr buffer arg1; - print_token buffer op "+"; - print_expr buffer arg2 + print_expr state arg1; + print_token state op "+"; + print_expr state arg2 | Sub {value = {arg1; op; arg2}; _} -> - print_expr buffer arg1; - print_token buffer op "-"; - print_expr buffer arg2 + print_expr state arg1; + print_token state op "-"; + print_expr state arg2 | Mult {value = {arg1; op; arg2}; _} -> - print_expr buffer arg1; - print_token buffer op "*"; - print_expr buffer arg2 + print_expr state arg1; + print_token state op "*"; + print_expr state arg2 | Div {value = {arg1; op; arg2}; _} -> - print_expr buffer arg1; - print_token buffer op "/"; - print_expr buffer arg2 + print_expr state arg1; + print_token state op "/"; + print_expr state arg2 | Mod {value = {arg1; op; arg2}; _} -> - print_expr buffer arg1; - print_token buffer op "mod"; - print_expr buffer arg2 + print_expr state arg1; + print_token state op "mod"; + print_expr state arg2 | Neg {value = {op; arg}; _} -> - print_token buffer op "-"; - print_expr buffer arg + print_token state op "-"; + print_expr state arg | Int i | Nat i -| Mutez i -> print_int buffer i +| Mutez i -> print_int state i -and print_string_expr buffer = function +and print_string_expr state = function Cat {value = {arg1; op; arg2}; _} -> - print_expr buffer arg1; - print_token buffer op "^"; - print_expr buffer arg2 + print_expr state arg1; + print_token state op "^"; + print_expr state arg2 | String s -> - print_string buffer s + print_string state s -and print_list_expr buffer = function +and print_list_expr state = function ECons {value = {arg1; op; arg2}; _} -> - print_expr buffer arg1; - print_token buffer op "#"; - print_expr buffer arg2 -| EListComp e -> print_injection buffer "list" print_expr e -| ENil e -> print_nil buffer e + print_expr state arg1; + print_token state op "#"; + print_expr state arg2 +| EListComp e -> print_injection state "list" print_expr e +| ENil e -> print_nil state e -and print_constr_expr buffer = function - SomeApp e -> print_some_app buffer e -| NoneExpr e -> print_none_expr buffer e -| ConstrApp e -> print_constr_app buffer e +and print_constr_expr state = function + SomeApp e -> print_some_app state e +| NoneExpr e -> print_none_expr state e +| ConstrApp e -> print_constr_app state e -and print_record_expr buffer e = - print_ne_injection buffer "record" print_field_assign e +and print_record_expr state e = + print_ne_injection state "record" print_field_assign e -and print_field_assign buffer {value; _} = +and print_field_assign state {value; _} = let {field_name; equal; field_expr} = value in - print_var buffer field_name; - print_token buffer equal "="; - print_expr buffer field_expr + print_var state field_name; + print_token state equal "="; + print_expr state field_expr -and print_projection buffer {value; _} = +and print_projection state {value; _} = let {struct_name; selector; field_path} = value in - print_var buffer struct_name; - print_token buffer selector "."; - print_field_path buffer field_path + print_var state struct_name; + print_token state selector "."; + print_field_path state field_path -and print_field_path buffer sequence = - print_nsepseq buffer "." print_selection sequence +and print_field_path state sequence = + print_nsepseq state "." print_selection sequence -and print_selection buffer = function - FieldName name -> print_var buffer name -| Component int -> print_int buffer int +and print_selection state = function + FieldName name -> print_var state name +| Component int -> print_int state int -and print_record_patch buffer node = +and print_record_patch state node = let {kwd_patch; path; kwd_with; record_inj} = node in - print_token buffer kwd_patch "patch"; - print_path buffer path; - print_token buffer kwd_with "with"; - print_ne_injection buffer "record" print_field_assign record_inj + 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 -and print_set_patch buffer node = +and print_set_patch state node = let {kwd_patch; path; kwd_with; set_inj} = node in - print_token buffer kwd_patch "patch"; - print_path buffer path; - print_token buffer kwd_with "with"; - print_ne_injection buffer "set" print_expr set_inj + 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 -and print_map_patch buffer node = +and print_map_patch state node = let {kwd_patch; path; kwd_with; map_inj} = node in - print_token buffer kwd_patch "patch"; - print_path buffer path; - print_token buffer kwd_with "with"; - print_ne_injection buffer "map" print_binding map_inj + 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 -and print_map_remove buffer node = +and print_map_remove state node = let {kwd_remove; key; kwd_from; kwd_map; map} = node in - print_token buffer kwd_remove "remove"; - print_expr buffer key; - print_token buffer kwd_from "from"; - print_token buffer kwd_map "map"; - print_path buffer map + print_token state kwd_remove "remove"; + print_expr state key; + print_token state kwd_from "from"; + print_token state kwd_map "map"; + print_path state map -and print_set_remove buffer node = +and print_set_remove state node = let {kwd_remove; element; kwd_from; kwd_set; set} = node in - print_token buffer kwd_remove "remove"; - print_expr buffer element; - print_token buffer kwd_from "from"; - print_token buffer kwd_set "set"; - print_path buffer set + print_token state kwd_remove "remove"; + print_expr state element; + print_token state kwd_from "from"; + print_token state kwd_set "set"; + print_path state set and print_injection : - 'a.Buffer.t -> string -> (Buffer.t -> 'a -> unit) -> + 'a.state -> string -> (state -> 'a -> unit) -> 'a injection reg -> unit = - fun buffer kwd print {value; _} -> + fun state kwd print {value; _} -> let {opening; elements; terminator; closing} = value in - print_opening buffer kwd opening; - print_sepseq buffer ";" print elements; - print_terminator buffer terminator; - print_closing buffer closing + print_opening state kwd opening; + print_sepseq state ";" print elements; + print_terminator state terminator; + print_closing state closing and print_ne_injection : - 'a.Buffer.t -> string -> (Buffer.t -> 'a -> unit) -> + 'a.state -> string -> (state -> 'a -> unit) -> 'a ne_injection reg -> unit = - fun buffer kwd print {value; _} -> + fun state kwd print {value; _} -> let {opening; ne_elements; terminator; closing} = value in - print_opening buffer kwd opening; - print_nsepseq buffer ";" print ne_elements; - print_terminator buffer terminator; - print_closing buffer closing + print_opening state kwd opening; + print_nsepseq state ";" print ne_elements; + print_terminator state terminator; + print_closing state closing -and print_opening buffer lexeme = function +and print_opening state lexeme = function Kwd kwd -> - print_token buffer kwd lexeme + print_token state kwd lexeme | KwdBracket (kwd, lbracket) -> - print_token buffer kwd lexeme; - print_token buffer lbracket "{" + print_token state kwd lexeme; + print_token state lbracket "{" -and print_closing buffer = function - RBracket rbracket -> print_token buffer rbracket "}" -| End kwd_end -> print_token buffer kwd_end "end" +and print_closing state = function + RBracket rbracket -> print_token state rbracket "}" +| End kwd_end -> print_token state kwd_end "end" -and print_binding buffer {value; _} = +and print_binding state {value; _} = let {source; arrow; image} = value in - print_expr buffer source; - print_token buffer arrow "->"; - print_expr buffer image + print_expr state source; + print_token state arrow "->"; + print_expr state image -and print_tuple_expr buffer {value; _} = +and print_tuple_expr state {value; _} = let {lpar; inside; rpar} = value in - print_token buffer lpar "("; - print_nsepseq buffer "," print_expr inside; - print_token buffer rpar ")" + print_token state lpar "("; + print_nsepseq state "," print_expr inside; + print_token state rpar ")" -and print_nil buffer value = print_token buffer value "nil" +and print_nil state value = print_token state value "nil" -and print_none_expr buffer value = print_token buffer value "None" +and print_none_expr state value = print_token state value "None" -and print_fun_call buffer {value; _} = +and print_fun_call state {value; _} = let expr, arguments = value in - print_expr buffer expr; - print_tuple_expr buffer arguments + print_expr state expr; + print_tuple_expr state arguments -and print_constr_app buffer {value; _} = +and print_constr_app state {value; _} = let constr, arguments = value in - print_constr buffer constr; + print_constr state constr; match arguments with None -> () - | Some arg -> print_tuple_expr buffer arg + | Some arg -> print_tuple_expr state arg -and print_some_app buffer {value; _} = +and print_some_app state {value; _} = let c_Some, arguments = value in - print_token buffer c_Some "Some"; - print_tuple_expr buffer arguments + print_token state c_Some "Some"; + print_tuple_expr state arguments -and print_par_expr buffer {value; _} = +and print_par_expr state {value; _} = let {lpar; inside; rpar} = value in - print_token buffer lpar "("; - print_expr buffer inside; - print_token buffer rpar ")" + print_token state lpar "("; + print_expr state inside; + print_token state rpar ")" -and print_pattern buffer = function - PVar var -> print_var buffer var -| PWild wild -> print_token buffer wild "_" -| PInt i -> print_int buffer i -| PNat n -> print_nat buffer n -| PBytes b -> print_bytes buffer b -| PString s -> print_string buffer s -| PList pattern -> print_list_pattern buffer pattern -| PTuple ptuple -> print_ptuple buffer ptuple -| PConstr pattern -> print_constr_pattern buffer pattern +and print_pattern state = function + PVar var -> print_var state var +| PWild wild -> print_token state wild "_" +| PInt i -> print_int state i +| PNat n -> print_nat state n +| PBytes b -> print_bytes state b +| PString s -> print_string state s +| PList pattern -> print_list_pattern state pattern +| PTuple ptuple -> print_ptuple state ptuple +| PConstr pattern -> print_constr_pattern state pattern -and print_constr_pattern buffer = function - PUnit region -> print_token buffer region "Unit" -| PFalse region -> print_token buffer region "False" -| PTrue region -> print_token buffer region "True" -| PNone region -> print_token buffer region "None" -| PSomeApp psome -> print_psome buffer psome +and print_constr_pattern state = function + PUnit region -> print_token state region "Unit" +| PFalse region -> print_token state region "False" +| PTrue region -> print_token state region "True" +| PNone region -> print_token state region "None" +| PSomeApp psome -> print_psome state psome | PConstrApp {value; _} -> let constr, arg = value in - print_constr buffer constr; + print_constr state constr; match arg with None -> () - | Some tuple -> print_ptuple buffer tuple + | Some tuple -> print_ptuple state tuple -and print_psome buffer {value; _} = +and print_psome state {value; _} = let c_Some, patterns = value in - print_token buffer c_Some "Some"; - print_patterns buffer patterns + print_token state c_Some "Some"; + print_patterns state patterns -and print_patterns buffer {value; _} = +and print_patterns state {value; _} = let {lpar; inside; rpar} = value in - print_token buffer lpar "("; - print_pattern buffer inside; - print_token buffer rpar ")" + print_token state lpar "("; + print_pattern state inside; + print_token state rpar ")" -and print_list_pattern buffer = function +and print_list_pattern state = function PListComp comp -> - print_injection buffer "list" print_pattern comp + print_injection state "list" print_pattern comp | PNil kwd_nil -> - print_token buffer kwd_nil "nil" + print_token state kwd_nil "nil" | PParCons cons -> - print_par_cons buffer cons + print_par_cons state cons | PCons {value; _} -> - print_nsepseq buffer "#" print_pattern value + print_nsepseq state "#" print_pattern value -and print_par_cons buffer {value; _} = +and print_par_cons state {value; _} = let {lpar; inside; rpar} = value in let head, cons, tail = inside in - print_token buffer lpar "("; - print_pattern buffer head; - print_token buffer cons "#"; - print_pattern buffer tail; - print_token buffer rpar ")" + print_token state lpar "("; + print_pattern state head; + print_token state cons "#"; + print_pattern state tail; + print_token state rpar ")" -and print_ptuple buffer {value; _} = +and print_ptuple state {value; _} = let {lpar; inside; rpar} = value in - print_token buffer lpar "("; - print_nsepseq buffer "," print_pattern inside; - print_token buffer rpar ")" + print_token state lpar "("; + print_nsepseq state "," print_pattern inside; + print_token state rpar ")" -and print_terminator buffer = function - Some semi -> print_token buffer semi ";" +and print_terminator state = function + Some semi -> print_token state semi ";" | None -> () (* Conversion to string *) -let to_string printer node = +let to_string ~offsets ~mode printer node = let buffer = Buffer.create 131 in - let () = printer buffer node + let state = mk_state ~offsets ~mode ~buffer in + let () = printer state node in Buffer.contents buffer -let tokens_to_string = to_string print_tokens -let path_to_string = to_string print_path -let pattern_to_string = to_string print_pattern -let instruction_to_string = to_string print_instruction +let tokens_to_string ~offsets ~mode = + to_string ~offsets ~mode print_tokens +let path_to_string ~offsets ~mode = + to_string ~offsets ~mode print_path +let pattern_to_string ~offsets ~mode = + to_string ~offsets ~mode print_pattern +let instruction_to_string ~offsets ~mode = + to_string ~offsets ~mode print_instruction -(* Pretty-printing the AST *) +(** {1 Pretty-printing the AST} *) -(* The function [mk_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?). *) -let mk_pad len rank pc = - pc ^ (if rank = len-1 then "`-- " else "|-- "), - pc ^ (if rank = len-1 then " " else "| ") +let pp_ident state {value=name; region} = + let reg = compact state region in + let node = sprintf "%s%s (%s)\n" state#pad_path name reg + in Buffer.add_string state#buffer node -let pp_ident buffer ~pad:(pd,_) Region.{value=name; region} = - let node = sprintf "%s%s (%s)\n" pd name (region#compact `Byte) - in Buffer.add_string buffer node +let pp_node state name = + let node = sprintf "%s%s\n" state#pad_path name + in Buffer.add_string state#buffer node -let pp_node buffer ~pad:(pd,_) name = - let node = sprintf "%s%s\n" pd name - in Buffer.add_string buffer node +let pp_string state = pp_ident state -let pp_string buffer = pp_ident buffer +let pp_loc_node state name region = + pp_ident state {value=name; region} -let pp_loc_node buffer ~pad name region = - pp_ident buffer ~pad Region.{value=name; region} - -let rec pp_ast buffer ~pad:(_,pc as pad) {decl; _} = +let rec pp_ast state {decl; _} = let apply len rank = - let pad = mk_pad len rank pc in - pp_declaration buffer ~pad in + pp_declaration (state#pad len rank) in let decls = Utils.nseq_to_list decl in - pp_node buffer ~pad ""; + pp_node state ""; List.iteri (List.length decls |> apply) decls -and pp_declaration buffer ~pad:(_,pc as pad) = function +and pp_declaration state = function TypeDecl {value; region} -> - pp_loc_node buffer ~pad "TypeDecl" region; - pp_ident buffer ~pad:(mk_pad 2 0 pc) value.name; - pp_type_expr buffer ~pad:(mk_pad 2 1 pc) value.type_expr + pp_loc_node state "TypeDecl" region; + pp_ident (state#pad 2 0) value.name; + pp_type_expr (state#pad 2 1) value.type_expr | ConstDecl {value; region} -> - pp_loc_node buffer ~pad "ConstDecl" region; - pp_const_decl buffer ~pad value + pp_loc_node state "ConstDecl" region; + pp_const_decl state value | FunDecl {value; region} -> - pp_loc_node buffer ~pad "FunDecl" region; - pp_fun_expr buffer ~pad value.fun_expr.value + pp_loc_node state "FunDecl" region; + pp_fun_expr state value.fun_expr.value -and pp_const_decl buffer ~pad:(_,pc) decl = - pp_ident buffer ~pad:(mk_pad 3 0 pc) decl.name; - pp_type_expr buffer ~pad:(mk_pad 3 1 pc) decl.const_type; - pp_expr buffer ~pad:(mk_pad 3 2 pc) decl.init +and pp_const_decl state decl = + pp_ident (state#pad 3 0) decl.name; + pp_type_expr (state#pad 3 1) decl.const_type; + pp_expr (state#pad 3 2) decl.init -and pp_type_expr buffer ~pad:(_,pc as pad) = function +and pp_type_expr state = function TProd cartesian -> - pp_loc_node buffer ~pad "TProd" cartesian.region; - pp_cartesian buffer ~pad cartesian + pp_loc_node state "TProd" cartesian.region; + pp_cartesian state cartesian | TVar v -> - pp_node buffer ~pad "TVar"; - pp_ident buffer ~pad:(mk_pad 1 0 pc) v + pp_node state "TVar"; + pp_ident (state#pad 1 0) v | TPar {value; region} -> - pp_loc_node buffer ~pad "TPar" region; - pp_type_expr buffer ~pad:(mk_pad 1 0 pc) value.inside + pp_loc_node state "TPar" region; + pp_type_expr (state#pad 1 0) value.inside | TApp {value=name,tuple; region} -> - pp_loc_node buffer ~pad "TApp" region; - pp_ident buffer ~pad:(mk_pad 1 0 pc) name; - pp_type_tuple buffer ~pad:(mk_pad 2 1 pc) tuple + pp_loc_node state "TApp" region; + pp_ident (state#pad 1 0) name; + pp_type_tuple (state#pad 2 1) tuple | TFun {value; region} -> - pp_loc_node buffer ~pad "TFun" region; + pp_loc_node state "TFun" region; let apply len rank = - let pad = mk_pad len rank pc in - pp_type_expr buffer ~pad in + pp_type_expr (state#pad len rank) in let domain, _, range = value in List.iteri (apply 2) [domain; range] | TSum {value; region} -> - pp_loc_node buffer ~pad "TSum" region; + pp_loc_node state "TSum" region; let apply len rank variant = - let pad = mk_pad len rank pc in - pp_variant buffer ~pad variant.value in + pp_variant (state#pad len rank) variant.value in let variants = Utils.nsepseq_to_list value in List.iteri (List.length variants |> apply) variants | TRecord {value; region} -> - pp_loc_node buffer ~pad "TRecord" region; + pp_loc_node state "TRecord" region; let apply len rank field_decl = - pp_field_decl buffer ~pad:(mk_pad len rank pc) + pp_field_decl (state#pad len rank) field_decl.value in let fields = Utils.nsepseq_to_list value.ne_elements in List.iteri (List.length fields |> apply) fields -and pp_cartesian buffer ~pad:(_,pc) {value; _} = +and pp_cartesian state {value; _} = let apply len rank = - pp_type_expr buffer ~pad:(mk_pad len rank pc) in + pp_type_expr (state#pad len rank) in let components = Utils.nsepseq_to_list value in List.iteri (List.length components |> apply) components -and pp_variant buffer ~pad:(_,pc as pad) {constr; arg} = - pp_ident buffer ~pad constr; +and pp_variant state {constr; arg} = + pp_ident state constr; match arg with None -> () - | Some (_,c) -> - pp_type_expr buffer ~pad:(mk_pad 1 0 pc) c + | Some (_,c) -> pp_type_expr (state#pad 1 0) c -and pp_field_decl buffer ~pad:(_,pc as pad) decl = - pp_ident buffer ~pad decl.field_name; - pp_type_expr buffer ~pad:(mk_pad 1 0 pc) decl.field_type +and pp_field_decl state decl = + pp_ident state decl.field_name; + pp_type_expr (state#pad 1 0) decl.field_type -and pp_type_tuple buffer ~pad:(_,pc) {value; _} = +and pp_type_tuple state {value; _} = let components = Utils.nsepseq_to_list value.inside in - let apply len rank = - pp_type_expr buffer ~pad:(mk_pad len rank pc) + let apply len rank = pp_type_expr (state#pad len rank) in List.iteri (List.length components |> apply) components -and pp_fun_expr buffer ~pad:(_,pc) decl = - let fields = - if decl.local_decls = [] then 5 else 6 in +and pp_fun_expr state decl = let () = - let pad = mk_pad fields 0 pc in - let anonymous_name = Region.wrap_ghost "#anonymous" in - pp_ident buffer ~pad @@ Simple_utils.Option.unopt ~default:anonymous_name decl.name in + let state = state#pad 5 0 in + match decl.name with + None -> pp_ident state (Region.wrap_ghost "#anon") + | Some var -> pp_ident state var in let () = - let pad = mk_pad fields 1 pc in - pp_node buffer ~pad ""; - pp_parameters buffer ~pad decl.param in + let state = state#pad 5 1 in + pp_node state ""; + pp_parameters state decl.param in let () = - let _, pc as pad = mk_pad fields 2 pc in - pp_node buffer ~pad ""; - pp_type_expr buffer ~pad:(mk_pad 1 0 pc) decl.ret_type in + let state = state#pad 5 2 in + pp_node state ""; + pp_type_expr (state#pad 1 0) decl.ret_type in let () = - if fields = 6 then - let pad = mk_pad fields 3 pc in - pp_node buffer ~pad ""; - pp_local_decls buffer ~pad decl.local_decls in - let () = - let pad = mk_pad fields (fields - 2) pc in - pp_node buffer ~pad ""; + let state = state#pad 5 3 in + pp_node state ""; let statements = - match decl.block with - Some block -> block.value.statements + match decl.block_with with + Some (block,_) -> block.value.statements | None -> Instr (Skip Region.ghost), [] in - pp_statements buffer ~pad statements in + pp_statements state statements in let () = - let _, pc as pad = mk_pad fields (fields - 1) pc in - pp_node buffer ~pad ""; - pp_expr buffer ~pad:(mk_pad 1 0 pc) decl.return + let state = state#pad 5 4 in + pp_node state ""; + pp_expr (state#pad 1 0) decl.return in () -and pp_parameters buffer ~pad:(_,pc) {value; _} = +and pp_parameters state {value; _} = let params = Utils.nsepseq_to_list value.inside in let arity = List.length params in - let apply len rank = - pp_param_decl buffer ~pad:(mk_pad len rank pc) + let apply len rank = pp_param_decl (state#pad len rank) in List.iteri (apply arity) params -and pp_param_decl buffer ~pad:(_,pc as pad) = function +and pp_param_decl state = function ParamConst {value; region} -> - pp_loc_node buffer ~pad "ParamConst" region; - pp_ident buffer ~pad:(mk_pad 2 0 pc) value.var; - pp_type_expr buffer ~pad:(mk_pad 2 1 pc) value.param_type + pp_loc_node state "ParamConst" region; + pp_ident (state#pad 2 0) value.var; + pp_type_expr (state#pad 2 1) value.param_type | ParamVar {value; region} -> - pp_loc_node buffer ~pad "ParamVar" region; - pp_ident buffer ~pad:(mk_pad 2 0 pc) value.var; - pp_type_expr buffer ~pad:(mk_pad 2 1 pc) value.param_type + pp_loc_node state "ParamVar" region; + pp_ident (state#pad 2 0) value.var; + pp_type_expr (state#pad 2 1) value.param_type -and pp_statements buffer ~pad:(_,pc) statements = +and pp_statements state statements = let statements = Utils.nsepseq_to_list statements in let length = List.length statements in - let apply len rank = - pp_statement buffer ~pad:(mk_pad len rank pc) + let apply len rank = pp_statement (state#pad len rank) in List.iteri (apply length) statements -and pp_statement buffer ~pad:(_,pc as pad) = function +and pp_statement state = function Instr instr -> - pp_node buffer ~pad "Instr"; - pp_instruction buffer ~pad:(mk_pad 1 0 pc) instr + pp_node state "Instr"; + pp_instruction (state#pad 1 0) instr | Data data_decl -> - pp_node buffer ~pad "Data"; - pp_data_decl buffer ~pad:(mk_pad 1 0 pc) data_decl + pp_node state "Data"; + pp_data_decl (state#pad 1 0) data_decl -and pp_instruction buffer ~pad:(_,pc as pad) = function +and pp_instruction state = function Cond {value; region} -> - pp_loc_node buffer ~pad "Cond" region; - pp_conditional buffer ~pad value + pp_loc_node state "Cond" region; + pp_conditional state value | CaseInstr {value; region} -> - pp_loc_node buffer ~pad "CaseInstr" region; - pp_case pp_if_clause buffer ~pad value + pp_loc_node state "CaseInstr" region; + pp_case pp_if_clause state value | Assign {value; region} -> - pp_loc_node buffer ~pad "Assign" region; - pp_assignment buffer ~pad value + pp_loc_node state "Assign" region; + pp_assignment state value | Loop loop -> - pp_node buffer ~pad "Loop"; - pp_loop buffer ~pad:(mk_pad 1 0 pc) loop + pp_node state "Loop"; + pp_loop (state#pad 1 0) loop | ProcCall {value; region} -> - pp_loc_node buffer ~pad "ProcCall" region; - pp_fun_call buffer ~pad value + pp_loc_node state "ProcCall" region; + pp_fun_call state value | Skip region -> - pp_loc_node buffer ~pad "Skip" region + pp_loc_node state "Skip" region | RecordPatch {value; region} -> - pp_loc_node buffer ~pad "RecordPatch" region; - pp_record_patch buffer ~pad value + pp_loc_node state "RecordPatch" region; + pp_record_patch state value | MapPatch {value; region} -> - pp_loc_node buffer ~pad "MapPatch" region; - pp_map_patch buffer ~pad value + pp_loc_node state "MapPatch" region; + pp_map_patch state value | SetPatch {value; region} -> - pp_loc_node buffer ~pad "SetPatch" region; - pp_set_patch buffer ~pad value + pp_loc_node state "SetPatch" region; + pp_set_patch state value | MapRemove {value; region} -> - pp_loc_node buffer ~pad "MapRemove" region; - pp_map_remove buffer ~pad value + pp_loc_node state "MapRemove" region; + pp_map_remove state value | SetRemove {value; region} -> - pp_loc_node buffer ~pad "SetRemove" region; - pp_set_remove buffer ~pad value + pp_loc_node state "SetRemove" region; + pp_set_remove state value -and pp_cond_expr buffer ~pad:(_,pc) (cond: cond_expr) = +and pp_cond_expr state (cond: cond_expr) = let () = - let _, pc as pad = mk_pad 3 0 pc in - pp_node buffer ~pad ""; - pp_expr buffer ~pad:(mk_pad 1 0 pc) cond.test in + let state = state#pad 3 0 in + pp_node state ""; + pp_expr (state#pad 1 0) cond.test in let () = - let _, pc as pad = mk_pad 3 1 pc in - pp_node buffer ~pad ""; - pp_expr buffer ~pad:(mk_pad 1 0 pc) cond.ifso in + let state = state#pad 3 1 in + pp_node state ""; + pp_expr (state#pad 1 0) cond.ifso in let () = - let _, pc as pad = mk_pad 3 2 pc in - pp_node buffer ~pad ""; - pp_expr buffer ~pad:(mk_pad 1 0 pc) cond.ifnot + let state = state#pad 3 2 in + pp_node state ""; + pp_expr (state#pad 1 0) cond.ifnot in () -and pp_conditional buffer ~pad:(_,pc) (cond: conditional) = +and pp_conditional state (cond: conditional) = let () = - let _, pc as pad = mk_pad 3 0 pc in - pp_node buffer ~pad ""; - pp_expr buffer ~pad:(mk_pad 1 0 pc) cond.test in + let state = state#pad 3 0 in + pp_node state ""; + pp_expr (state#pad 1 0) cond.test in let () = - let _, pc as pad = mk_pad 3 1 pc in - pp_node buffer ~pad ""; - pp_if_clause buffer ~pad:(mk_pad 1 0 pc) cond.ifso in + let state = state#pad 3 1 in + pp_node state ""; + pp_if_clause (state#pad 1 0) cond.ifso in let () = - let _, pc as pad = mk_pad 3 2 pc in - pp_node buffer ~pad ""; - pp_if_clause buffer ~pad:(mk_pad 1 0 pc) cond.ifnot + let state = state#pad 3 2 in + pp_node state ""; + pp_if_clause (state#pad 1 0) cond.ifnot in () -and pp_if_clause buffer ~pad:(_,pc as pad) = function +and pp_if_clause state = function ClauseInstr instr -> - pp_node buffer ~pad "ClauseInstr"; - pp_instruction buffer ~pad:(mk_pad 1 0 pc) instr + pp_node state "ClauseInstr"; + pp_instruction (state#pad 1 0) instr | ClauseBlock block -> - pp_node buffer ~pad "ClauseBlock"; - pp_clause_block buffer ~pad:(mk_pad 1 0 pc) block + pp_node state "ClauseBlock"; + pp_clause_block (state#pad 1 0) block -and pp_clause_block buffer ~pad = function +and pp_clause_block state = function LongBlock {value; region} -> - pp_loc_node buffer ~pad "LongBlock" region; - pp_statements buffer ~pad value.statements + pp_loc_node state "LongBlock" region; + pp_statements state value.statements | ShortBlock {value; region} -> - pp_loc_node buffer ~pad "ShortBlock" region; - pp_statements buffer ~pad (fst value.inside) + pp_loc_node state "ShortBlock" region; + pp_statements state (fst value.inside) and pp_case : - 'a.(Buffer.t -> pad:(string*string) -> 'a -> unit) - -> Buffer.t -> pad:(string*string) -> 'a case -> unit = - fun printer buffer ~pad:(_,pc) case -> + 'a.(state -> 'a -> unit) -> state -> 'a case -> unit = + fun printer state case -> let clauses = Utils.nsepseq_to_list case.cases.value in let clauses = List.map (fun {value; _} -> value) clauses in let length = List.length clauses + 1 in let apply len rank = - pp_case_clause printer buffer ~pad:(mk_pad len (rank+1) pc) - in pp_expr buffer ~pad:(mk_pad length 0 pc) case.expr; + let state = state#pad len (rank+1) + in pp_case_clause printer state + in pp_expr (state#pad length 0) case.expr; List.iteri (apply length) clauses and pp_case_clause : - 'a.(Buffer.t -> pad:(string*string) -> 'a -> unit) - -> Buffer.t -> pad:(string*string) -> 'a case_clause -> unit = - fun printer buffer ~pad:(_,pc as pad) clause -> - pp_node buffer ~pad ""; - pp_pattern buffer ~pad:(mk_pad 2 0 pc) clause.pattern; - printer buffer ~pad:(mk_pad 2 1 pc) clause.rhs + 'a.(state -> 'a -> unit) -> state -> 'a case_clause -> unit = + fun printer state clause -> + pp_node state ""; + pp_pattern (state#pad 2 0) clause.pattern; + printer (state#pad 2 1) clause.rhs -and pp_pattern buffer ~pad:(_,pc as pad) = function +and pp_pattern state = function PWild region -> - pp_loc_node buffer ~pad "PWild" region + pp_loc_node state "PWild" region | PConstr pattern -> - pp_node buffer ~pad "PConstr"; - pp_constr_pattern buffer ~pad:(mk_pad 1 0 pc) pattern + pp_node state "PConstr"; + pp_constr_pattern (state#pad 1 0) pattern | PVar v -> - pp_node buffer ~pad "PVar"; - pp_ident buffer ~pad:(mk_pad 1 0 pc) v + pp_node state "PVar"; + pp_ident (state#pad 1 0) v | PInt n -> - pp_node buffer ~pad "PInt"; - pp_int buffer ~pad n + pp_node state "PInt"; + pp_int state n | PNat n -> - pp_node buffer ~pad "PNat"; - pp_int buffer ~pad n + pp_node state "PNat"; + pp_int state n | PBytes b -> - pp_node buffer ~pad "PBytes"; - pp_bytes buffer ~pad b + pp_node state "PBytes"; + pp_bytes state b | PString s -> - pp_node buffer ~pad "PString"; - pp_ident buffer ~pad:(mk_pad 1 0 pc) s + pp_node state "PString"; + pp_ident (state#pad 1 0) s | PList plist -> - pp_node buffer ~pad "PList"; - pp_list_pattern buffer ~pad:(mk_pad 1 0 pc) plist + pp_node state "PList"; + pp_list_pattern (state#pad 1 0) plist | PTuple {value; region} -> - pp_loc_node buffer ~pad "PTuple" region; - pp_tuple_pattern buffer ~pad:(mk_pad 1 0 pc) value + pp_loc_node state "PTuple" region; + pp_tuple_pattern (state#pad 1 0) value -and pp_bytes buffer ~pad:(_,pc) {value=lexeme,hex; region} = - pp_loc_node buffer ~pad:(mk_pad 2 0 pc) lexeme region; - pp_node buffer ~pad:(mk_pad 2 1 pc) (Hex.to_string hex) +and pp_bytes state {value=lexeme,hex; region} = + pp_loc_node (state#pad 2 0) lexeme region; + pp_node (state#pad 2 1) (Hex.to_string hex) -and pp_int buffer ~pad:(_,pc) {value=lexeme,z; region} = - pp_loc_node buffer ~pad:(mk_pad 2 0 pc) lexeme region; - pp_node buffer ~pad:(mk_pad 2 1 pc) (Z.to_string z) +and pp_int state {value=lexeme,z; region} = + pp_loc_node (state#pad 2 0) lexeme region; + pp_node (state#pad 2 1) (Z.to_string z) -and pp_constr_pattern buffer ~pad:(_,pc as pad) = function +and pp_constr_pattern state = function PNone region -> - pp_loc_node buffer ~pad "PNone" region + pp_loc_node state "PNone" region | PSomeApp {value=_,{value=par; _}; region} -> - pp_loc_node buffer ~pad "PSomeApp" region; - pp_pattern buffer ~pad:(mk_pad 1 0 pc) par.inside + pp_loc_node state "PSomeApp" region; + pp_pattern (state#pad 1 0) par.inside | PUnit region -> - pp_loc_node buffer ~pad "PUnit" region + pp_loc_node state "PUnit" region | PFalse region -> - pp_loc_node buffer ~pad "PFalse" region + pp_loc_node state "PFalse" region | PTrue region -> - pp_loc_node buffer ~pad "PTrue" region + pp_loc_node state "PTrue" region | PConstrApp {value; region} -> - pp_loc_node buffer ~pad "PConstrApp" region; - pp_constr_app_pattern buffer ~pad:(mk_pad 1 0 pc) value + pp_loc_node state "PConstrApp" region; + pp_constr_app_pattern (state#pad 1 0) value -and pp_constr_app_pattern buffer ~pad (constr, pat_opt) = - pp_ident buffer ~pad constr; +and pp_constr_app_pattern state (constr, pat_opt) = + pp_ident state constr; match pat_opt with None -> () - | Some {value; _} -> pp_tuple_pattern buffer ~pad value + | Some {value; _} -> pp_tuple_pattern state value -and pp_list_pattern buffer ~pad:(_,pc as pad) = function +and pp_list_pattern state = function PListComp {value; region} -> - pp_loc_node buffer ~pad "PListComp" region; - pp_injection pp_pattern buffer ~pad:(mk_pad 1 0 pc) value + pp_loc_node state "PListComp" region; + pp_injection pp_pattern (state#pad 1 0) value | PNil region -> - pp_loc_node buffer ~pad "PNil" region + pp_loc_node state "PNil" region | PParCons {value; region} -> - pp_loc_node buffer ~pad "PParCons" region; - pp_bin_cons buffer ~pad:(mk_pad 1 0 pc) value.inside + pp_loc_node state "PParCons" region; + pp_bin_cons (state#pad 1 0) value.inside | PCons {value; region} -> let patterns = Utils.nsepseq_to_list value in let length = List.length patterns in let apply len rank = - pp_pattern buffer ~pad:(mk_pad len rank pc) in - pp_loc_node buffer ~pad "PCons" region; + pp_pattern (state#pad len rank) in + pp_loc_node state "PCons" region; List.iteri (apply length) patterns -and pp_bin_cons buffer ~pad:(_,pc) (head, _, tail) = - pp_pattern buffer ~pad:(mk_pad 2 0 pc) head; - pp_pattern buffer ~pad:(mk_pad 2 1 pc) tail +and pp_bin_cons state (head, _, tail) = + pp_pattern (state#pad 2 0) head; + pp_pattern (state#pad 2 1) tail and pp_injection : - 'a.(Buffer.t -> pad:(string*string) -> 'a -> unit) - -> Buffer.t -> pad:(string*string) -> 'a injection -> unit = - fun printer buffer ~pad:(_,pc) inj -> - let elements = Utils.sepseq_to_list inj.elements in - let length = List.length elements in - let apply len rank = printer buffer ~pad:(mk_pad len rank pc) + 'a.(state -> 'a -> unit) -> state -> 'a injection -> unit = + fun printer state inj -> + let elements = Utils.sepseq_to_list inj.elements in + let length = List.length elements in + let apply len rank = printer (state#pad len rank) in List.iteri (apply length) elements and pp_ne_injection : - 'a.(Buffer.t -> pad:(string*string) -> 'a -> unit) - -> Buffer.t -> pad:(string*string) -> 'a ne_injection -> unit = - fun printer buffer ~pad:(_,pc) inj -> - let ne_elements = Utils.nsepseq_to_list inj.ne_elements in - let length = List.length ne_elements in - let apply len rank = printer buffer ~pad:(mk_pad len rank pc) + 'a.(state -> 'a -> unit) -> state -> 'a ne_injection -> unit = + fun printer state inj -> + let ne_elements = Utils.nsepseq_to_list inj.ne_elements in + let length = List.length ne_elements in + let apply len rank = printer (state#pad len rank) in List.iteri (apply length) ne_elements -and pp_tuple_pattern buffer ~pad:(_,pc) tuple = - let patterns = Utils.nsepseq_to_list tuple.inside in - let length = List.length patterns in - let apply len rank = - pp_pattern buffer ~pad:(mk_pad len rank pc) +and pp_tuple_pattern state tuple = + let patterns = Utils.nsepseq_to_list tuple.inside in + let length = List.length patterns in + let apply len rank = pp_pattern (state#pad len rank) in List.iteri (apply length) patterns -and pp_assignment buffer ~pad:(_,pc) asgn = - pp_lhs buffer ~pad:(mk_pad 2 0 pc) asgn.lhs; - pp_expr buffer ~pad:(mk_pad 2 1 pc) asgn.rhs +and pp_assignment state asgn = + pp_lhs (state#pad 2 0) asgn.lhs; + pp_expr (state#pad 2 1) asgn.rhs -and pp_lhs buffer ~pad:(_,pc as pad) = function +and pp_lhs state = function Path path -> - pp_node buffer ~pad "Path"; - pp_path buffer ~pad:(mk_pad 1 0 pc) path + pp_node state "Path"; + pp_path (state#pad 1 0) path | MapPath {value; region} -> - pp_loc_node buffer ~pad "MapPath" region; - pp_map_lookup buffer ~pad value + pp_loc_node state "MapPath" region; + pp_map_lookup state value -and pp_path buffer ~pad:(_,pc as pad) = function +and pp_path state = function Name name -> - pp_node buffer ~pad "Name"; - pp_ident buffer ~pad:(mk_pad 1 0 pc) name + pp_node state "Name"; + pp_ident (state#pad 1 0) name | Path {value; region} -> - pp_loc_node buffer ~pad "Path" region; - pp_projection buffer ~pad value + pp_loc_node state "Path" region; + pp_projection state value -and pp_projection buffer ~pad:(_,pc) proj = - let selections = Utils.nsepseq_to_list proj.field_path in - let len = List.length selections in - let apply len rank = - pp_selection buffer ~pad:(mk_pad len rank pc) in - pp_ident buffer ~pad:(mk_pad (1+len) 0 pc) proj.struct_name; +and pp_projection state proj = + let selections = Utils.nsepseq_to_list proj.field_path in + let len = List.length selections in + let apply len rank = pp_selection (state#pad len rank) in + pp_ident (state#pad (1+len) 0) proj.struct_name; List.iteri (apply len) selections -and pp_selection buffer ~pad:(_,pc as pad) = function +and pp_selection state = function FieldName name -> - pp_node buffer ~pad "FieldName"; - pp_ident buffer ~pad:(mk_pad 1 0 pc) name + pp_node state "FieldName"; + pp_ident (state#pad 1 0) name | Component comp -> - pp_node buffer ~pad "Component"; - pp_int buffer ~pad comp + pp_node state "Component"; + pp_int state comp -and pp_map_lookup buffer ~pad:(_,pc) lookup = - pp_path buffer ~pad:(mk_pad 2 0 pc) lookup.path; - pp_expr buffer ~pad:(mk_pad 2 1 pc) lookup.index.value.inside +and pp_map_lookup state lookup = + pp_path (state#pad 2 0) lookup.path; + pp_expr (state#pad 2 1) lookup.index.value.inside -and pp_loop buffer ~pad:(_,pc as pad) = function +and pp_loop state = function While {value; _} -> - pp_node buffer ~pad ""; + pp_node state ""; let () = - let _, pc as pad = mk_pad 2 0 pc in - pp_node buffer ~pad ""; - pp_expr buffer ~pad:(mk_pad 1 0 pc) value.cond in + let state = state#pad 2 0 in + pp_node state ""; + pp_expr (state#pad 1 0) value.cond in let () = - let pad = mk_pad 2 1 pc in + let state = state#pad 2 1 in let statements = value.block.value.statements in - pp_node buffer ~pad ""; - pp_statements buffer ~pad statements + pp_node state ""; + pp_statements state statements in () | For for_loop -> - pp_node buffer ~pad ""; - pp_for_loop buffer ~pad:(mk_pad 1 0 pc) for_loop + pp_node state ""; + pp_for_loop (state#pad 1 0) for_loop -and pp_for_loop buffer ~pad = function +and pp_for_loop state = function ForInt {value; region} -> - pp_loc_node buffer ~pad "ForInt" region; - pp_for_int buffer ~pad value + pp_loc_node state "ForInt" region; + pp_for_int state value | ForCollect {value; region} -> - pp_loc_node buffer ~pad "ForCollect" region; - pp_for_collect buffer ~pad value + pp_loc_node state "ForCollect" region; + pp_for_collect state value -and pp_for_int buffer ~pad:(_,pc) for_int = +and pp_for_int state for_int = let () = - let pad = mk_pad 3 0 pc in - pp_node buffer ~pad ""; - pp_var_assign buffer ~pad for_int.assign.value in + let state = state#pad 3 0 in + pp_node state ""; + pp_var_assign state for_int.assign.value in let () = - let _, pc as pad = mk_pad 3 1 pc in - pp_node buffer ~pad ""; - pp_expr buffer ~pad:(mk_pad 1 0 pc) for_int.bound in + let state = state#pad 3 1 in + pp_node state ""; + pp_expr (state#pad 1 0) for_int.bound in let () = - let pad = mk_pad 3 2 pc in + let state = state#pad 3 2 in let statements = for_int.block.value.statements in - pp_node buffer ~pad ""; - pp_statements buffer ~pad statements + pp_node state ""; + pp_statements state statements in () -and pp_var_assign buffer ~pad:(_,pc) asgn = - let pad = mk_pad 2 0 pc in - pp_ident buffer ~pad asgn.name; - let pad = mk_pad 2 1 pc in - pp_expr buffer ~pad asgn.expr +and pp_var_assign state asgn = + pp_ident (state#pad 2 0) asgn.name; + pp_expr (state#pad 2 1) asgn.expr -and pp_for_collect buffer ~pad:(_,pc) collect = +and pp_for_collect state collect = let () = - let pad = mk_pad 3 0 pc in + let state = state#pad 3 0 in match collect.bind_to with None -> - pp_ident buffer ~pad collect.var + pp_ident state collect.var | Some (_, var) -> - pp_var_binding buffer ~pad (collect.var, var) in + pp_var_binding state (collect.var, var) in let () = - let _, pc as pad = mk_pad 3 1 pc in - pp_node buffer ~pad ""; - pp_collection buffer ~pad:(mk_pad 2 0 pc) collect.collection; - pp_expr buffer ~pad:(mk_pad 1 0 pc) collect.expr in + let state = state#pad 3 1 in + pp_node state ""; + pp_collection (state#pad 2 0) collect.collection; + pp_expr (state#pad 1 0) collect.expr in let () = - let pad = mk_pad 3 2 pc in + let state = state#pad 3 2 in let statements = collect.block.value.statements in - pp_node buffer ~pad ""; - pp_statements buffer ~pad statements + pp_node state ""; + pp_statements state statements in () -and pp_collection buffer ~pad = function - Map region -> pp_loc_node buffer ~pad "map" region -| Set region -> pp_loc_node buffer ~pad "set" region -| List region -> pp_loc_node buffer ~pad "list" region +and pp_collection state = function + Map region -> pp_loc_node state "map" region +| Set region -> pp_loc_node state "set" region +| List region -> pp_loc_node state "list" region -and pp_var_binding buffer ~pad:(_,pc as pad) (source, image) = - pp_node buffer ~pad ""; - pp_ident buffer ~pad:(mk_pad 2 0 pc) source; - pp_ident buffer ~pad:(mk_pad 2 1 pc) image +and pp_var_binding state (source, image) = + pp_node state ""; + pp_ident (state#pad 2 0) source; + pp_ident (state#pad 2 1) image -and pp_fun_call buffer ~pad:(_,pc) (expr, args) = - let args = Utils.nsepseq_to_list args.value.inside in - let arity = List.length args in - let apply len rank = - pp_expr buffer ~pad:(mk_pad len rank pc) - in pp_expr buffer ~pad:(mk_pad (1+arity) 0 pc) expr; +and pp_fun_call state (expr, args) = + let args = Utils.nsepseq_to_list args.value.inside in + let arity = List.length args in + let apply len rank = pp_expr (state#pad len rank) + in pp_expr (state#pad (1+arity) 0) expr; List.iteri (apply arity) args -and pp_record_patch buffer ~pad:(_,pc as pad) patch = - pp_path buffer ~pad:(mk_pad 2 0 pc) patch.path; - pp_ne_injection pp_field_assign buffer - ~pad patch.record_inj.value +and pp_record_patch state patch = + pp_path (state#pad 2 0) patch.path; + pp_ne_injection pp_field_assign state patch.record_inj.value -and pp_field_assign buffer ~pad:(_,pc as pad) {value; _} = - pp_node buffer ~pad ""; - pp_ident buffer ~pad:(mk_pad 2 0 pc) value.field_name; - pp_expr buffer ~pad:(mk_pad 2 1 pc) value.field_expr +and pp_field_assign state {value; _} = + pp_node state ""; + pp_ident (state#pad 2 0) value.field_name; + pp_expr (state#pad 2 1) value.field_expr -and pp_map_patch buffer ~pad:(_,pc as pad) patch = - pp_path buffer ~pad:(mk_pad 2 0 pc) patch.path; - pp_ne_injection pp_binding buffer - ~pad patch.map_inj.value +and pp_map_patch state patch = + pp_path (state#pad 2 0) patch.path; + pp_ne_injection pp_binding state patch.map_inj.value -and pp_binding buffer ~pad:(_,pc as pad) {value; _} = +and pp_binding state {value; _} = let source, image = value.source, value.image in - pp_node buffer ~pad ""; - pp_expr buffer ~pad:(mk_pad 2 0 pc) source; - pp_expr buffer ~pad:(mk_pad 2 1 pc) image + pp_node state ""; + pp_expr (state#pad 2 0) source; + pp_expr (state#pad 2 1) image -and pp_set_patch buffer ~pad:(_,pc as pad) patch = - pp_path buffer ~pad:(mk_pad 2 0 pc) patch.path; - pp_ne_injection pp_expr buffer ~pad patch.set_inj.value +and pp_set_patch state patch = + pp_path (state#pad 2 0) patch.path; + pp_ne_injection pp_expr state patch.set_inj.value -and pp_map_remove buffer ~pad:(_,pc) rem = - pp_expr buffer ~pad:(mk_pad 2 0 pc) rem.key; - pp_path buffer ~pad:(mk_pad 2 1 pc) rem.map +and pp_map_remove state rem = + pp_expr (state#pad 2 0) rem.key; + pp_path (state#pad 2 1) rem.map -and pp_set_remove buffer ~pad:(_,pc) rem = - pp_expr buffer ~pad:(mk_pad 2 0 pc) rem.element; - pp_path buffer ~pad:(mk_pad 2 1 pc) rem.set +and pp_set_remove state rem = + pp_expr (state#pad 2 0) rem.element; + pp_path (state#pad 2 1) rem.set -and pp_local_decls buffer ~pad:(_,pc) decls = - let apply len rank = - pp_local_decl buffer ~pad:(mk_pad len rank pc) - in List.iteri (List.length decls |> apply) decls - -and pp_local_decl buffer ~pad:(_,pc as pad) = function -| LocalData data -> - pp_node buffer ~pad "LocalData"; - pp_data_decl buffer ~pad:(mk_pad 1 0 pc) data - -and pp_data_decl buffer ~pad = function +and pp_data_decl state = function LocalConst {value; region} -> - pp_loc_node buffer ~pad "LocalConst" region; - pp_const_decl buffer ~pad value + pp_loc_node state "LocalConst" region; + pp_const_decl state value | LocalVar {value; region} -> - pp_loc_node buffer ~pad "LocalVar" region; - pp_var_decl buffer ~pad value + pp_loc_node state "LocalVar" region; + pp_var_decl state value | LocalFun {value; region} -> - pp_loc_node buffer ~pad "LocalFun" region; - pp_fun_expr buffer ~pad value.fun_expr.value + pp_loc_node state "LocalFun" region; + pp_fun_expr state value.fun_expr.value -and pp_var_decl buffer ~pad:(_,pc) decl = - pp_ident buffer ~pad:(mk_pad 3 0 pc) decl.name; - pp_type_expr buffer ~pad:(mk_pad 3 1 pc) decl.var_type; - pp_expr buffer ~pad:(mk_pad 3 2 pc) decl.init +and pp_var_decl state decl = + pp_ident (state#pad 3 0) decl.name; + pp_type_expr (state#pad 3 1) decl.var_type; + pp_expr (state#pad 3 2) decl.init -and pp_expr buffer ~pad:(_,pc as pad) = function +and pp_expr state = function ECase {value; region} -> - pp_loc_node buffer ~pad "ECase" region; - pp_case pp_expr buffer ~pad value + pp_loc_node state "ECase" region; + pp_case pp_expr state value | ECond {value; region} -> - pp_loc_node buffer ~pad "ECond" region; - pp_cond_expr buffer ~pad value + pp_loc_node state "ECond" region; + pp_cond_expr state value | EAnnot {value; region} -> - pp_loc_node buffer ~pad "EAnnot" region; - pp_annotated buffer ~pad value + pp_loc_node state "EAnnot" region; + pp_annotated state value | ELogic e_logic -> - pp_node buffer ~pad "ELogic"; - pp_e_logic buffer ~pad:(mk_pad 1 0 pc) e_logic + pp_node state "ELogic"; + pp_e_logic (state#pad 1 0) e_logic | EArith e_arith -> - pp_node buffer ~pad "EArith"; - pp_arith_expr buffer ~pad:(mk_pad 1 0 pc) e_arith + pp_node state "EArith"; + pp_arith_expr (state#pad 1 0) e_arith | EString e_string -> - pp_node buffer ~pad "EString"; - pp_string_expr buffer ~pad:(mk_pad 1 0 pc) e_string + pp_node state "EString"; + pp_string_expr (state#pad 1 0) e_string | EList e_list -> - pp_node buffer ~pad "EList"; - pp_list_expr buffer ~pad:(mk_pad 1 0 pc) e_list + pp_node state "EList"; + pp_list_expr (state#pad 1 0) e_list | ESet e_set -> - pp_node buffer ~pad "ESet"; - pp_set_expr buffer ~pad:(mk_pad 1 0 pc) e_set + pp_node state "ESet"; + pp_set_expr (state#pad 1 0) e_set | EConstr e_constr -> - pp_node buffer ~pad "EConstr"; - pp_constr_expr buffer ~pad:(mk_pad 1 0 pc) e_constr + pp_node state "EConstr"; + pp_constr_expr (state#pad 1 0) e_constr | ERecord {value; region} -> - pp_loc_node buffer ~pad "ERecord" region; - pp_ne_injection pp_field_assign buffer ~pad value + pp_loc_node state "ERecord" region; + pp_ne_injection pp_field_assign state value | EProj {value; region} -> - pp_loc_node buffer ~pad "EProj" region; - pp_projection buffer ~pad value + pp_loc_node state "EProj" region; + pp_projection state value | EMap e_map -> - pp_node buffer ~pad "EMap"; - pp_map_expr buffer ~pad:(mk_pad 1 0 pc) e_map + pp_node state "EMap"; + pp_map_expr (state#pad 1 0) e_map | EVar v -> - pp_node buffer ~pad "EVar"; - pp_ident buffer ~pad:(mk_pad 1 0 pc) v + pp_node state "EVar"; + pp_ident (state#pad 1 0) v | ECall {value; region} -> - pp_loc_node buffer ~pad "ECall" region; - pp_fun_call buffer ~pad value + pp_loc_node state "ECall" region; + pp_fun_call state value | EBytes b -> - pp_node buffer ~pad "EBytes"; - pp_bytes buffer ~pad b + pp_node state "EBytes"; + pp_bytes state b | EUnit region -> - pp_loc_node buffer ~pad "EUnit" region + pp_loc_node state "EUnit" region | ETuple e_tuple -> - pp_node buffer ~pad "ETuple"; - pp_tuple_expr buffer ~pad e_tuple + pp_node state "ETuple"; + pp_tuple_expr state e_tuple | EPar {value; region} -> - pp_loc_node buffer ~pad "EPar" region; - pp_expr buffer ~pad:(mk_pad 1 0 pc) value.inside + pp_loc_node state "EPar" region; + pp_expr (state#pad 1 0) value.inside | EFun {value; region} -> - pp_loc_node buffer ~pad "EFun" region; - pp_fun_expr ~pad buffer value; + pp_loc_node state "EFun" region; + pp_fun_expr state value; -and pp_list_expr buffer ~pad:(_,pc as pad) = function +and pp_list_expr state = function ECons {value; region} -> - pp_loc_node buffer ~pad "ECons" region; - pp_expr buffer ~pad:(mk_pad 2 0 pc) value.arg1; - pp_expr buffer ~pad:(mk_pad 2 1 pc) value.arg2 + pp_loc_node state "ECons" region; + pp_expr (state#pad 2 0) value.arg1; + pp_expr (state#pad 2 1) value.arg2 | ENil region -> - pp_loc_node buffer ~pad "ENil" region + pp_loc_node state "ENil" region | EListComp {value; region} -> - pp_loc_node buffer ~pad "EListComp" region; + pp_loc_node state "EListComp" region; if value.elements = None then - pp_node buffer ~pad:(mk_pad 1 0 pc) "[]" - else - pp_injection pp_expr buffer ~pad value + pp_node (state#pad 1 0) "[]" + else pp_injection pp_expr state value -and pp_arith_expr buffer ~pad:(_,pc as pad) = function +and pp_arith_expr state = function Add {value; region} -> - pp_bin_op "Add" region buffer ~pad value + pp_bin_op "Add" region state value | Sub {value; region} -> - pp_bin_op "Sub" region buffer ~pad value + pp_bin_op "Sub" region state value | Mult {value; region} -> - pp_bin_op "Mult" region buffer ~pad value + pp_bin_op "Mult" region state value | Div {value; region} -> - pp_bin_op "Div" region buffer ~pad value + pp_bin_op "Div" region state value | Mod {value; region} -> - pp_bin_op "Mod" region buffer ~pad value + pp_bin_op "Mod" region state value | Neg {value; region} -> - pp_loc_node buffer ~pad "Neg" region; - pp_expr buffer ~pad:(mk_pad 1 0 pc) value.arg; + pp_loc_node state "Neg" region; + pp_expr (state#pad 1 0) value.arg; | Int i -> - pp_node buffer ~pad "Int"; - pp_int buffer ~pad i + pp_node state "Int"; + pp_int state i | Nat n -> - pp_node buffer ~pad "Nat"; - pp_int buffer ~pad n + pp_node state "Nat"; + pp_int state n | Mutez m -> - pp_node buffer ~pad "Mutez"; - pp_int buffer ~pad m + pp_node state "Mutez"; + pp_int state m -and pp_set_expr buffer ~pad:(_,pc as pad) = function +and pp_set_expr state = function SetInj {value; region} -> - pp_loc_node buffer ~pad "SetInj" region; - pp_injection pp_expr buffer ~pad value + pp_loc_node state "SetInj" region; + pp_injection pp_expr state value | SetMem {value; region} -> - pp_loc_node buffer ~pad "SetMem" region; - pp_expr buffer ~pad:(mk_pad 2 0 pc) value.set; - pp_expr buffer ~pad:(mk_pad 2 1 pc) value.element + pp_loc_node state "SetMem" region; + pp_expr (state#pad 2 0) value.set; + pp_expr (state#pad 2 1) value.element -and pp_e_logic buffer ~pad:(_, pc as pad) = function +and pp_e_logic state = function BoolExpr e -> - pp_node buffer ~pad "BoolExpr"; - pp_bool_expr buffer ~pad:(mk_pad 1 0 pc) e + pp_node state "BoolExpr"; + pp_bool_expr (state#pad 1 0) e | CompExpr e -> - pp_node buffer ~pad "CompExpr"; - pp_comp_expr buffer ~pad:(mk_pad 1 0 pc) e + pp_node state "CompExpr"; + pp_comp_expr (state#pad 1 0) e -and pp_bool_expr buffer ~pad:(_,pc as pad) = function +and pp_bool_expr state = function Or {value; region} -> - pp_bin_op "Or" region buffer ~pad value + pp_bin_op "Or" region state value | And {value; region} -> - pp_bin_op "And" region buffer ~pad value + pp_bin_op "And" region state value | Not {value; region} -> - pp_loc_node buffer ~pad "Not" region; - pp_expr buffer ~pad:(mk_pad 1 0 pc) value.arg + pp_loc_node state "Not" region; + pp_expr (state#pad 1 0) value.arg | False region -> - pp_loc_node buffer ~pad "False" region + pp_loc_node state "False" region | True region -> - pp_loc_node buffer ~pad "True" region + pp_loc_node state "True" region -and pp_comp_expr buffer ~pad = function +and pp_comp_expr state = function Lt {value; region} -> - pp_bin_op "Lt" region buffer ~pad value + pp_bin_op "Lt" region state value | Leq {value; region} -> - pp_bin_op "Leq" region buffer ~pad value + pp_bin_op "Leq" region state value | Gt {value; region} -> - pp_bin_op "Gt" region buffer ~pad value + pp_bin_op "Gt" region state value | Geq {value; region} -> - pp_bin_op "Geq" region buffer ~pad value + pp_bin_op "Geq" region state value | Equal {value; region} -> - pp_bin_op "Equal" region buffer ~pad value + pp_bin_op "Equal" region state value | Neq {value; region} -> - pp_bin_op "Neq" region buffer ~pad value + pp_bin_op "Neq" region state value -and pp_constr_expr buffer ~pad:(_, pc as pad) = function +and pp_constr_expr state = function NoneExpr region -> - pp_loc_node buffer ~pad "NoneExpr" region + pp_loc_node state "NoneExpr" region | SomeApp {value=_,args; region} -> - pp_loc_node buffer ~pad "SomeApp" region; - pp_tuple_expr buffer ~pad args + pp_loc_node state "SomeApp" region; + pp_tuple_expr state args | ConstrApp {value; region} -> - pp_loc_node buffer ~pad "ConstrApp" region; - pp_constr_app buffer ~pad:(mk_pad 1 0 pc) value + pp_loc_node state "ConstrApp" region; + pp_constr_app (state#pad 1 0) value -and pp_constr_app buffer ~pad (constr, args_opt) = - pp_ident buffer ~pad constr; +and pp_constr_app state (constr, args_opt) = + pp_ident state constr; match args_opt with None -> () - | Some args -> pp_tuple_expr buffer ~pad args + | Some args -> pp_tuple_expr state args -and pp_map_expr buffer ~pad = function +and pp_map_expr state = function MapLookUp {value; region} -> - pp_loc_node buffer ~pad "MapLookUp" region; - pp_map_lookup buffer ~pad value + pp_loc_node state "MapLookUp" region; + pp_map_lookup state value | MapInj {value; region} | BigMapInj {value; region} -> - pp_loc_node buffer ~pad "MapInj" region; - pp_injection pp_binding buffer ~pad value + pp_loc_node state "MapInj" region; + pp_injection pp_binding state value -and pp_tuple_expr buffer ~pad:(_,pc) {value; _} = - let exprs = Utils.nsepseq_to_list value.inside in - let length = List.length exprs in - let apply len rank = - pp_expr buffer ~pad:(mk_pad len rank pc) +and pp_tuple_expr state {value; _} = + let exprs = Utils.nsepseq_to_list value.inside in + let length = List.length exprs in + let apply len rank = pp_expr (state#pad len rank) in List.iteri (apply length) exprs -and pp_string_expr buffer ~pad:(_,pc as pad) = function +and pp_string_expr state = function Cat {value; region} -> - pp_loc_node buffer ~pad "Cat" region; - pp_expr buffer ~pad:(mk_pad 2 0 pc) value.arg1; - pp_expr buffer ~pad:(mk_pad 2 1 pc) value.arg2; + pp_loc_node state "Cat" region; + pp_expr (state#pad 2 0) value.arg1; + pp_expr (state#pad 2 1) value.arg2; | String s -> - pp_node buffer ~pad "String"; - pp_string buffer ~pad:(mk_pad 1 0 pc) s + pp_node state "String"; + pp_string (state#pad 1 0) s -and pp_annotated buffer ~pad:(_,pc) (expr, t_expr) = - pp_expr buffer ~pad:(mk_pad 2 0 pc) expr; - pp_type_expr buffer ~pad:(mk_pad 2 1 pc) 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 -and pp_bin_op node region buffer ~pad:(_,pc as pad) op = - pp_loc_node buffer ~pad node region; - pp_expr buffer ~pad:(mk_pad 2 0 pc) op.arg1; - pp_expr buffer ~pad:(mk_pad 2 1 pc) op.arg2 - -let pp_ast buffer = pp_ast buffer ~pad:("","") +and pp_bin_op node region state op = + pp_loc_node state node region; + pp_expr (state#pad 2 0) op.arg1; + pp_expr (state#pad 2 1) op.arg2 diff --git a/src/passes/1-parser/pascaligo/ParserLog.mli b/src/passes/1-parser/pascaligo/ParserLog.mli index c9800f791..c1c9bf521 100644 --- a/src/passes/1-parser/pascaligo/ParserLog.mli +++ b/src/passes/1-parser/pascaligo/ParserLog.mli @@ -1,18 +1,35 @@ -(* Printing the AST *) +(** Printing the AST *) -val offsets : bool ref -val mode : [`Byte | `Point] ref +(** The type [state] captures the state that is threaded in the + printing iterators in this module. +*) +type state -val print_tokens : Buffer.t -> AST.t -> unit -val print_path : Buffer.t -> AST.path -> unit -val print_pattern : Buffer.t -> AST.pattern -> unit -val print_instruction : Buffer.t -> AST.instruction -> unit +val mk_state : + offsets:bool -> mode:[`Point|`Byte] -> buffer:Buffer.t -> state -val tokens_to_string : AST.t -> string -val path_to_string : AST.path -> string -val pattern_to_string : AST.pattern -> string -val instruction_to_string : AST.instruction -> string +(** {1 Printing tokens from the AST in a buffer} -(* Pretty-printing of the AST *) + Printing the tokens reconstructed from the AST. This is very useful + for debugging, as the output of [print_token ast] can be textually + compared to that of [Lexer.trace] (see module [LexerMain]). *) -val pp_ast : Buffer.t -> AST.t -> unit +val print_tokens : state -> AST.t -> unit +val print_path : state -> AST.path -> unit +val print_pattern : state -> AST.pattern -> unit +val print_instruction : state -> AST.instruction -> unit + +(** {1 Printing tokens from the AST in a string} *) + +val tokens_to_string : + offsets:bool -> mode:[`Point|`Byte] -> AST.t -> string +val path_to_string : + offsets:bool -> mode:[`Point|`Byte] -> AST.path -> string +val pattern_to_string : + offsets:bool -> mode:[`Point|`Byte] -> AST.pattern -> string +val instruction_to_string : + offsets:bool -> mode:[`Point|`Byte] -> AST.instruction -> string + +(** {1 Pretty-printing of the AST} *) + +val pp_ast : state -> AST.t -> unit diff --git a/src/passes/1-parser/pascaligo/ParserMain.ml b/src/passes/1-parser/pascaligo/ParserMain.ml index 5fa99ab76..130cfbb23 100644 --- a/src/passes/1-parser/pascaligo/ParserMain.ml +++ b/src/passes/1-parser/pascaligo/ParserMain.ml @@ -1,27 +1,24 @@ -(* Driver for the parser of PascaLIGO *) +(** Driver for the parser of PascaLIGO *) -(* Error printing and exception tracing *) +let extension = ".ligo" +let options = EvalOpt.read "PascaLIGO" extension +(** Error printing and exception tracing +*) let () = Printexc.record_backtrace true -(* Reading the command-line options *) - -let options = EvalOpt.read "PascaLIGO" ".ligo" - -open EvalOpt - -(* Auxiliary functions *) - +(** Auxiliary functions +*) let sprintf = Printf.sprintf -(* Extracting the input file *) - +(** Extracting the input file +*) let file = - match options.input with + match options#input with None | Some "-" -> false | Some _ -> true -(* Error printing and exception tracing *) +(** {1 Error printing and exception tracing} *) let () = Printexc.record_backtrace true @@ -35,35 +32,35 @@ let error_to_string = function | _ -> assert false let print_error ?(offsets=true) mode Region.{region; value} ~file = - let msg = error_to_string value in - let reg = region#to_string ~file ~offsets mode in + let msg = error_to_string value in + let reg = region#to_string ~file ~offsets mode in Utils.highlight (sprintf "Parse error %s:\n%s%!" reg msg) -(* Path for CPP inclusions (#include) *) +(** {1 Preprocessing the input source and opening the input channels} *) +(** Path for CPP inclusions (#include) +*) let lib_path = - match options.libs with + match options#libs with [] -> "" | libs -> let mk_I dir path = Printf.sprintf " -I %s%s" dir path - in List.fold_right mk_I libs "" - -(* Preprocessing the input source and opening the input channels *) + in List.fold_right mk_I libs "" let prefix = - match options.input with + match options#input with None | Some "-" -> "temp" | Some file -> Filename.(file |> basename |> remove_extension) -let suffix = ".pp.ligo" +let suffix = ".pp" ^ extension let pp_input = - if Utils.String.Set.mem "cpp" options.verbose + if Utils.String.Set.mem "cpp" options#verbose then prefix ^ suffix else let pp_input, pp_out = Filename.open_temp_file prefix suffix in close_out pp_out; pp_input let cpp_cmd = - match options.input with + match options#input with None | Some "-" -> Printf.sprintf "cpp -traditional-cpp%s - > %s" lib_path pp_input @@ -72,12 +69,12 @@ let cpp_cmd = lib_path file pp_input let () = - if Utils.String.Set.mem "cpp" options.verbose + if Utils.String.Set.mem "cpp" options#verbose then Printf.eprintf "%s\n%!" cpp_cmd; if Sys.command cpp_cmd <> 0 then external_ (Printf.sprintf "the command \"%s\" failed." cpp_cmd) -(* Instanciating the lexer *) +(** {1 Instanciating the lexer} *) module Lexer = Lexer.Make (LexToken) @@ -88,45 +85,49 @@ let Lexer.{read; buffer; get_pos; get_last; close} = and cout = stdout -let log = Log.output_token ~offsets:options.offsets - options.mode options.cmd cout +let log = Log.output_token ~offsets:options#offsets + options#mode options#cmd cout and close_all () = close (); close_out cout -(* Tokeniser *) +(** {1 Tokeniser} *) let tokeniser = read ~log -(* Main *) +(** {1 Main} *) let () = try let ast = Parser.contract tokeniser buffer in - if Utils.String.Set.mem "ast" options.verbose + if Utils.String.Set.mem "ast" options#verbose then let buffer = Buffer.create 131 in + let state = ParserLog.mk_state + ~offsets:options#offsets + ~mode:options#mode + ~buffer in begin - ParserLog.offsets := options.offsets; - ParserLog.mode := options.mode; - ParserLog.pp_ast buffer ast; + ParserLog.pp_ast state ast; Buffer.output_buffer stdout buffer end - else if Utils.String.Set.mem "ast-tokens" options.verbose + else if Utils.String.Set.mem "ast-tokens" options#verbose then let buffer = Buffer.create 131 in + let state = ParserLog.mk_state + ~offsets:options#offsets + ~mode:options#mode + ~buffer in begin - ParserLog.offsets := options.offsets; - ParserLog.mode := options.mode; - ParserLog.print_tokens buffer ast; + ParserLog.print_tokens state ast; Buffer.output_buffer stdout buffer end with Lexer.Error err -> close_all (); - Lexer.print_error ~offsets:options.offsets - options.mode err ~file + Lexer.print_error ~offsets:options#offsets + options#mode err ~file | Parser.Error -> let region = get_last () in let error = Region.{region; value=ParseError} in let () = close_all () in - print_error ~offsets:options.offsets - options.mode error ~file + print_error ~offsets:options#offsets + options#mode error ~file | Sys_error msg -> Utils.highlight msg diff --git a/src/passes/1-parser/pascaligo/Stubs/Simple_utils.ml b/src/passes/1-parser/pascaligo/Stubs/Simple_utils.ml index 61a721ba3..0360af1b5 100644 --- a/src/passes/1-parser/pascaligo/Stubs/Simple_utils.ml +++ b/src/passes/1-parser/pascaligo/Stubs/Simple_utils.ml @@ -1,3 +1,2 @@ module Region = Region module Pos = Pos -module Option = X_option diff --git a/src/passes/1-parser/pascaligo/Tests/pp.ligo b/src/passes/1-parser/pascaligo/Tests/pp.ligo index bd3869197..78c06c34d 100644 --- a/src/passes/1-parser/pascaligo/Tests/pp.ligo +++ b/src/passes/1-parser/pascaligo/Tests/pp.ligo @@ -3,8 +3,8 @@ type u is A | B of t * int | C of int -> (string -> int) type v is record a : t; b : record c : string end end function back (var store : store) : list (operation) * store is - var operations : list (operation) := list [] begin + var operations : list (operation) := list []; const a : nat = 0n; x0 := record foo = "1"; bar = 4n end; x1 := nil; @@ -31,8 +31,8 @@ function back (var store : store) : list (operation) * store is if now > store.deadline and (not True) then begin f (x,1); - for k -> d : int * string in map m block { skip }; - for x : int in set s block { skip }; + for k -> d in map m block { skip }; + for x in set s block { skip }; while i < 10n begin acc := 2 - (if toggle then f(x) else Unit); @@ -53,8 +53,8 @@ function back (var store : store) : list (operation) * store is end with (operations, store) function claim (var store : store) : list (operation) * store is - var operations : list (operation) := nil begin + var operations : list (operation) := nil; if now <= store.deadline then failwith ("Too soon.") else @@ -73,8 +73,8 @@ function claim (var store : store) : list (operation) * store is end with (operations, store) function withdraw (var store : store) : list (operation) * store is - var operations : list (operation) := list end begin + var operations : list (operation) := list end; if sender = owner then if now >= store.deadline then if balance >= store.goal then { diff --git a/src/passes/1-parser/reasonligo/Parser.mly b/src/passes/1-parser/reasonligo/Parser.mly index 1a63fb329..743cfc0e8 100644 --- a/src/passes/1-parser/reasonligo/Parser.mly +++ b/src/passes/1-parser/reasonligo/Parser.mly @@ -36,11 +36,11 @@ type 'a sequence_or_record = %nonassoc Ident -%nonassoc COLON (* Solves a shift/reduce problem that happens with record - and sequences. To elaborate: - - sequence_or_record_in can be reduced to - expr -> Ident, but also to - field_assignment -> Ident. +%nonassoc COLON (* Solves a shift/reduce problem that happens with record + and sequences. To elaborate: + - sequence_or_record_in can be reduced to + expr -> Ident, but also to + field_assignment -> Ident. *) %% @@ -135,7 +135,7 @@ sepseq(item,sep): (* Non-empty comma-separated values (at least two values) *) tuple(item): - item COMMA nsepseq(item,COMMA) { + item COMMA nsepseq(item,COMMA) { let h,t = $3 in $1,($2,h)::t } @@ -143,7 +143,7 @@ tuple(item): list(item): LBRACKET sep_or_term_list(item, COMMA) RBRACKET { - let elements, terminator = $2 in + let elements, terminator = $2 in { value = { compound = Brackets ($1,$3); @@ -151,7 +151,7 @@ list(item): terminator; }; region = cover $1 $3 - } + } } | LBRACKET RBRACKET { let value = { @@ -161,11 +161,11 @@ list(item): let region = cover $1 $2 in {value; region} } - + (* Main *) contract: - declarations EOF { + declarations EOF { {decl = $1; eof=$2} } declarations: @@ -179,7 +179,7 @@ declaration: (* Type declarations *) type_decl: - Type type_name EQ type_expr { + Type type_name EQ type_expr { let region = cover $1 (type_expr_to_region $4) in let value = { kwd_type = $1; @@ -200,15 +200,15 @@ cartesian: let value = Utils.nsepseq_cons $1 $2 $3 in let region = nsepseq_to_region type_expr_to_region value in TProd {region; value} - } -| fun_type { ($1 : type_expr) } - -fun_type: - core_type { - $1 } -| core_type ARROW fun_type { - let region = cover (type_expr_to_region $1) (type_expr_to_region $3) in +| fun_type { ($1 : type_expr) } + +fun_type: + core_type { + $1 + } +| core_type ARROW fun_type { + let region = cover (type_expr_to_region $1) (type_expr_to_region $3) in TFun {region; value = ($1, $2, $3)} } @@ -219,28 +219,28 @@ core_type: | module_name DOT type_name { let module_name = $1.value in let type_name = $3.value in - let value = module_name ^ "." ^ type_name in + let value = module_name ^ "." ^ type_name in let region = cover $1.region $3.region - in + in TVar {region; value} } -| type_constr LPAR nsepseq(core_type, COMMA) RPAR { +| type_constr LPAR nsepseq(core_type, COMMA) RPAR { let arg_val = $3 in let constr = $1 in - let start = $1.region in - let stop = $4 in + let start = $1.region in + let stop = $4 in let region = cover start stop in let lpar, rpar = $2, $4 in TApp Region.{value = constr, { value = { - lpar; + lpar; rpar; inside = arg_val }; region = cover lpar rpar; }; region} } -| par (type_expr) { +| par (type_expr) { TPar $1 } @@ -248,7 +248,7 @@ type_constr: type_name { $1 } sum_type: - VBAR nsepseq(variant,VBAR) { + VBAR nsepseq(variant,VBAR) { let region = nsepseq_to_region (fun x -> x.region) $2 in {region; value = $2} } @@ -259,11 +259,11 @@ variant: and value = {constr = $1; arg = Some ($2, $3)} in {region; value} } -| Constr { +| Constr { {region=$1.region; value= {constr=$1; arg=None}} } record_type: - LBRACE sep_or_term_list(field_decl,COMMA) RBRACE { + LBRACE sep_or_term_list(field_decl,COMMA) RBRACE { let ne_elements, terminator = $2 in let region = cover $1 $3 and value = { @@ -271,7 +271,7 @@ record_type: ne_elements; terminator; } - in {region; value} + in {region; value} } type_expr_field: @@ -282,24 +282,24 @@ type_expr_field: field_decl: field_name { let value = {field_name = $1; colon = Region.ghost; field_type = TVar $1} - in {region = $1.region; value} + in {region = $1.region; value} } | field_name COLON type_expr_field { let stop = type_expr_to_region $3 in let region = cover $1.region stop and value = {field_name = $1; colon = $2; field_type = $3} - in {region; value} + in {region; value} } (* Top-level non-recursive definitions *) let_declaration: Let let_binding { - let kwd_let = $1 in + let kwd_let = $1 in let binding, (region: Region.region) = $2 in {value = kwd_let, binding; region} } - + es6_func: ARROW expr { $1, $2 @@ -313,42 +313,42 @@ let_binding: let region = cover start stop in ({binders = pattern, []; lhs_type=$2; eq=$3; let_rhs=$4}, region) } -| tuple(sub_irrefutable) type_annotation? EQ expr { - let h, t = $1 in +| tuple(sub_irrefutable) type_annotation? EQ expr { + let h, t = $1 in let start = pattern_to_region h in let stop = last (fun (region, _) -> region) t in - let region = cover start stop in + let region = cover start stop in let pattern = PTuple { value = $1; region } in let start = region in - let stop = expr_to_region $4 in + let stop = expr_to_region $4 in let region = cover start stop in ({binders = pattern, []; lhs_type=$2; eq=$3; let_rhs=$4}, region) } -| WILD type_annotation? EQ expr { +| WILD type_annotation? EQ expr { let pattern = PWild $1 in let start = pattern_to_region pattern in - let stop = expr_to_region $4 in + let stop = expr_to_region $4 in let region = cover start stop in ({binders = pattern, []; lhs_type=$2; eq=$3; let_rhs=$4}, region) } -| unit type_annotation? EQ expr { +| unit type_annotation? EQ expr { let pattern = PUnit $1 in let start = pattern_to_region pattern in - let stop = expr_to_region $4 in + let stop = expr_to_region $4 in let region = cover start stop in ({binders = pattern, []; lhs_type=$2; eq=$3; let_rhs=$4}, region) } -| record_pattern type_annotation? EQ expr { +| record_pattern type_annotation? EQ expr { let pattern = PRecord $1 in let start = pattern_to_region pattern in - let stop = expr_to_region $4 in + let stop = expr_to_region $4 in let region = cover start stop in ({binders = pattern, []; lhs_type=$2; eq=$3; let_rhs=$4}, region) } -| par(closed_irrefutable) type_annotation? EQ expr { +| par(closed_irrefutable) type_annotation? EQ expr { let pattern = PPar $1 in let start = pattern_to_region pattern in - let stop = expr_to_region $4 in + let stop = expr_to_region $4 in let region = cover start stop in ({binders = pattern, []; lhs_type=$2; eq=$3; let_rhs=$4}, region) } @@ -359,11 +359,11 @@ type_annotation: (* Patterns *) irrefutable: - tuple(sub_irrefutable) { - let h, t = $1 in + tuple(sub_irrefutable) { + let h, t = $1 in let start = pattern_to_region h in let stop = last (fun (region, _) -> region) t in - let region = cover start stop in + let region = cover start stop in PTuple { value = $1; region } } | sub_irrefutable { $1 } @@ -381,14 +381,14 @@ closed_irrefutable: | typed_pattern { PTyped $1 } typed_pattern: - irrefutable COLON type_expr { - let start = pattern_to_region $1 in + irrefutable COLON type_expr { + let start = pattern_to_region $1 in let stop = type_expr_to_region $3 in let region = cover start stop in { value = { - pattern = $1; - colon = $2; + pattern = $1; + colon = $2; type_expr = $3 }; region @@ -396,18 +396,18 @@ typed_pattern: } pattern: - LBRACKET sub_pattern COMMA DOTDOTDOT sub_pattern RBRACKET { + LBRACKET sub_pattern COMMA DOTDOTDOT sub_pattern RBRACKET { let start = pattern_to_region $2 in - let stop = pattern_to_region $5 in + let stop = pattern_to_region $5 in let region = cover start stop in let val_ = {value = $2, $3, $5; region} in - PList (PCons val_) + PList (PCons val_) } -| tuple(sub_pattern) { - let h, t = $1 in +| tuple(sub_pattern) { + let h, t = $1 in let start = pattern_to_region h in let stop = last (fun (region, _) -> region) t in - let region = cover start stop in + let region = cover start stop in PTuple { value = $1; region } } | core_pattern { $1 } @@ -425,7 +425,7 @@ core_pattern: | False { PFalse $1 } | Str { PString $1 } | par(ptuple) { PPar $1 } -| list(sub_pattern) { PList (PListComp $1) } +| list(sub_pattern) { PList (PListComp $1) } | constr_pattern { PConstr $1 } | record_pattern { PRecord $1 } @@ -439,7 +439,7 @@ record_pattern: terminator; } in - {region; value} + {region; value} } field_pattern: @@ -458,25 +458,25 @@ constr_pattern: and value = $1, $2 in PSomeApp {value; region} } -| Constr { +| Constr { PConstrApp { value = $1, None; region = $1.region } } -| Constr sub_pattern { +| Constr sub_pattern { let region = cover $1.region (pattern_to_region $2) in - PConstrApp { value = $1, Some $2; region } + PConstrApp { value = $1, Some $2; region } } ptuple: - tuple(sub_pattern) { - let h, t = $1 in + tuple(sub_pattern) { + let h, t = $1 in let start = pattern_to_region h in let stop = last (fun (region, _) -> region) t in - let region = cover start stop in - PTuple { value = $1; region } + let region = cover start stop in + PTuple { value = $1; region } } unit: - LPAR RPAR { + LPAR RPAR { let the_unit = ghost, ghost in let region = cover $1 $2 in { value = the_unit; region } @@ -500,57 +500,57 @@ base_cond: base_cond__open(base_cond) { $1 } type_expr_simple_args: - LPAR nsepseq(type_expr_simple, COMMA) RPAR { + LPAR nsepseq(type_expr_simple, COMMA) RPAR { $1, $2, $3 - } + } -type_expr_simple: - core_expr_2 type_expr_simple_args? { +type_expr_simple: + core_expr_2 type_expr_simple_args? { let args = $2 in - let constr = match $1 with + let constr = match $1 with | EVar i -> i - | EProj {value = {struct_name; field_path; _}; region} -> - let path = - (Utils.nsepseq_foldl - (fun a e -> - match e with + | EProj {value = {struct_name; field_path; _}; region} -> + let path = + (Utils.nsepseq_foldl + (fun a e -> + match e with | FieldName v -> a ^ "." ^ v.value | Component {value = c, _; _} -> a ^ "." ^ c - ) + ) struct_name.value field_path - ) + ) in {value = path; region } | EArith (Mutez {value = s, _; region }) | EArith (Int {value = s, _; region }) | EArith (Nat {value = s, _; region }) -> { value = s; region } - | EString (StrLit {value = s; region}) -> { value = s; region } + | EString (String {value = s; region}) -> { value = s; region } | ELogic (BoolExpr (True t)) -> { value = "true"; region = t } | ELogic (BoolExpr (False f)) -> { value = "false"; region = f } | _ -> failwith "Not supported" in - match args with + match args with Some (lpar, args, rpar) -> ( let start = expr_to_region $1 in let stop = rpar in - let region = cover start stop in + let region = cover start stop in TApp { value = constr, { value = { - inside = args; - lpar; + inside = args; + lpar; rpar - }; - region}; + }; + region}; region} ) | None -> TVar constr } - | LPAR nsepseq(type_expr_simple, COMMA) RPAR { + | LPAR nsepseq(type_expr_simple, COMMA) RPAR { TProd {value = $2; region = cover $1 $3} } - | LPAR type_expr_simple ARROW type_expr_simple RPAR { + | LPAR type_expr_simple ARROW type_expr_simple RPAR { TFun {value = $2, $3, $4; region = cover $1 $5} } @@ -562,32 +562,32 @@ fun_expr: let arrow, body = $2 in let kwd_fun = Region.ghost in let start = expr_to_region $1 in - let stop = expr_to_region body in + let stop = expr_to_region body in let region = cover start stop in let rec arg_to_pattern = (function - | EVar val_ -> PVar val_ + | EVar val_ -> PVar val_ | EAnnot {value = (EVar v, typ); region} -> PTyped {value = { - pattern = PVar v; + pattern = PVar v; colon = Region.ghost; type_expr = typ; } ; region} - | EPar {value = {inside; lpar; rpar}; region} -> + | EPar {value = {inside; lpar; rpar}; region} -> PPar {value = {inside = arg_to_pattern inside; lpar; rpar}; region} | EUnit u -> PUnit u | _ -> failwith "Not supported" ) - in + in let fun_args_to_pattern = (function | EAnnot {value = (ETuple {value = fun_args; _}, _); _} -> (* ((foo:x, bar) : type) *) let bindings = List.map (fun arg -> arg_to_pattern (snd arg)) (snd fun_args) in (arg_to_pattern (fst fun_args), bindings) | EAnnot {value = (EPar {value = {inside = fun_arg ; _}; _}, _); _} -> (* ((foo:x, bar) : type) *) (arg_to_pattern fun_arg, []) - | EPar {value = {inside = fun_arg; _ }; _} -> + | EPar {value = {inside = fun_arg; _ }; _} -> (arg_to_pattern fun_arg, []) | EAnnot e -> (arg_to_pattern (EAnnot e), []) - | ETuple {value = fun_args; _} -> + | ETuple {value = fun_args; _} -> let bindings = List.map (fun arg -> arg_to_pattern (snd arg)) (snd fun_args) in (arg_to_pattern (fst fun_args), bindings) | EUnit e -> @@ -624,13 +624,13 @@ if_then(right_expr): let the_unit = ghost, ghost in let ifnot = EUnit {region=ghost; value=the_unit} in let region = cover $1 $5 in - { + { value = { - kwd_if = $1; - test = $2; - kwd_then = $3; + kwd_if = $1; + test = $2; + kwd_then = $3; ifso = $4; - kwd_else = Region.ghost; + kwd_else = Region.ghost; ifnot; }; region @@ -640,13 +640,13 @@ if_then(right_expr): if_then_else(right_expr): If parenthesized_expr LBRACE closed_if SEMI RBRACE Else LBRACE right_expr SEMI RBRACE { let region = cover $1 $11 in - { + { value = { - kwd_if = $1; - test = $2; - kwd_then = $3; + kwd_if = $1; + test = $2; + kwd_then = $3; ifso = $4; - kwd_else = $6; + kwd_else = $6; ifnot = $9 }; region @@ -671,20 +671,20 @@ switch_expr(right_expr): let stop = $5 in let region = cover start stop in { value = { - kwd_match = $1; - expr = $2; - lead_vbar = None; + kwd_match = $1; + expr = $2; + lead_vbar = None; kwd_with = Region.ghost; cases = { value = cases; region = nsepseq_to_region (fun {region; _} -> region) $4 }; - }; - region + }; + region } } -switch_expr_: +switch_expr_: | par(expr) { $1.value.inside } @@ -693,7 +693,7 @@ switch_expr_: } cases(right_expr): - nseq(case_clause(right_expr)) { + nseq(case_clause(right_expr)) { let (hd, tl) = $1 in hd, (List.map (fun f -> expr_to_region f.value.rhs, f) tl) } @@ -701,11 +701,11 @@ cases(right_expr): case_clause(right_expr): VBAR pattern ARROW right_expr SEMI? { let region = cover (pattern_to_region $2) (expr_to_region $4) in - {value = + {value = { - pattern = $2; - arrow = $3; - rhs=$4 + pattern = $2; + arrow = $3; + rhs=$4 }; region } @@ -713,11 +713,11 @@ case_clause(right_expr): let_expr(right_expr): Let let_binding SEMI right_expr { - let kwd_let = $1 in - let (binding: let_binding), _ = $2 in + let kwd_let = $1 in + let (binding: let_binding), _ = $2 in let kwd_in = $3 in let body = $4 in - let stop = expr_to_region $4 in + let stop = expr_to_region $4 in let region = cover $1 stop in let let_in = {kwd_let; binding; kwd_in; body} in ELetIn {region; value=let_in} } @@ -726,19 +726,19 @@ disj_expr_level: disj_expr { ELogic (BoolExpr (Or $1)) } | conj_expr_level { $1 } | par(tuple(disj_expr_level)) type_annotation_simple? { - let region = $1.region in + let region = $1.region in let tuple = ETuple {value=$1.value.inside; region} in - let region = match $2 with + let region = match $2 with | Some s -> cover $1.region (type_expr_to_region s) | None -> region - in - match $2 with + in + match $2 with | Some typ -> EAnnot({value = tuple, typ; region}) | None -> tuple } bin_op(arg1,op,arg2): - arg1 op arg2 { + arg1 op arg2 { let start = expr_to_region $1 in let stop = expr_to_region $3 in let region = cover start stop in @@ -821,29 +821,29 @@ unary_expr_level: let start = $1 in let end_ = expr_to_region $2 in let region = cover start end_ - and value = {op = $1; arg = $2} - in EArith (Neg {region; value}) + and value = {op = $1; arg = $2} + in EArith (Neg {region; value}) } | NOT call_expr_level { let start = $1 in let end_ = expr_to_region $2 in let region = cover start end_ - and value = {op = $1; arg = $2} in + and value = {op = $1; arg = $2} in ELogic (BoolExpr (Not ({region; value}))) -} +} | call_expr_level { - $1 + $1 } -call_expr_level: +call_expr_level: call_expr_level_in type_annotation_simple? { - let region = match $2 with + let region = match $2 with | Some s -> cover (expr_to_region $1) (type_expr_to_region s) | None -> expr_to_region $1 - in + in match $2 with - | Some t -> - EAnnot { value = $1, t; region } + | Some t -> + EAnnot { value = $1, t; region } | None -> $1 } @@ -859,12 +859,12 @@ constr_expr: | C_Some core_expr { let region = cover $1 (expr_to_region $2) in EConstr (ESomeApp {value = $1,$2; region}) - } - | Constr core_expr? { + } + | Constr core_expr? { let start = $1.region in - let stop = match $2 with + let stop = match $2 with | Some c -> expr_to_region c - | None -> start + | None -> start in let region = cover start stop in EConstr (EConstrApp { value = $1,$2; region}) @@ -892,7 +892,7 @@ core_expr_2: | Nat { EArith (Nat $1) } | Ident | module_field { EVar $1 } | projection { EProj $1 } -| Str { EString (StrLit $1) } +| Str { EString (String $1) } | unit { EUnit $1 } | False { ELogic (BoolExpr (False $1)) } | True { ELogic (BoolExpr (True $1)) } @@ -940,7 +940,7 @@ core_expr: | Nat { EArith (Nat $1) } | Ident | module_field { EVar $1 } | projection { EProj $1 } -| Str { EString (StrLit $1) } +| Str { EString (String $1) } | unit { EUnit $1 } | False { ELogic (BoolExpr (False $1)) } | True { ELogic (BoolExpr (True $1)) } @@ -949,9 +949,9 @@ core_expr: | sequence_or_record { $1 } module_field: - module_name DOT field_name { + module_name DOT field_name { let region = cover $1.region $3.region in - { value = $1.value ^ "." ^ $3.value; region } + { value = $1.value ^ "." ^ $3.value; region } } selection: @@ -962,7 +962,7 @@ selection: } | DOT field_name selection { let r, (h, t) = $3 in - let result:((selection, dot) Utils.nsepseq) = (FieldName $2), ($1, h) :: t in + let result:((selection, dot) Utils.nsepseq) = (FieldName $2), ($1, h) :: t in r, result } | DOT field_name { @@ -974,15 +974,15 @@ selection: projection: struct_name selection { - let start = $1.region in - let stop = nsepseq_to_region (function - | FieldName f -> f.region + let start = $1.region in + let stop = nsepseq_to_region (function + | FieldName f -> f.region | Component c -> c.region) (snd $2) in let region = cover start stop in - { value = + { value = { - struct_name = $1; + struct_name = $1; selector = fst $2; field_path = snd $2 }; @@ -994,33 +994,33 @@ projection: let field_name = $3 in let value = module_name.value ^ "." ^ field_name.value in let struct_name = {$1 with value} in - let start = $1.region in - let stop = nsepseq_to_region (function - | FieldName f -> f.region + let start = $1.region in + let stop = nsepseq_to_region (function + | FieldName f -> f.region | Component c -> c.region) (snd $4) in let region = cover start stop in - { value = + { value = { - struct_name; - selector = fst $4; + struct_name; + selector = fst $4; field_path = snd $4 }; region - } + } } -sequence_or_record_in: +sequence_or_record_in: expr SEMI sep_or_term_list(expr,SEMI) { let (e, _region) = $3 in let e = Utils.nsepseq_cons $1 $2 e in PaSequence { s_elts = e; s_terminator = None} } -| field_assignment COMMA sep_or_term_list(field_assignment,COMMA) { +| field_assignment COMMA sep_or_term_list(field_assignment,COMMA) { let (e, _region) = $3 in let e = Utils.nsepseq_cons $1 $2 e in PaRecord { r_elts = e; r_terminator = None} - } + } | expr SEMI? { PaSingleExpr $1 } @@ -1029,7 +1029,7 @@ sequence_or_record: LBRACE sequence_or_record_in RBRACE { let compound = Braces($1, $3) in let region = cover $1 $3 in - match $2 with + match $2 with | PaSequence s -> ( let value: expr injection = { compound; @@ -1045,33 +1045,33 @@ sequence_or_record: ne_elements = r.r_elts; terminator = r.r_terminator; } - in + in ERecord {value; region} ) - | PaSingleExpr e -> e + | PaSingleExpr e -> e } field_assignment: - field_name { - { value = + field_name { + { value = { - field_name = $1; - assignment = Region.ghost; + field_name = $1; + assignment = Region.ghost; field_expr = EVar $1 }; region = $1.region } } | field_name COLON expr { - let start = $1.region in - let stop = expr_to_region $3 in + let start = $1.region in + let stop = expr_to_region $3 in let region = cover start stop in - { value = + { value = { - field_name = $1; - assignment = $2; + field_name = $1; + assignment = $2; field_expr = $3 }; region - } + } } diff --git a/src/passes/1-parser/shared/EvalOpt.ml b/src/passes/1-parser/shared/EvalOpt.ml index a4508ab30..68e2b1f94 100644 --- a/src/passes/1-parser/shared/EvalOpt.ml +++ b/src/passes/1-parser/shared/EvalOpt.ml @@ -1,22 +1,32 @@ -(* Parsing command-line options *) - -(* The type [command] denotes some possible behaviours of the - compiler. *) +(** Parsing command-line options *) +(** The type [command] denotes some possible behaviours of the + compiler. +*) type command = Quiet | Copy | Units | Tokens -(* The type [options] gathers the command-line options. *) - -type options = { +(** The type [options] gathers the command-line options. +*) +type options = < input : string option; libs : string list; verbose : Utils.String.Set.t; offsets : bool; mode : [`Byte | `Point]; cmd : command -} +> -(* Auxiliary functions *) +let make ~input ~libs ~verbose ~offsets ~mode ~cmd = + object + method input = input + method libs = libs + method verbose = verbose + method offsets = offsets + method mode = mode + method cmd = cmd + end + +(** {1 Auxiliary functions} *) let printf = Printf.printf let sprintf = Printf.sprintf @@ -25,7 +35,7 @@ let print = print_endline let abort msg = Utils.highlight (sprintf "Command-line error: %s\n" msg); exit 1 -(* Help *) +(** {1 Help} *) let help language extension () = let file = Filename.basename Sys.argv.(0) in @@ -44,11 +54,11 @@ let help language extension () = print " -h, --help This help"; exit 0 -(* Version *) +(** {1 Version} *) let version () = printf "%s\n" Version.version; exit 0 -(* Specifying the command-line options a la GNU *) +(** {1 Specifying the command-line options a la GNU} *) let copy = ref false and tokens = ref false @@ -85,8 +95,8 @@ let specs language extension = ] ;; -(* Handler of anonymous arguments *) - +(** Handler of anonymous arguments +*) let anonymous arg = match !input with None -> input := Some arg @@ -94,8 +104,8 @@ let anonymous arg = abort (sprintf "Multiple inputs") ;; -(* Checking options and exporting them as non-mutable values *) - +(** Checking options and exporting them as non-mutable values +*) let string_of convert = function None -> "None" | Some s -> sprintf "Some %s" (convert s) @@ -168,9 +178,9 @@ let check extension = | false, false, false, true -> Tokens | _ -> abort "Choose one of -q, -c, -u, -t." - in {input; libs; verbose; offsets; mode; cmd} + in make ~input ~libs ~verbose ~offsets ~mode ~cmd -(* Parsing the command-line options *) +(** {1 Parsing the command-line options} *) let read language extension = try diff --git a/src/passes/1-parser/shared/EvalOpt.mli b/src/passes/1-parser/shared/EvalOpt.mli index 3b4c3497a..e3b006e38 100644 --- a/src/passes/1-parser/shared/EvalOpt.mli +++ b/src/passes/1-parser/shared/EvalOpt.mli @@ -1,55 +1,67 @@ -(* Parsing the command-line options of PascaLIGO *) +(** Parsing the command-line options of PascaLIGO *) -(* The type [command] denotes some possible behaviours of the - compiler. The constructors are +(** The type [command] denotes some possible behaviours of the + compiler. The constructors are + {ul - * [Quiet], then no output from the lexer and parser should be - expected, safe error messages: this is the default value; - * [Copy], then lexemes of tokens and markup will be printed to - standard output, with the expectation of a perfect match with - the input file; - * [Units], then the tokens and markup will be printed to standard - output, that is, the abstract representation of the concrete - lexical syntax; - * [Tokens], then the tokens only will be printed. -*) + {li [Quiet], then no output from the lexer and parser should be + expected, safe error messages: this is the default value;} + {li [Copy], then lexemes of tokens and markup will be printed to + standard output, with the expectation of a perfect match + with the input file;} + + {li [Units], then the tokens and markup will be printed to + standard output, that is, the abstract representation of the + concrete lexical syntax;} + + {li [Tokens], then the tokens only will be printed.} + } + *) type command = Quiet | Copy | Units | Tokens -(* The type [options] gathers the command-line options. +(** The type [options] gathers the command-line options. + {ul - If the field [input] is [Some src], the name of the PascaLIGO - source file, with the extension ".ligo", is [src]. If [input] is - [Some "-"] or [None], the source file is read from standard input. + {li If the field [input] is [Some src], the name of the + PascaLIGO source file, with the extension ".ligo", is + [src]. If [input] is [Some "-"] or [None], the source file + is read from standard input.} - The field [libs] is the paths where to find PascaLIGO files for - inclusion (#include). + {li The field [libs] is the paths where to find PascaLIGO files + for inclusion (#include).} - The field [verbose] is a set of stages of the compiler chain, - about which more information may be displayed. + {li The field [verbose] is a set of stages of the compiler + chain, about which more information may be displayed.} - If the field [offsets] is [true], then the user requested that - messages about source positions and regions be expressed in terms - of horizontal offsets. + {li If the field [offsets] is [true], then the user requested + that messages about source positions and regions be + expressed in terms of horizontal offsets.} - If the value [mode] is [`Byte], then the unit in which source - positions and regions are expressed in messages is the byte. If - [`Point], the unit is unicode points. - -*) - -type options = { + {li If the value [mode] is [`Byte], then the unit in which + source positions and regions are expressed in messages is + the byte. If [`Point], the unit is unicode points.} + } + *) +type options = < input : string option; libs : string list; verbose : Utils.String.Set.t; offsets : bool; mode : [`Byte | `Point]; cmd : command -} +> -(* Parsing the command-line options on stdin. The first parameter is +val make : + input:string option -> + libs:string list -> + verbose:Utils.String.Set.t -> + offsets:bool -> + mode:[`Byte | `Point] -> + cmd:command -> options + +(** Parsing the command-line options on stdin. The first parameter is the name of the concrete syntax, e.g., "pascaligo", and the second is the file extension, e.g., ".ligo". *) - val read : string -> string -> options diff --git a/src/passes/1-parser/shared/Lexer.mll b/src/passes/1-parser/shared/Lexer.mll index 582860c51..41d95b432 100644 --- a/src/passes/1-parser/shared/Lexer.mll +++ b/src/passes/1-parser/shared/Lexer.mll @@ -1,6 +1,7 @@ (* Lexer specification for LIGO, to be processed by [ocamllex]. *) { +[@@@warning "-42"] module Region = Simple_utils.Region module Pos = Simple_utils.Pos diff --git a/src/passes/1-parser/shared/LexerLog.ml b/src/passes/1-parser/shared/LexerLog.ml index fdba7bad6..65655a720 100644 --- a/src/passes/1-parser/shared/LexerLog.ml +++ b/src/passes/1-parser/shared/LexerLog.ml @@ -1,4 +1,4 @@ -(* Embedding the lexer of PascaLIGO in a debug module *) +(** Embedding the LIGO lexer in a debug module *) let sprintf = Printf.sprintf @@ -24,10 +24,9 @@ module Make (Lexer: Lexer.S) : (S with module Lexer = Lexer) = module Lexer = Lexer module Token = Lexer.Token - (* Pretty-printing in a string the lexemes making up the markup + (** Pretty-printing in a string the lexemes making up the markup between two tokens, concatenated with the last lexeme itself. *) - let output_token ?(offsets=true) mode command channel left_mark token : unit = let output str = Printf.fprintf channel "%s%!" str in diff --git a/src/passes/2-simplify/ligodity.ml b/src/passes/2-simplify/ligodity.ml index 8ae0aa0ee..34443dcb0 100644 --- a/src/passes/2-simplify/ligodity.ml +++ b/src/passes/2-simplify/ligodity.ml @@ -100,8 +100,10 @@ module Errors = struct let title () = "simplifying expression" in let message () = "" in let data = [ - ("expression" , - thunk @@ Parser.Ligodity.ParserLog.expr_to_string t) + ("expression" , + (** TODO: The labelled arguments should be flowing from the CLI. *) + thunk @@ Parser.Ligodity.ParserLog.expr_to_string + ~offsets:true ~mode:`Point t) ] in error ~data title message @@ -350,7 +352,7 @@ let rec simpl_expression : return @@ e_literal ~loc (Literal_mutez n) ) | EArith (Neg e) -> simpl_unop "NEG" e - | EString (StrLit s) -> ( + | EString (String s) -> ( let (s , loc) = r_split s in let s' = let s = s in @@ -724,9 +726,11 @@ and simpl_cases : type a . (Raw.pattern * a) list -> (a, unit) matching result = | lst -> let error x = let title () = "Pattern" in + (** TODO: The labelled arguments should be flowing from the CLI. *) let content () = Printf.sprintf "Pattern : %s" - (Parser.Ligodity.ParserLog.pattern_to_string x) in + (Parser.Ligodity.ParserLog.pattern_to_string + ~offsets:true ~mode:`Point x) in error title content in let as_variant () = diff --git a/src/passes/2-simplify/pascaligo.ml b/src/passes/2-simplify/pascaligo.ml index 5c79c4077..ae96ddc27 100644 --- a/src/passes/2-simplify/pascaligo.ml +++ b/src/passes/2-simplify/pascaligo.ml @@ -1,4 +1,4 @@ -open Trace +open! Trace open Ast_simplified module Raw = Parser.Pascaligo.AST @@ -13,12 +13,12 @@ let pseq_to_list = function | None -> [] | Some lst -> npseq_to_list lst let get_value : 'a Raw.reg -> 'a = fun x -> x.value -let is_compiler_generated = fun (name) -> String.contains (Var.to_name name) '#' +let is_compiler_generated name = String.contains (Var.to_name name) '#' let detect_local_declarations (for_body : expression) = let%bind aux = Self_ast_simplified.fold_expression (fun (nlist, cur_loop : expression_variable list * bool) (ass_exp : expression) -> - if cur_loop then + if cur_loop then match ass_exp.expression with | E_let_in {binder;rhs = _;result = _} -> let (name,_) = binder in @@ -45,14 +45,14 @@ let detect_free_variables (for_body : expression) (local_decl_names : expression when n=C_OR || n=C_AND || n=C_LT || n=C_GT || n=C_LE || n=C_GE || n=C_EQ || n=C_NEQ -> ( match (a.expression,b.expression) with - | E_variable na , E_variable nb -> + | E_variable na , E_variable nb -> let ret = [] in let ret = if not (is_compiler_generated na) then na::ret else ret in let ret = if not (is_compiler_generated nb) then nb::ret else ret in ok (ret@prev) - | E_variable n , _ + | E_variable n , _ | _ , E_variable n -> if not (is_compiler_generated n) then ok (n::prev) else ok prev @@ -140,8 +140,10 @@ module Errors = struct let data = [ ("pattern_loc", fun () -> Format.asprintf "%a" Location.pp_lift @@ pattern_loc) ; + (** TODO: The labelled arguments should be flowing from the CLI. *) ("pattern", - fun () -> Parser.Pascaligo.ParserLog.pattern_to_string p) + fun () -> Parser.Pascaligo.ParserLog.pattern_to_string + ~offsets:true ~mode:`Point p) ] in error ~data title message @@ -189,9 +191,11 @@ module Errors = struct let simplifying_instruction t = let title () = "simplifiying instruction" in let message () = "" in + (** TODO: The labelled arguments should be flowing from the CLI. *) let data = [ ("instruction", - fun () -> Parser.Pascaligo.ParserLog.instruction_to_string t) + fun () -> Parser.Pascaligo.ParserLog.instruction_to_string + ~offsets:true ~mode:`Point t) ] in error ~data title message end @@ -569,11 +573,6 @@ and simpl_tuple_expression ?loc (lst:Raw.expr list) : expression result = let%bind lst = bind_list @@ List.map simpl_expression lst in return @@ e_tuple ?loc lst -and simpl_local_declaration : Raw.local_decl -> _ result = fun t -> - match t with - | LocalData d -> - simpl_data_declaration d - and simpl_data_declaration : Raw.data_decl -> _ result = fun t -> match t with | LocalVar x -> @@ -612,10 +611,10 @@ and simpl_fun_expression : loc:_ -> Raw.fun_expr -> ((expression_variable option * type_expression option) * expression) result = fun ~loc x -> let open! Raw in - let {name;param;ret_type;local_decls;block;return} : fun_expr = x in + let {name;param;ret_type;block_with;return} : fun_expr = x in let statements = - match block with - | Some block -> npseq_to_list block.value.statements + match block_with with + | Some (block,_) -> npseq_to_list block.value.statements | None -> [] in (match param.value.inside with @@ -623,14 +622,12 @@ and simpl_fun_expression : let%bind input = simpl_param a in let name = Option.map (fun (x : _ reg) -> Var.of_name x.value) name in let (binder , input_type) = input in - let%bind local_declarations = - bind_map_list simpl_local_declaration local_decls in let%bind instructions = bind_list @@ List.map simpl_statement @@ statements in let%bind result = simpl_expression return in let%bind output_type = simpl_type_expression ret_type in - let body = local_declarations @ instructions in + let body = instructions in let%bind result = let aux prec cur = cur (Some prec) in bind_fold_right_list aux result body in @@ -654,14 +651,12 @@ and simpl_fun_expression : ass in bind_list @@ List.mapi aux params in - let%bind local_declarations = - bind_map_list simpl_local_declaration local_decls in let%bind instructions = bind_list @@ List.map simpl_statement @@ statements in let%bind result = simpl_expression return in let%bind output_type = simpl_type_expression ret_type in - let body = tpl_declarations @ local_declarations @ instructions in + let body = tpl_declarations @ instructions in let%bind result = let aux prec cur = cur (Some prec) in bind_fold_right_list aux result body in @@ -1002,9 +997,11 @@ and simpl_cases : type a . (Raw.pattern * a) list -> (a, unit) matching result = let aux (x , y) = let error = let title () = "Pattern" in + (** TODO: The labelled arguments should be flowing from the CLI. *) let content () = Printf.sprintf "Pattern : %s" - (Parser.Pascaligo.ParserLog.pattern_to_string x) in + (Parser.Pascaligo.ParserLog.pattern_to_string + ~offsets:true ~mode:`Point x) in error title content in let%bind x' = trace error @@ @@ -1113,7 +1110,7 @@ and simpl_for_int : Raw.for_int -> (_ -> expression result) result = fun fi -> - references to the iterated value ==> variable `#COMPILER#elt_X` Note: In the case of an inner loop capturing variable from an outer loop the free variable name can be `#COMPILER#acc.Y` and because we do not - capture the accumulator record in the inner loop, we don't want to + capture the accumulator record in the inner loop, we don't want to generate `#COMPILER#acc.#COMPILER#acc.Y` but `#COMPILER#acc.Y` 5) Append the return value to the body @@ -1145,7 +1142,7 @@ and simpl_for_collect : Raw.for_collect -> (_ -> expression result) result = fun let elt_v_name = match fc.bind_to with | Some v -> "#COMPILER#elt_"^(snd v).value | None -> "#COMPILER#elt_unused" in - let element_names = ok @@ match fc.bind_to with + let element_names = ok @@ match fc.bind_to with | Some v -> [Var.of_name fc.var.value;Var.of_name (snd v).value] | None -> [Var.of_name fc.var.value] in (* STEP 1 *)