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

Printing of tokens from the AST is now done in a Buffer.t

Browse Source
This commit is contained in:
Christian Rinderknecht 2019-10-09 16:07:13 +02:00
parent a4ad62ad16
commit bcf73d01bf
13 changed files with 917 additions and 764 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

582
src/passes/1-parser/ligodity/ParserLog.ml
View File

@ -8,357 +8,455 @@ open! Region
let sprintf = Printf.sprintf let sprintf = Printf.sprintf
let offsets = ref true let offsets = ref true
let mode = ref `Point let mode = ref `Point
let compact (region: Region.t) = let compact (region: Region.t) =
region#compact ~offsets:!offsets !mode region#compact ~offsets:!offsets !mode
let print_nsepseq sep print (head,tail) = let print_nsepseq buffer sep print (head,tail) =
let print_aux ((sep_reg:Region.t), item) = let print_aux ((sep_reg:Region.t), item) =
Printf.printf "%s: %s\n" (compact sep_reg) sep; let sep_line = sprintf "%s: %s\n" (compact sep_reg) sep
print item in Buffer.add_string buffer sep_line;
in print head; List.iter print_aux tail print buffer item
in print buffer head; List.iter print_aux tail
let print_sepseq sep print = function let print_sepseq buffer sep print = function
None -> () None -> ()
| Some seq -> print_nsepseq sep print seq | Some seq -> print_nsepseq buffer sep print seq
let print_csv print = print_nsepseq "," print let print_csv buffer print = print_nsepseq buffer "," print
let print_token (reg: Region.t) conc = let print_token buffer (reg: Region.t) conc =
Printf.printf "%s: %s\n" (compact reg) conc let line = sprintf "%s: %s\n" (compact reg) conc
in Buffer.add_string buffer line
let print_var Region.{region; value} = let print_var buffer Region.{region; value} =
Printf.printf "%s: Ident %s\n" (compact region) value let line = sprintf "%s: Ident %s\n" (compact region) value
in Buffer.add_string buffer line
let print_uident Region.{region; value} = let print_pvar buffer Region.{region; value} =
Printf.printf "%s: Uident %s\n" (compact region) value let line = sprintf "%s: PVar %s\n" (compact region) value
in Buffer.add_string buffer line
let print_str Region.{region; value} = let print_uident buffer Region.{region; value} =
Printf.printf "%s: Str \"%s\"\n" (compact region) value let line = sprintf "%s: Uident %s\n" (compact region) value
in Buffer.add_string buffer line
let print_bytes Region.{region; value=lexeme, abstract} = let print_str buffer Region.{region; value} =
Printf.printf "%s: Bytes (\"%s\", \"0x%s\")\n" let line = sprintf "%s: Str \"%s\"\n" (compact region) value
(compact region) lexeme (Hex.to_string abstract) in Buffer.add_string buffer line
let rec print_tokens {decl;eof} = let print_bytes buffer Region.{region; value=lexeme, abstract} =
Utils.nseq_iter print_statement decl; print_token eof "EOF" let line = sprintf "%s: Bytes (\"%s\", \"0x%s\")\n"
(compact region) lexeme (Hex.to_string abstract)
in Buffer.add_string buffer line
and print_statement = function let print_int buffer Region.{region; value=lex,z} =
let line = sprintf "PInt %s (%s)" lex (Z.to_string z)
in print_token buffer region line
let rec print_tokens buffer {decl;eof} =
Utils.nseq_iter (print_statement buffer) decl;
print_token buffer eof "EOF"
and print_statement buffer = function
Let {value=kwd_let, let_binding; _} -> Let {value=kwd_let, let_binding; _} ->
print_token kwd_let "let"; print_token buffer kwd_let "let";
print_let_binding let_binding print_let_binding buffer let_binding
| LetEntry {value=kwd_let_entry, let_binding; _} -> | LetEntry {value=kwd_let_entry, let_binding; _} ->
print_token kwd_let_entry "let%entry"; print_token buffer kwd_let_entry "let%entry";
print_let_binding let_binding print_let_binding buffer let_binding
| TypeDecl {value={kwd_type; name; eq; type_expr}; _} -> | TypeDecl {value={kwd_type; name; eq; type_expr}; _} ->
print_token kwd_type "type"; print_token buffer kwd_type "type";
print_var name; print_var buffer name;
print_token eq "="; print_token buffer eq "=";
print_type_expr type_expr print_type_expr buffer type_expr
and print_type_expr = function and print_type_expr buffer = function
TProd prod -> print_cartesian prod TProd prod -> print_cartesian buffer prod
| TSum {value; _} -> print_nsepseq "|" print_variant value | TSum {value; _} -> print_nsepseq buffer "|" print_variant value
| TRecord t -> print_record_type t | TRecord t -> print_record_type buffer t
| TApp app -> print_type_app app | TApp app -> print_type_app buffer app
| TPar par -> print_type_par par | TPar par -> print_type_par buffer par
| TAlias var -> print_var var | TAlias var -> print_var buffer var
| TFun t -> print_fun_type t | TFun t -> print_fun_type buffer t
and print_fun_type {value; _} = and print_fun_type buffer {value; _} =
let domain, arrow, range = value in let domain, arrow, range = value in
print_type_expr domain; print_type_expr buffer domain;
print_token arrow "->"; print_token buffer arrow "->";
print_type_expr range print_type_expr buffer range
and print_type_app {value; _} = and print_type_app buffer {value; _} =
let type_constr, type_tuple = value in let type_constr, type_tuple = value in
print_type_tuple type_tuple; print_type_tuple buffer type_tuple;
print_var type_constr print_var buffer type_constr
and print_type_tuple {value; _} = and print_type_tuple buffer {value; _} =
let {lpar; inside; rpar} = value in let {lpar; inside; rpar} = value in
print_token lpar "("; print_token buffer lpar "(";
print_nsepseq "," print_type_expr inside; print_nsepseq buffer "," print_type_expr inside;
print_token rpar ")" print_token buffer rpar ")"
and print_type_par {value={lpar;inside=t;rpar}; _} = and print_type_par buffer {value={lpar;inside=t;rpar}; _} =
print_token lpar "("; print_token buffer lpar "(";
print_type_expr t; print_type_expr buffer t;
print_token rpar ")" print_token buffer rpar ")"
and print_projection node = and print_projection buffer node =
let {struct_name; selector; field_path} = node in let {struct_name; selector; field_path} = node in
print_var struct_name; print_var buffer struct_name;
print_token selector "."; print_token buffer selector ".";
print_nsepseq "." print_selection field_path print_nsepseq buffer "." print_selection field_path
and print_selection = function and print_selection buffer = function
FieldName id -> print_var id FieldName id ->
print_var buffer id
| Component {value; _} -> | Component {value; _} ->
let {lpar; inside; rpar} = value in let {lpar; inside; rpar} = value in
let Region.{value=lexeme,z; region} = inside in let Region.{value=lexeme,z; region} = inside in
print_token lpar "("; print_token buffer lpar "(";
print_token region print_token buffer region
(sprintf "Int %s (%s)" lexeme (Z.to_string z)); (sprintf "Int %s (%s)" lexeme (Z.to_string z));
print_token rpar ")" print_token buffer rpar ")"
and print_cartesian Region.{value;_} = and print_cartesian buffer Region.{value;_} =
print_nsepseq "*" print_type_expr value print_nsepseq buffer "*" print_type_expr value
and print_variant {value = {constr; args}; _} = and print_variant buffer {value = {constr; args}; _} =
print_uident constr; print_uident buffer constr;
match args with match args with
None -> () None -> ()
| Some (kwd_of, cartesian) -> | Some (kwd_of, cartesian) ->
print_token kwd_of "of"; print_token buffer kwd_of "of";
print_cartesian cartesian print_cartesian buffer cartesian
and print_record_type record_type = and print_record_type buffer record_type =
print_injection print_field_decl record_type print_injection buffer print_field_decl record_type
and print_field_decl {value; _} = and print_field_decl buffer {value; _} =
let {field_name; colon; field_type} = value let {field_name; colon; field_type} = value
in print_var field_name; in print_var buffer field_name;
print_token colon ":"; print_token buffer colon ":";
print_type_expr field_type print_type_expr buffer field_type
and print_injection : and print_injection :
'a.('a -> unit) -> 'a injection reg -> unit = 'a.Buffer.t -> (Buffer.t -> 'a -> unit) -> 'a injection reg -> unit =
fun print {value; _} -> fun buffer print {value; _} ->
let {opening; elements; terminator; closing} = value in let {opening; elements; terminator; closing} = value in
print_opening opening; print_opening buffer opening;
print_sepseq ";" print elements; print_sepseq buffer ";" print elements;
print_terminator terminator; print_terminator buffer terminator;
print_closing closing print_closing buffer closing
and print_opening = function and print_opening buffer = function
Begin region -> print_token region "begin" Begin region -> print_token buffer region "begin"
| With region -> print_token region "with" | With region -> print_token buffer region "with"
| LBrace region -> print_token region "{" | LBrace region -> print_token buffer region "{"
| LBracket region -> print_token region "[" | LBracket region -> print_token buffer region "["
and print_closing = function and print_closing buffer = function
End region -> print_token region "end" End region -> print_token buffer region "end"
| RBrace region -> print_token region "}" | RBrace region -> print_token buffer region "}"
| RBracket region -> print_token region "]" | RBracket region -> print_token buffer region "]"
and print_terminator = function and print_terminator buffer = function
Some semi -> print_token semi ";" Some semi -> print_token buffer semi ";"
| None -> () | None -> ()
and print_let_binding {bindings; lhs_type; eq; let_rhs} = and print_let_binding buffer {bindings; lhs_type; eq; let_rhs} =
List.iter print_pattern bindings; let () = List.iter (print_pattern buffer) bindings in
(match lhs_type with let () =
None -> () match lhs_type with
| Some (colon, type_expr) -> None -> ()
print_token colon ":"; | Some (colon, type_expr) ->
print_type_expr type_expr); print_token buffer colon ":";
(print_token eq "="; print_expr let_rhs) print_type_expr buffer type_expr in
let () = print_token buffer eq "="
in print_expr buffer let_rhs
and print_pattern = function and print_pattern buffer = function
PTuple {value=patterns;_} -> print_csv print_pattern patterns PTuple {value=patterns;_} ->
| PList p -> print_list_pattern p print_csv buffer print_pattern patterns
| PVar {region; value} -> | PList p ->
Printf.printf "%s: PVar %s\n" (compact region) value print_list_pattern buffer p
| PVar v ->
print_pvar buffer v
| PUnit {value=lpar,rpar; _} -> | PUnit {value=lpar,rpar; _} ->
print_token lpar "("; print_token rpar ")" print_token buffer lpar "(";
| PInt {region; value=lex,z} -> print_token buffer rpar ")"
print_token region (sprintf "PInt %s (%s)" lex (Z.to_string z)) | PInt i ->
| PTrue kwd_true -> print_token kwd_true "true" print_int buffer i
| PFalse kwd_false -> print_token kwd_false "false" | PTrue kwd_true ->
| PString s -> print_str s print_token buffer kwd_true "true"
| PWild wild -> print_token wild "_" | PFalse kwd_false ->
print_token buffer kwd_false "false"
| PString s ->
print_str buffer s
| PWild wild ->
print_token buffer wild "_"
| PPar {value={lpar;inside=p;rpar}; _} -> | PPar {value={lpar;inside=p;rpar}; _} ->
print_token lpar "("; print_pattern p; print_token rpar ")" print_token buffer lpar "(";
| PConstr p -> print_constr_pattern p print_pattern buffer p;
| PRecord r -> print_record_pattern r print_token buffer rpar ")"
| PTyped t -> print_typed_pattern t | PConstr p ->
print_constr_pattern buffer p
| PRecord r ->
print_record_pattern buffer r
| PTyped t ->
print_typed_pattern buffer t
and print_list_pattern = function and print_list_pattern buffer = function
Sugar p -> print_injection print_pattern p Sugar p -> print_injection buffer print_pattern p
| PCons p -> print_raw p | PCons p -> print_raw buffer p
and print_raw {value=p1,c,p2; _} = and print_raw buffer {value=p1,c,p2; _} =
print_pattern p1; print_token c "::"; print_pattern p2 print_pattern buffer p1;
print_token buffer c "::";
print_pattern buffer p2
and print_typed_pattern {value; _} = and print_typed_pattern buffer {value; _} =
let {pattern; colon; type_expr} = value in let {pattern; colon; type_expr} = value in
print_pattern pattern; print_pattern buffer pattern;
print_token colon ":"; print_token buffer colon ":";
print_type_expr type_expr print_type_expr buffer type_expr
and print_record_pattern record_pattern = and print_record_pattern buffer record_pattern =
print_injection print_field_pattern record_pattern print_injection buffer print_field_pattern record_pattern
and print_field_pattern {value; _} = and print_field_pattern buffer {value; _} =
let {field_name; eq; pattern} = value in let {field_name; eq; pattern} = value in
print_var field_name; print_var buffer field_name;
print_token eq "="; print_token buffer eq "=";
print_pattern pattern print_pattern buffer pattern
and print_constr_pattern {value=constr, p_opt; _} = and print_constr_pattern buffer {value=constr, p_opt; _} =
print_uident constr; print_uident buffer constr;
match p_opt with match p_opt with
None -> () None -> ()
| Some pattern -> print_pattern pattern | Some pattern -> print_pattern buffer pattern
and print_expr = function and print_expr buffer = function
ELetIn {value;_} -> print_let_in value ELetIn {value;_} -> print_let_in buffer value
| ECond cond -> print_conditional cond | ECond cond -> print_conditional buffer cond
| ETuple {value;_} -> print_csv print_expr value | ETuple {value;_} -> print_csv buffer print_expr value
| ECase {value;_} -> print_match_expr value | ECase {value;_} -> print_match_expr buffer value
| EFun e -> print_fun_expr e | EFun e -> print_fun_expr buffer e
| EAnnot e -> print_annot_expr e | EAnnot e -> print_annot_expr buffer e
| ELogic e -> print_logic_expr e | ELogic e -> print_logic_expr buffer e
| EArith e -> print_arith_expr e | EArith e -> print_arith_expr buffer e
| EString e -> print_string_expr e | EString e -> print_string_expr buffer e
| ECall {value=f,l; _} -> | ECall {value=f,l; _} ->
print_expr f; Utils.nseq_iter print_expr l print_expr buffer f;
| EVar v -> print_var v Utils.nseq_iter (print_expr buffer) l
| EProj p -> print_projection p.value | EVar v ->
print_var buffer v
| EProj p ->
print_projection buffer p.value
| EUnit {value=lpar,rpar; _} -> | EUnit {value=lpar,rpar; _} ->
print_token lpar "("; print_token rpar ")" print_token buffer lpar "(";
| EBytes b -> print_bytes b print_token buffer rpar ")"
| EBytes b ->
print_bytes buffer b
| EPar {value={lpar;inside=e;rpar}; _} -> | EPar {value={lpar;inside=e;rpar}; _} ->
print_token lpar "("; print_expr e; print_token rpar ")" print_token buffer lpar "(";
| EList e -> print_list_expr e print_expr buffer e;
| ESeq seq -> print_sequence seq print_token buffer rpar ")"
| ERecord e -> print_record_expr e | EList e ->
| EConstr {value=constr,None; _} -> print_uident constr print_list_expr buffer e
| ESeq seq ->
print_sequence buffer seq
| ERecord e ->
print_record_expr buffer e
| EConstr {value=constr,None; _} ->
print_uident buffer constr
| EConstr {value=(constr, Some arg); _} -> | EConstr {value=(constr, Some arg); _} ->
print_uident constr; print_expr arg print_uident buffer constr;
print_expr buffer arg
and print_annot_expr {value=e,t; _} = and print_annot_expr buffer {value=e,t; _} =
print_expr e; print_expr buffer e;
print_token Region.ghost ":"; print_token buffer Region.ghost ":";
print_type_expr t print_type_expr buffer t
and print_list_expr = function and print_list_expr buffer = function
Cons {value={arg1;op;arg2}; _} -> Cons {value={arg1;op;arg2}; _} ->
print_expr arg1; print_expr buffer arg1;
print_token op "::"; print_token buffer op "::";
print_expr arg2 print_expr buffer arg2
| List e -> print_injection print_expr e | List e -> print_injection buffer print_expr e
(*| Append {value=e1,append,e2; _} -> (*
print_expr e1; | Append {value=e1,append,e2; _} ->
print_token append "@"; print_expr buffer e1;
print_expr e2 *) print_token buffer append "@";
print_expr buffer e2
*)
and print_arith_expr = function and print_arith_expr buffer = function
Add {value={arg1;op;arg2}; _} -> Add {value={arg1;op;arg2}; _} ->
print_expr arg1; print_token op "+"; print_expr arg2 print_expr buffer arg1;
print_token buffer op "+";
print_expr buffer arg2
| Sub {value={arg1;op;arg2}; _} -> | Sub {value={arg1;op;arg2}; _} ->
print_expr arg1; print_token op "-"; print_expr arg2 print_expr buffer arg1;
print_token buffer op "-";
print_expr buffer arg2
| Mult {value={arg1;op;arg2}; _} -> | Mult {value={arg1;op;arg2}; _} ->
print_expr arg1; print_token op "*"; print_expr arg2 print_expr buffer arg1;
print_token buffer op "*";
print_expr buffer arg2
| Div {value={arg1;op;arg2}; _} -> | Div {value={arg1;op;arg2}; _} ->
print_expr arg1; print_token op "/"; print_expr arg2 print_expr buffer arg1;
print_token buffer op "/";
print_expr buffer arg2
| Mod {value={arg1;op;arg2}; _} -> | Mod {value={arg1;op;arg2}; _} ->
print_expr arg1; print_token op "mod"; print_expr arg2 print_expr buffer arg1;
| Neg {value={op;arg}; _} -> print_token op "-"; print_expr arg print_token buffer op "mod";
print_expr buffer arg2
| Neg {value={op;arg}; _} ->
print_token buffer op "-";
print_expr buffer arg
| Int {region; value=lex,z} -> | Int {region; value=lex,z} ->
print_token region (sprintf "Int %s (%s)" lex (Z.to_string z)) let line = sprintf "Int %s (%s)" lex (Z.to_string z)
in print_token buffer region line
| Mtz {region; value=lex,z} -> | Mtz {region; value=lex,z} ->
print_token region (sprintf "Mtz %s (%s)" lex (Z.to_string z)) let line = sprintf "Mtz %s (%s)" lex (Z.to_string z)
in print_token buffer region line
| Nat {region; value=lex,z} -> | Nat {region; value=lex,z} ->
print_token region (sprintf "Nat %s (%s)" lex (Z.to_string z)) let line = sprintf "Nat %s (%s)" lex (Z.to_string z)
in print_token buffer region line
and print_string_expr = function and print_string_expr buffer = function
Cat {value={arg1;op;arg2}; _} -> Cat {value={arg1;op;arg2}; _} ->
print_expr arg1; print_token op "^"; print_expr arg2 print_expr buffer arg1;
| String s -> print_str s print_token buffer op "^";
print_expr buffer arg2
| String s ->
print_str buffer s
and print_logic_expr = function and print_logic_expr buffer = function
BoolExpr e -> print_bool_expr e BoolExpr e -> print_bool_expr buffer e
| CompExpr e -> print_comp_expr e | CompExpr e -> print_comp_expr buffer e
and print_bool_expr = function and print_bool_expr buffer = function
Or {value={arg1;op;arg2}; _} -> Or {value={arg1;op;arg2}; _} ->
print_expr arg1; print_token op "||"; print_expr arg2 print_expr buffer arg1;
print_token buffer op "||";
print_expr buffer arg2
| And {value={arg1;op;arg2}; _} -> | And {value={arg1;op;arg2}; _} ->
print_expr arg1; print_token op "&&"; print_expr arg2 print_expr buffer arg1;
| Not {value={op;arg}; _} -> print_token op "not"; print_expr arg print_token buffer op "&&";
| True kwd_true -> print_token kwd_true "true" print_expr buffer arg2
| False kwd_false -> print_token kwd_false "false" | Not {value={op;arg}; _} ->
print_token buffer op "not";
print_expr buffer arg
| True kwd_true ->
print_token buffer kwd_true "true"
| False kwd_false ->
print_token buffer kwd_false "false"
and print_comp_expr = function and print_comp_expr buffer = function
Lt {value={arg1;op;arg2}; _} -> Lt {value={arg1;op;arg2}; _} ->
print_expr arg1; print_token op "<"; print_expr arg2 print_expr buffer arg1;
print_token buffer op "<";
print_expr buffer arg2
| Leq {value={arg1;op;arg2}; _} -> | Leq {value={arg1;op;arg2}; _} ->
print_expr arg1; print_token op "<="; print_expr arg2 print_expr buffer arg1;
print_token buffer op "<=";
print_expr buffer arg2
| Gt {value={arg1;op;arg2}; _} -> | Gt {value={arg1;op;arg2}; _} ->
print_expr arg1; print_token op ">"; print_expr arg2 print_expr buffer arg1;
print_token buffer op ">";
print_expr buffer arg2
| Geq {value={arg1;op;arg2}; _} -> | Geq {value={arg1;op;arg2}; _} ->
print_expr arg1; print_token op ">="; print_expr arg2 print_expr buffer arg1;
print_token buffer op ">=";
print_expr buffer arg2
| Neq {value={arg1;op;arg2}; _} -> | Neq {value={arg1;op;arg2}; _} ->
print_expr arg1; print_token op "<>"; print_expr arg2 print_expr buffer arg1;
print_token buffer op "<>";
print_expr buffer arg2
| Equal {value={arg1;op;arg2}; _} -> | Equal {value={arg1;op;arg2}; _} ->
print_expr arg1; print_token op "="; print_expr arg2 print_expr buffer arg1;
print_token buffer op "=";
print_expr buffer arg2
and print_record_expr e = and print_record_expr buffer e =
print_injection print_field_assign e print_injection buffer print_field_assign e
and print_field_assign {value; _} = and print_field_assign buffer {value; _} =
let {field_name; assignment; field_expr} = value in let {field_name; assignment; field_expr} = value in
print_var field_name; print_var buffer field_name;
print_token assignment "="; print_token buffer assignment "=";
print_expr field_expr print_expr buffer field_expr
and print_sequence seq = print_injection print_expr seq and print_sequence buffer seq =
print_injection buffer print_expr seq
and print_match_expr expr = and print_match_expr buffer expr =
let {kwd_match; expr; opening; let {kwd_match; expr; opening;
lead_vbar; cases; closing} = expr in lead_vbar; cases; closing} = expr in
print_token kwd_match "match"; print_token buffer kwd_match "match";
print_expr expr; print_expr buffer expr;
print_opening opening; print_opening buffer opening;
print_token_opt lead_vbar "|"; print_token_opt buffer lead_vbar "|";
print_cases cases; print_cases buffer cases;
print_closing closing print_closing buffer closing
and print_token_opt = function and print_token_opt buffer = function
None -> fun _ -> () None -> fun _ -> ()
| Some region -> print_token region | Some region -> print_token buffer region
and print_cases {value; _} = and print_cases buffer {value; _} =
print_nsepseq "|" print_case_clause value print_nsepseq buffer "|" print_case_clause value
and print_case_clause {value; _} = and print_case_clause buffer {value; _} =
let {pattern; arrow; rhs} = value in let {pattern; arrow; rhs} = value in
print_pattern pattern; print_pattern buffer pattern;
print_token arrow "->"; print_token buffer arrow "->";
print_expr rhs print_expr buffer rhs
and print_let_in (bind: let_in) = and print_let_in buffer (bind: let_in) =
let {kwd_let; binding; kwd_in; body} = bind in let {kwd_let; binding; kwd_in; body} = bind in
print_token kwd_let "let"; print_token buffer kwd_let "let";
print_let_binding binding; print_let_binding buffer binding;
print_token kwd_in "in"; print_token buffer kwd_in "in";
print_expr body print_expr buffer body
and print_fun_expr {value; _} = and print_fun_expr buffer {value; _} =
let {kwd_fun; params; p_annot; arrow; body} = value in let {kwd_fun; params; p_annot; arrow; body} = value in
print_token kwd_fun "fun"; let () = print_token buffer kwd_fun "fun" in
(match p_annot with let () =
None -> List.iter print_pattern params match p_annot with
| Some (colon, type_expr) -> None -> List.iter (print_pattern buffer) params
print_token colon ":"; | Some (colon, type_expr) ->
print_type_expr type_expr); print_token buffer colon ":";
print_token arrow "->"; print_type_expr buffer type_expr in
print_expr body let () =
print_token buffer arrow "->"
in print_expr buffer body
and print_conditional {value; _} = and print_conditional buffer {value; _} =
let {kwd_if; test; kwd_then; ifso; kwd_else; ifnot} = value let {kwd_if; test; kwd_then;
in print_token ghost "("; ifso; kwd_else; ifnot} = value in
print_token kwd_if "if"; print_token buffer ghost "(";
print_expr test; print_token buffer kwd_if "if";
print_token kwd_then "then"; print_expr buffer test;
print_expr ifso; print_token buffer kwd_then "then";
print_token kwd_else "else"; print_expr buffer ifso;
print_expr ifnot; print_token buffer kwd_else "else";
print_token ghost ")" print_expr buffer ifnot;
print_token buffer ghost ")"
(* Conversion to string *)
let to_string printer node =
let buffer = Buffer.create 131 in
let () = printer buffer 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

15
src/passes/1-parser/ligodity/ParserLog.mli
View File

@ -10,13 +10,10 @@ val mode : [`Byte | `Point] ref
the AST to be unparsed before printing (those nodes that have been the AST to be unparsed before printing (those nodes that have been
normalised with function [norm_let] and [norm_fun]). *) normalised with function [norm_let] and [norm_fun]). *)
val print_tokens : AST.t -> unit 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_path : AST.path -> unit *) val tokens_to_string : AST.t -> string
val print_pattern : AST.pattern -> unit val pattern_to_string : AST.pattern -> string
val print_expr : AST.expr -> unit val expr_to_string : AST.expr -> string
(* val print_instruction : AST.instruction -> unit *)
(* val print_projection : projection -> unit
val print_pattern : pattern -> unit
val print_expr : expr -> unit *)

6
src/passes/1-parser/ligodity/ParserMain.ml
View File

@ -103,10 +103,12 @@ let () =
try try
let ast = Parser.contract tokeniser buffer in let ast = Parser.contract tokeniser buffer in
if Utils.String.Set.mem "ast" options.verbose if Utils.String.Set.mem "ast" options.verbose
then begin then let buffer = Buffer.create 131 in
begin
ParserLog.offsets := options.offsets; ParserLog.offsets := options.offsets;
ParserLog.mode := options.mode; ParserLog.mode := options.mode;
ParserLog.print_tokens ast ParserLog.print_tokens buffer ast;
Buffer.output_buffer stdout buffer
end end
with with
Lexer.Error err -> Lexer.Error err ->

13
src/passes/1-parser/ligodity/Tests/match.mml
View File

@ -1,13 +0,0 @@
type storage = int
type param =
Add of int
| Sub of int
let%entry main (p : param) storage =
let storage =
storage +
(match p with
Add n -> n
| Sub n -> 0-n)
in (([] : operation list), storage)

0
src/passes/1-parser/pascaligo/.SParserMain.tag
View File

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

File diff suppressed because it is too large Load Diff

12
src/passes/1-parser/pascaligo/ParserLog.mli
View File

@ -3,8 +3,12 @@
val offsets : bool ref val offsets : bool ref
val mode : [`Byte | `Point] ref val mode : [`Byte | `Point] ref
val print_tokens : AST.t -> unit 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 print_path : AST.path -> unit val tokens_to_string : AST.t -> string
val print_pattern : AST.pattern -> unit val path_to_string : AST.path -> string
val print_instruction : AST.instruction -> unit val pattern_to_string : AST.pattern -> string
val instruction_to_string : AST.instruction -> string

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

@ -103,10 +103,12 @@ let () =
try try
let ast = Parser.contract tokeniser buffer in let ast = Parser.contract tokeniser buffer in
if Utils.String.Set.mem "ast" options.verbose if Utils.String.Set.mem "ast" options.verbose
then begin then let buffer = Buffer.create 131 in
begin
ParserLog.offsets := options.offsets; ParserLog.offsets := options.offsets;
ParserLog.mode := options.mode; ParserLog.mode := options.mode;
ParserLog.print_tokens ast ParserLog.print_tokens buffer ast;
Buffer.output_buffer stdout buffer
end end
with with
Lexer.Error err -> Lexer.Error err ->

10
src/passes/1-parser/pascaligo/SParserMain.ml
View File

@ -105,10 +105,12 @@ let () =
try try
let ast = Parser.contract tokeniser buffer in let ast = Parser.contract tokeniser buffer in
if Utils.String.Set.mem "ast" options.verbose if Utils.String.Set.mem "ast" options.verbose
then begin then let buffer = Buffer.create 131
ParserLog.offsets := options.offsets; in begin
ParserLog.mode := options.mode; ParserLog.offsets := options.offsets;
ParserLog.print_tokens ast ParserLog.mode := options.mode;
ParserLog.print_tokens buffer ast;
Buffer.output_buffer stdout buffer
end end
with with
Lexer.Error err -> Lexer.Error err ->

2
src/passes/1-parser/pascaligo/Tests/crowdfunding.ligo
View File

@ -50,6 +50,6 @@ function withdraw (var store : store) : list (operation) * store is
operations := list [Transfer (owner, balance)]; operations := list [Transfer (owner, balance)];
}; };
else failwith ("Below target.") else failwith ("Below target.")
else fail "Too soon."; else failwith ("Too soon.");
else skip else skip
end with (operations, store) end with (operations, store)

7
src/passes/2-simplify/ligodity.ml
View File

@ -121,7 +121,7 @@ module Errors = struct
let message () = "" in let message () = "" in
let data = [ let data = [
("expression" , ("expression" ,
thunk @@ Format.asprintf "%a" PP_helpers.(printer Parser.Ligodity.ParserLog.print_expr) t) thunk @@ Parser.Ligodity.ParserLog.expr_to_string t)
] in ] in
error ~data title message error ~data title message
@ -751,7 +751,8 @@ and simpl_cases : type a . (Raw.pattern * a) list -> a matching result =
let error x = let error x =
let title () = "Pattern" in let title () = "Pattern" in
let content () = let content () =
Format.asprintf "Pattern : %a" (PP_helpers.printer Parser.Ligodity.ParserLog.print_pattern) x in Printf.sprintf "Pattern : %s"
(Parser.Ligodity.ParserLog.pattern_to_string x) in
error title content error title content
in in
let as_variant () = let as_variant () =
@ -770,7 +771,7 @@ and simpl_cases : type a . (Raw.pattern * a) list -> a matching result =
ok @@ Match_variant constrs ok @@ Match_variant constrs
in in
let as_option () = let as_option () =
let aux (x , y) = let aux (x , y) =
let%bind x' = let%bind x' =
trace (error x) @@ trace (error x) @@
get_constr_opt x get_constr_opt x

13
src/passes/2-simplify/pascaligo.ml
View File

@ -175,9 +175,9 @@ module Errors = struct
] in ] in
error ~data title message *) error ~data title message *)
let unsupported_deep_set_rm path = let unsupported_deep_set_rm path =
let title () = "set removals" in let title () = "set removals" in
let message () = let message () =
Format.asprintf "removal of members from embedded sets is not supported yet" in Format.asprintf "removal of members from embedded sets is not supported yet" in
let data = [ let data = [
("path_loc", ("path_loc",
@ -217,7 +217,7 @@ module Errors = struct
("pattern_loc", ("pattern_loc",
fun () -> Format.asprintf "%a" Location.pp_lift @@ pattern_loc) ; fun () -> Format.asprintf "%a" Location.pp_lift @@ pattern_loc) ;
("pattern", ("pattern",
fun () -> Format.asprintf "%a" (Simple_utils.PP_helpers.printer Parser.Pascaligo.ParserLog.print_pattern) p) ; fun () -> Parser.Pascaligo.ParserLog.pattern_to_string p)
] in ] in
error ~data title message error ~data title message
@ -261,7 +261,7 @@ module Errors = struct
let message () = "" in let message () = "" in
let data = [ let data = [
("instruction", ("instruction",
fun () -> Format.asprintf "%a" PP_helpers.(printer Parser.Pascaligo.ParserLog.print_instruction) t) fun () -> Parser.Pascaligo.ParserLog.instruction_to_string t)
] in ] in
error ~data title message error ~data title message
end end
@ -855,7 +855,7 @@ and simpl_single_instruction : Raw.single_instr -> (_ -> expression result) resu
let (set_rm, loc) = r_split r in let (set_rm, loc) = r_split r in
let%bind set = match set_rm.set with let%bind set = match set_rm.set with
| Name v -> ok v.value | Name v -> ok v.value
| Path path -> fail @@ unsupported_deep_set_rm path in | Path path -> fail @@ unsupported_deep_set_rm path in
let%bind removed' = simpl_expression set_rm.element in let%bind removed' = simpl_expression set_rm.element in
let expr = e_constant ~loc "SET_REMOVE" [removed' ; e_variable set] in let expr = e_constant ~loc "SET_REMOVE" [removed' ; e_variable set] in
return_statement @@ e_assign ~loc set [] expr return_statement @@ e_assign ~loc set [] expr
@ -957,7 +957,8 @@ and simpl_cases : type a . (Raw.pattern * a) list -> a matching result = fun t -
let error = let error =
let title () = "Pattern" in let title () = "Pattern" in
let content () = let content () =
Format.asprintf "Pattern : %a" (PP_helpers.printer Parser.Pascaligo.ParserLog.print_pattern) x in Printf.sprintf "Pattern : %s"
(Parser.Pascaligo.ParserLog.pattern_to_string x) in
error title content in error title content in
let%bind x' = let%bind x' =
trace error @@ trace error @@

31
vendors/ligo-utils/simple-utils/PP_helpers.ml vendored
View File

@ -1,17 +1,28 @@
open Format open Format
let string : formatter -> string -> unit = fun ppf s -> fprintf ppf "%s" s let string : formatter -> string -> unit = fun ppf s -> fprintf ppf "%s" s
let tag tag : formatter -> unit -> unit = fun ppf () -> fprintf ppf tag let tag tag : formatter -> unit -> unit = fun ppf () -> fprintf ppf tag
let bool ppf b = fprintf ppf "%b" b let bool ppf b = fprintf ppf "%b" b
let pair f g ppf (a , b) = fprintf ppf "%a , %a" f a g b let pair f g ppf (a , b) = fprintf ppf "%a , %a" f a g b
let new_line : formatter -> unit -> unit = tag "@;" let new_line : formatter -> unit -> unit = tag "@;"
let rec new_lines n ppf () = let rec new_lines n ppf () =
match n with match n with
| 0 -> new_line ppf () | 0 -> new_line ppf ()
| n -> new_line ppf () ; new_lines (n-1) ppf () | n -> new_line ppf () ; new_lines (n-1) ppf ()
let const const : formatter -> unit -> unit = fun ppf () -> fprintf ppf "%s" const let const const : formatter -> unit -> unit = fun ppf () -> fprintf ppf "%s" const
let comment : formatter -> string -> unit = fun ppf s -> fprintf ppf "(* %s *)" s let comment : formatter -> string -> unit = fun ppf s -> fprintf ppf "(* %s *)" s
let list_sep value separator = pp_print_list ~pp_sep:separator value let list_sep value separator = pp_print_list ~pp_sep:separator value
let list value = pp_print_list ~pp_sep:(tag "") value let list value = pp_print_list ~pp_sep:(tag "") value
let ne_list_sep value separator ppf (hd, tl) = let ne_list_sep value separator ppf (hd, tl) =
value ppf hd ; value ppf hd ;
separator ppf () ; separator ppf () ;
@ -35,25 +46,11 @@ let int = fun ppf n -> fprintf ppf "%d" n
let map = fun f pp ppf x -> let map = fun f pp ppf x ->
pp ppf (f x) pp ppf (f x)
let pair_sep value sep ppf (a, b) = fprintf ppf "%a %s %a" value a sep value b let pair_sep value sep ppf (a, b) =
fprintf ppf "%a %s %a" value a sep value b
let smap_sep value sep ppf m = let smap_sep value sep ppf m =
let module SMap = X_map.String in let module SMap = X_map.String in
let lst = SMap.to_kv_list m in let lst = SMap.to_kv_list m in
let new_pp ppf (k, v) = fprintf ppf "%s -> %a" k value v in let new_pp ppf (k, v) = fprintf ppf "%s -> %a" k value v in
fprintf ppf "%a" (list_sep new_pp sep) lst fprintf ppf "%a" (list_sep new_pp sep) lst
(* TODO: remove all uses. this is bad. *)
let printer : ('a -> unit) -> _ -> 'a -> unit = fun f ppf x ->
let oldstdout = Unix.dup Unix.stdout in
let name = "/tmp/wtf-" ^ (string_of_int @@ Random.bits ()) in
let newstdout = open_out name in
Unix.dup2 (Unix.descr_of_out_channel newstdout) Unix.stdout;
f x;
flush stdout;
Unix.dup2 oldstdout Unix.stdout;
let ic = open_in name in
let n = in_channel_length ic in
let s = Bytes.create n in
really_input ic s 0 n;
close_in ic;
fprintf ppf "%s" (Bytes.to_string s)