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

Merge branch 'rinderknecht@pprint' into 'dev'

Browse Source 
Adding a pretty-printer for CameLIGO source files

See merge request ligolang/ligo!599
This commit is contained in:
Sander 2020-06-10 15:16:53 +00:00
commit 82a8ee5697
234 changed files with 8659 additions and 2118 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
src/bin/cli.ml
View File

@ -159,10 +159,22 @@ let preprocess =
let doc = "Subcommand: Preprocess the source file.\nWarning: Intended for development of LIGO and can break at any time." in
(Term.ret term, Term.info ~doc cmdname)
let pretty_print =
let f source_file syntax display_format = (
toplevel ~display_format @@
let%bind pp =
Compile.Of_source.pretty_print source_file (Syntax_name syntax) in
ok @@ Buffer.contents pp
) in
let term = Term.(const f $ source_file 0 $ syntax $ display_format) in
let cmdname = "pretty-print" in
let doc = "Subcommand: Pretty-print the source file."
in (Term.ret term, Term.info ~doc cmdname)
let print_cst =
let f source_file syntax display_format = (
toplevel ~display_format @@
let%bind pp = Compile.Of_source.pretty_print source_file (Syntax_name syntax) in
let%bind pp = Compile.Of_source.pretty_print_cst source_file (Syntax_name syntax) in
ok @@ Format.asprintf "%s \n" (Buffer.contents pp)
)
in
@ -489,5 +501,6 @@ let run ?argv () =
print_ast_typed ;
print_mini_c ;
list_declarations ;
preprocess
preprocess;
pretty_print
]

6
src/bin/expect_tests/help_tests.ml
View File

@ -57,6 +57,9 @@ let%expect_test _ =
Subcommand: Preprocess the source file. Warning: Intended for
development of LIGO and can break at any time.
pretty-print
Subcommand: Pretty-print the source file.
print-ast
Subcommand: Print the AST. Warning: Intended for development of
LIGO and can break at any time.
@ -148,6 +151,9 @@ let%expect_test _ =
Subcommand: Preprocess the source file. Warning: Intended for
development of LIGO and can break at any time.
pretty-print
Subcommand: Pretty-print the source file.
print-ast
Subcommand: Print the AST. Warning: Intended for development of
LIGO and can break at any time.

4
src/bin/expect_tests/literals.ml
View File

@ -7,7 +7,7 @@ let%expect_test _ =
let%expect_test _ =
run_ligo_bad ["interpret" ; "(\"thisisnotasignature\":signature)" ; "--syntax=pascaligo"] ;
[%expect {|
ligo: in file "", line 0, characters 1-32. Badly formatted literal: Signature thisisnotasignature {"location":"in file \"\", line 0, characters 1-32"}
ligo: in file "", line 0, characters 0-33. Badly formatted literal: Signature thisisnotasignature {"location":"in file \"\", line 0, characters 0-33"}
If you're not sure how to fix this error, you can
@ -25,7 +25,7 @@ let%expect_test _ =
let%expect_test _ =
run_ligo_bad ["interpret" ; "(\"thisisnotapublickey\":key)" ; "--syntax=pascaligo"] ;
[%expect {|
ligo: in file "", line 0, characters 1-26. Badly formatted literal: key thisisnotapublickey {"location":"in file \"\", line 0, characters 1-26"}
ligo: in file "", line 0, characters 0-27. Badly formatted literal: key thisisnotapublickey {"location":"in file \"\", line 0, characters 0-27"}
If you're not sure how to fix this error, you can

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

@ -129,7 +129,7 @@ let parsify_string syntax source =
let%bind applied = Self_ast_imperative.all_program parsified
in ok applied
let pretty_print_pascaligo source =
let pretty_print_pascaligo_cst source =
let%bind ast = Parser.Pascaligo.parse_file source in
let buffer = Buffer.create 59 in
let state =
@ -137,10 +137,10 @@ let pretty_print_pascaligo source =
~offsets:true
~mode:`Byte
~buffer in
Parser_pascaligo.ParserLog.pp_ast state ast;
Parser_pascaligo.ParserLog.pp_cst state ast;
ok buffer
let pretty_print_cameligo source =
let pretty_print_cameligo_cst source =
let%bind ast = Parser.Cameligo.parse_file source in
let buffer = Buffer.create 59 in
let state = (* TODO: Should flow from the CLI *)
@ -148,10 +148,10 @@ let pretty_print_cameligo source =
~offsets:true
~mode:`Point
~buffer in
Parser_cameligo.ParserLog.pp_ast state ast;
Parser_cameligo.ParserLog.pp_cst state ast;
ok buffer
let pretty_print_reasonligo source =
let pretty_print_reasonligo_cst source =
let%bind ast = Parser.Reasonligo.parse_file source in
let buffer = Buffer.create 59 in
let state = (* TODO: Should flow from the CLI *)
@ -159,16 +159,16 @@ let pretty_print_reasonligo source =
~offsets:true
~mode:`Point
~buffer in
Parser_cameligo.ParserLog.pp_ast state ast;
Parser_cameligo.ParserLog.pp_cst state ast;
ok buffer
let pretty_print syntax source =
let pretty_print_cst syntax source =
let%bind v_syntax =
syntax_to_variant syntax (Some source) in
match v_syntax with
PascaLIGO -> pretty_print_pascaligo source
| CameLIGO -> pretty_print_cameligo source
| ReasonLIGO -> pretty_print_reasonligo source
PascaLIGO -> pretty_print_pascaligo_cst source
| CameLIGO -> pretty_print_cameligo_cst source
| ReasonLIGO -> pretty_print_reasonligo_cst source
let preprocess_pascaligo = Parser.Pascaligo.preprocess
@ -183,3 +183,44 @@ let preprocess syntax source =
PascaLIGO -> preprocess_pascaligo source
| CameLIGO -> preprocess_cameligo source
| ReasonLIGO -> preprocess_reasonligo source
let pretty_print_pascaligo source =
let%bind ast = Parser.Pascaligo.parse_file source in
let doc = Parser_pascaligo.Pretty.print ast in
let buffer = Buffer.create 131 in
let width =
match Terminal_size.get_columns () with
None -> 60
| Some c -> c in
let () = PPrint.ToBuffer.pretty 1.0 width buffer doc
in Trace.ok buffer
let pretty_print_cameligo source =
let%bind ast = Parser.Cameligo.parse_file source in
let doc = Parser_cameligo.Pretty.print ast in
let buffer = Buffer.create 131 in
let width =
match Terminal_size.get_columns () with
None -> 60
| Some c -> c in
let () = PPrint.ToBuffer.pretty 1.0 width buffer doc
in Trace.ok buffer
let pretty_print_reasonligo source =
let%bind ast = Parser.Reasonligo.parse_file source in
let doc = Parser_reasonligo.Pretty.print ast in
let buffer = Buffer.create 131 in
let width =
match Terminal_size.get_columns () with
None -> 60
| Some c -> c in
let () = PPrint.ToBuffer.pretty 1.0 width buffer doc
in Trace.ok buffer
let pretty_print syntax source =
let%bind v_syntax =
syntax_to_variant syntax (Some source) in
match v_syntax with
PascaLIGO -> pretty_print_pascaligo source
| CameLIGO -> pretty_print_cameligo source
| ReasonLIGO -> pretty_print_reasonligo source

7
src/main/compile/of_source.ml
View File

@ -19,8 +19,11 @@ let compile_contract_input : string -> string -> v_syntax -> Ast_imperative.expr
let%bind (storage,parameter) = bind_map_pair (compile_expression syntax) (storage,parameter) in
ok @@ Ast_imperative.e_pair storage parameter
let pretty_print source_filename syntax =
Helpers.pretty_print syntax source_filename
let pretty_print_cst source_filename syntax =
Helpers.pretty_print_cst syntax source_filename
let preprocess source_filename syntax =
Helpers.preprocess syntax source_filename
let pretty_print source_filename syntax =
Helpers.pretty_print syntax source_filename

21
src/passes/01-parser/cameligo.ml
View File

@ -5,6 +5,7 @@ module Scoping = Parser_cameligo.Scoping
module Region = Simple_utils.Region
module ParErr = Parser_cameligo.ParErr
module SSet = Set.Make (String)
module Pretty = Parser_cameligo.Pretty
(* Mock IOs TODO: Fill them with CLI options *)
@ -19,7 +20,8 @@ module SubIO =
ext : string; (* ".mligo" *)
mode : [`Byte | `Point];
cmd : EvalOpt.command;
mono : bool
mono : bool;
pretty : bool
>
let options : options =
@ -34,6 +36,7 @@ module SubIO =
method mode = `Point
method cmd = EvalOpt.Quiet
method mono = false
method pretty = false
end
let make =
@ -46,6 +49,7 @@ module SubIO =
~mode:options#mode
~cmd:options#cmd
~mono:options#mono
~pretty:options#mono
end
module Parser =
@ -146,3 +150,18 @@ let parse_expression source = apply (fun () -> Unit.expr_in_string source)
(* Preprocessing a contract in a file *)
let preprocess source = apply (fun () -> Unit.preprocess source)
(* Pretty-print a file (after parsing it). *)
let pretty_print source =
match parse_file source with
Stdlib.Error _ as e -> e
| Ok ast ->
let doc = Pretty.print (fst ast) in
let buffer = Buffer.create 131 in
let width =
match Terminal_size.get_columns () with
None -> 60
| Some c -> c in
let () = PPrint.ToBuffer.pretty 1.0 width buffer doc
in Trace.ok buffer

3
src/passes/01-parser/cameligo.mli
View File

@ -19,3 +19,6 @@ val parse_expression : string -> AST.expr Trace.result
(** Preprocess a given CameLIGO file and preprocess it. *)
val preprocess : string -> Buffer.t Trace.result
(** Pretty-print a given CameLIGO file (after parsing it). *)
val pretty_print : string -> Buffer.t Trace.result

2
src/passes/01-parser/cameligo/.links
View File

@ -19,5 +19,3 @@ $HOME/git/OCaml-build/Makefile
../shared/LexerUnit.ml
../shared/ParserUnit.mli
../shared/ParserUnit.ml
$HOME/git/ligo/_build/default/src/passes/1-parser/cameligo/ParErr.ml

22
src/passes/01-parser/cameligo/AST.ml
View File

@ -137,11 +137,14 @@ and ast = t
and attributes = attribute list
and declaration =
Let of (kwd_let * kwd_rec option * let_binding * attributes) reg
Let of let_decl
| TypeDecl of type_decl reg
(* Non-recursive values *)
and let_decl =
(kwd_let * kwd_rec option * let_binding * attributes) reg
and let_binding = {
binders : pattern nseq;
lhs_type : (colon * type_expr) option;
@ -225,7 +228,7 @@ and field_pattern = {
and expr =
ECase of expr case reg
| ECond of cond_expr reg
| EAnnot of (expr * colon * type_expr) par reg
| EAnnot of annot_expr par reg
| ELogic of logic_expr
| EArith of arith_expr
| EString of string_expr
@ -244,6 +247,8 @@ and expr =
| EFun of fun_expr reg
| ESeq of expr injection reg
and annot_expr = expr * colon * type_expr
and 'a injection = {
compound : compound;
elements : ('a, semi) sepseq;
@ -336,18 +341,19 @@ and field_assign = {
}
and update = {
lbrace : lbrace;
record : path;
lbrace : lbrace;
record : path;
kwd_with : kwd_with;
updates : field_path_assign reg ne_injection reg;
rbrace : rbrace;
updates : field_path_assignment reg ne_injection reg;
rbrace : rbrace
}
and field_path_assign = {
field_path : (selection, dot) nsepseq;
and field_path_assignment = {
field_path : path;
assignment : equal;
field_expr : expr
}
and path =
Name of variable
| Path of projection reg

15
src/passes/01-parser/cameligo/LexToken.mll
View File

@ -431,21 +431,20 @@ type nat_err =
| Non_canonical_zero_nat
let mk_nat lexeme region =
match (String.index_opt lexeme 'n') with
match String.index_opt lexeme 'n' with
None -> Error Invalid_natural
| Some _ -> let z =
Str.(global_replace (regexp "_") "" lexeme) |>
Str.(global_replace (regexp "n") "") |>
Z.of_string in
Str.(global_replace (regexp "_") "" lexeme) |>
Str.(global_replace (regexp "n") "") |>
Z.of_string in
if Z.equal z Z.zero && lexeme <> "0n"
then Error Non_canonical_zero_nat
else Ok (Nat Region.{region; value = lexeme,z})
let mk_mutez lexeme region =
let z =
Str.(global_replace (regexp "_") "" lexeme) |>
Str.(global_replace (regexp "mutez") "") |>
Z.of_string in
let z = Str.(global_replace (regexp "_") "" lexeme) |>
Str.(global_replace (regexp "mutez") "") |>
Z.of_string in
if Z.equal z Z.zero && lexeme <> "0mutez"
then Error Non_canonical_zero
else Ok (Mutez Region.{region; value = lexeme, z})

53
src/passes/01-parser/cameligo/Parser.mly
View File

@ -86,7 +86,7 @@ nsepseq(item,sep):
(* Non-empty comma-separated values (at least two values) *)
tuple(item):
item "," nsepseq(item,",") { let h,t = $3 in $1,($2,h)::t }
item "," nsepseq(item,",") { let h,t = $3 in $1, ($2,h)::t }
(* Possibly empty semicolon-separated values between brackets *)
@ -236,10 +236,7 @@ type_annotation:
irrefutable:
sub_irrefutable { $1 }
| tuple(sub_irrefutable) {
let hd, tl = $1 in
let start = pattern_to_region hd in
let stop = last fst tl in
let region = cover start stop
let region = nsepseq_to_region pattern_to_region $1
in PTuple {region; value=$1} }
sub_irrefutable:
@ -276,9 +273,7 @@ pattern:
PList (PCons {region; value=$1,$2,$3})
}
| tuple(sub_pattern) {
let start = pattern_to_region (fst $1) in
let stop = last fst (snd $1) in
let region = cover start stop
let region = nsepseq_to_region pattern_to_region $1
in PTuple {region; value=$1} }
sub_pattern:
@ -333,10 +328,7 @@ constr_pattern:
ptuple:
tuple(tail) {
let hd, tl = $1 in
let start = pattern_to_region hd in
let stop = last fst tl in
let region = cover start stop
let region = nsepseq_to_region pattern_to_region $1
in PTuple {region; value=$1} }
unit:
@ -372,9 +364,7 @@ base_expr(right_expr):
tuple_expr:
tuple(disj_expr_level) {
let start = expr_to_region (fst $1) in
let stop = last fst (snd $1) in
let region = cover start stop
let region = nsepseq_to_region expr_to_region $1
in ETuple {region; value=$1} }
conditional(right_expr):
@ -534,8 +524,7 @@ mult_expr_level:
| unary_expr_level { $1 }
unary_expr_level:
call_expr_level { $1 }
| "-" call_expr_level {
"-" call_expr_level {
let start = $1 in
let stop = expr_to_region $2 in
let region = cover start stop
@ -547,7 +536,9 @@ unary_expr_level:
let stop = expr_to_region $2 in
let region = cover start stop
and value = {op=$1; arg=$2} in
ELogic (BoolExpr (Not ({region; value}))) }
ELogic (BoolExpr (Not ({region; value})))
}
| call_expr_level { $1 }
call_expr_level:
call_expr | constr_expr | core_expr { $1 }
@ -593,7 +584,10 @@ core_expr:
| record_expr { ERecord $1 }
| update_record { EUpdate $1 }
| par(expr) { EPar $1 }
| par(expr ":" type_expr {$1,$2,$3}) { EAnnot $1 }
| par(annot_expr) { EAnnot $1 }
annot_expr:
expr ":" type_expr { $1,$2,$3 }
module_field:
module_name "." module_fun {
@ -602,7 +596,7 @@ module_field:
module_fun:
field_name { $1 }
| "or" { {value="or"; region=$1} }
| "or" { {value="or"; region=$1} }
projection:
struct_name "." nsepseq(selection,".") {
@ -642,7 +636,7 @@ update_record:
lbrace = $1;
record = $2;
kwd_with = $3;
updates = {value = {compound = Braces($1,$5);
updates = {value = {compound = Braces (ghost, ghost);
ne_elements;
terminator};
region = cover $3 $5};
@ -650,20 +644,15 @@ update_record:
in {region; value} }
field_path_assignment :
nsepseq(selection,".") "=" expr {
let start = nsepseq_to_region selection_to_region $1 in
let region = cover start (expr_to_region $3) in
let value = {field_path = $1;
assignment = $2;
field_expr = $3}
in {region; value}}
path "=" expr {
let region = cover (path_to_region $1) (expr_to_region $3)
and value = {field_path=$1; assignment=$2; field_expr=$3}
in {region; value} }
field_assignment:
field_name "=" expr {
let start = $1.region in
let stop = expr_to_region $3 in
let region = cover start stop in
let value = {field_name = $1;
let region = cover $1.region (expr_to_region $3)
and value = {field_name = $1;
assignment = $2;
field_expr = $3}
in {region; value} }

45
src/passes/01-parser/cameligo/ParserLog.ml
View File

@ -136,11 +136,10 @@ let rec print_tokens state {decl;eof} =
print_token state eof "EOF"
and print_attributes state attributes =
List.iter (
fun ({value = attribute; region}) ->
let attribute_formatted = sprintf "[@@%s]" attribute in
print_token state region attribute_formatted
) attributes
let apply {value = attribute; region} =
let attribute_formatted = sprintf "[@@%s]" attribute in
print_token state region attribute_formatted
in List.iter apply attributes
and print_statement state = function
Let {value=kwd_let, kwd_rec, let_binding, attributes; _} ->
@ -527,7 +526,7 @@ and print_field_assign state {value; _} =
and print_field_path_assign state {value; _} =
let {field_path; assignment; field_expr} = value in
print_nsepseq state "." print_selection field_path;
print_path state field_path;
print_token state assignment "=";
print_expr state field_expr
@ -616,12 +615,20 @@ let pp_node state name =
let node = sprintf "%s%s\n" state#pad_path name
in Buffer.add_string state#buffer node
let pp_string state = pp_ident state
let pp_string 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_verbatim 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_loc_node state name region =
pp_ident state {value=name; region}
let rec pp_ast state {decl; _} =
let rec pp_cst state {decl; _} =
let apply len rank =
pp_declaration (state#pad len rank) in
let decls = Utils.nseq_to_list decl in
@ -704,7 +711,7 @@ and pp_pattern state = function
pp_string (state#pad 1 0) s
| PVerbatim v ->
pp_node state "PVerbatim";
pp_string (state#pad 1 0) v
pp_verbatim (state#pad 1 0) v
| PUnit {region; _} ->
pp_loc_node state "PUnit" region
| PFalse region ->
@ -938,7 +945,7 @@ and pp_projection state proj =
List.iteri (apply len) selections
and pp_update state update =
pp_path state update.record;
pp_path (state#pad 2 0) update.record;
pp_ne_injection pp_field_path_assign state update.updates.value
and pp_path state = function
@ -963,10 +970,10 @@ and pp_field_assign state {value; _} =
pp_expr (state#pad 2 1) value.field_expr
and pp_field_path_assign state {value; _} =
pp_node state "<field path for update>";
let path = Utils.nsepseq_to_list value.field_path in
List.iter (pp_selection (state#pad 2 0)) path;
pp_expr (state#pad 2 1) value.field_expr
let {field_path; field_expr; _} = value in
pp_node state "<update>";
pp_path (state#pad 2 0) field_path;
pp_expr (state#pad 2 1) field_expr
and pp_constr_expr state = function
ENone region ->
@ -987,11 +994,11 @@ and pp_constr_app_expr state (constr, expr_opt) =
and pp_list_expr state = function
ECons {value; region} ->
pp_loc_node state "Cons" region;
pp_loc_node state "ECons" region;
pp_expr (state#pad 2 0) value.arg1;
pp_expr (state#pad 2 1) value.arg2
| EListComp {value; region} ->
pp_loc_node state "List" region;
pp_loc_node state "EListComp" region;
if value.elements = None
then pp_node (state#pad 1 0) "<nil>"
else pp_injection pp_expr state value
@ -1134,13 +1141,13 @@ and pp_type_expr state = function
pp_type_expr (state#pad len rank) in
let domain, _, range = value in
List.iteri (apply 2) [domain; range]
| TPar {value={inside;_}; region} ->
| TPar {value={inside;_}; region} ->
pp_loc_node state "TPar" region;
pp_type_expr (state#pad 1 0) inside
| TVar v ->
| TVar v ->
pp_node state "TVar";
pp_ident (state#pad 1 0) v
| TString s ->
| TString s ->
pp_node state "TString";
pp_string (state#pad 1 0) s

2
src/passes/01-parser/cameligo/ParserLog.mli
View File

@ -27,5 +27,5 @@ val expr_to_string :
(** {1 Pretty-printing of AST nodes} *)
val pp_ast : state -> AST.t -> unit
val pp_cst : state -> AST.t -> unit
val pp_expr : state -> AST.expr -> unit

25
src/passes/01-parser/cameligo/ParserMain.ml
View File

@ -22,7 +22,8 @@ module SubIO =
ext : string;
mode : [`Byte | `Point];
cmd : EvalOpt.command;
mono : bool
mono : bool;
pretty : bool
>
let options : options =
@ -36,6 +37,7 @@ module SubIO =
method mode = IO.options#mode
method cmd = IO.options#cmd
method mono = IO.options#mono
method pretty = IO.options#pretty
end
let make =
@ -48,6 +50,7 @@ module SubIO =
~mode:options#mode
~cmd:options#cmd
~mono:options#mono
~pretty:options#pretty
end
module Parser =
@ -67,14 +70,28 @@ module ParserLog =
module Lexer = Lexer.Make (LexToken)
module Unit =
ParserUnit.Make (Lexer)(AST)(Parser)(ParErr)(ParserLog)(SubIO)
ParserUnit.Make (Lexer)(AST)(Parser)(Parser_msg)(ParserLog)(SubIO)
(* Main *)
let wrap = function
Stdlib.Ok _ -> flush_all ()
Stdlib.Ok ast ->
if IO.options#pretty then
begin
let doc = Pretty.print ast in
let width =
match Terminal_size.get_columns () with
None -> 60
| Some c -> c in
PPrint.ToChannel.pretty 1.0 width stdout doc;
print_newline ()
end;
flush_all ()
| Error msg ->
(flush_all (); Printf.eprintf "\027[31m%s\027[0m%!" msg.Region.value)
begin
flush_all ();
Printf.eprintf "\027[31m%s\027[0m%!" msg.Region.value
end
let () =
match IO.options#input with

442
src/passes/01-parser/cameligo/Pretty.ml Normal file
View File

@ -0,0 +1,442 @@
[@@@warning "-42"]
open AST
module Region = Simple_utils.Region
open! Region
open! PPrint
let pp_par printer {value; _} =
string "(" ^^ nest 1 (printer value.inside ^^ string ")")
let rec print ast =
let app decl = group (pp_declaration decl) in
let decl = Utils.nseq_to_list ast.decl in
separate_map (hardline ^^ hardline) app decl
and pp_declaration = function
Let decl -> pp_let_decl decl
| TypeDecl decl -> pp_type_decl decl
and pp_let_decl {value; _} =
let _, rec_opt, binding, attr = value in
let let_str =
match rec_opt with
None -> "let "
| Some _ -> "let rec " in
let binding = pp_let_binding binding
and attr = pp_attributes attr
in string let_str ^^ binding ^^ attr
and pp_attributes = function
[] -> empty
| attr ->
let make s = string "[@@" ^^ string s.value ^^ string "]" in
group (nest 2 (break 1 ^^ separate_map (break 0) make attr))
and pp_ident {value; _} = string value
and pp_string s = string "\"" ^^ pp_ident s ^^ string "\""
and pp_verbatim s = string "{|" ^^ pp_ident s ^^ string "|}"
and pp_let_binding (binding : let_binding) =
let {binders; lhs_type; let_rhs; _} = binding in
let head, tail = binders in
let patterns =
group (nest 2 (separate_map (break 1) pp_pattern (head::tail))) in
let lhs =
patterns ^^
match lhs_type with
None -> empty
| Some (_,e) -> group (break 1 ^^ string ": " ^^ pp_type_expr e)
in prefix 2 1 (lhs ^^ string " =") (pp_expr let_rhs)
and pp_pattern = function
PConstr p -> pp_pconstr p
| PUnit _ -> string "()"
| PFalse _ -> string "false"
| PTrue _ -> string "true"
| PVar v -> pp_ident v
| PInt i -> pp_int i
| PNat n -> pp_nat n
| PBytes b -> pp_bytes b
| PString s -> pp_string s
| PVerbatim s -> pp_verbatim s
| PWild _ -> string "_"
| PList l -> pp_plist l
| PTuple t -> pp_ptuple t
| PPar p -> pp_ppar p
| PRecord r -> pp_precord r
| PTyped t -> pp_ptyped t
and pp_pconstr = function
PNone _ -> string "None"
| PSomeApp p -> pp_patt_some p
| PConstrApp a -> pp_pconstr_app a
and pp_pconstr_app {value; _} =
match value with
constr, None -> pp_ident constr
| constr, Some pat ->
prefix 4 1 (pp_ident constr) (pp_pattern pat)
and pp_patt_some {value; _} =
prefix 4 1 (string "Some") (pp_pattern (snd value))
and pp_int {value; _} =
string (Z.to_string (snd value))
and pp_nat {value; _} =
string (Z.to_string (snd value) ^ "n")
and pp_bytes {value; _} =
string ("0x" ^ Hex.show (snd value))
and pp_ppar p = pp_par pp_pattern p
and pp_plist = function
PListComp cmp -> pp_list_comp cmp
| PCons cons -> pp_pcons cons
and pp_list_comp e = group (pp_injection pp_pattern e)
and pp_pcons {value; _} =
let patt1, _, patt2 = value in
prefix 2 1 (pp_pattern patt1 ^^ string " ::") (pp_pattern patt2)
and pp_ptuple {value; _} =
let head, tail = value in
let rec app = function
[] -> empty
| [p] -> group (break 1 ^^ pp_pattern p)
| p::items ->
group (break 1 ^^ pp_pattern p ^^ string ",") ^^ app items
in if tail = []
then pp_pattern head
else pp_pattern head ^^ string "," ^^ app (List.map snd tail)
and pp_precord fields = pp_ne_injection pp_field_pattern fields
and pp_field_pattern {value; _} =
let {field_name; pattern; _} = value in
prefix 2 1 (pp_ident field_name ^^ string " =") (pp_pattern pattern)
and pp_ptyped {value; _} =
let {pattern; type_expr; _} = value in
group (pp_pattern pattern ^^ string " :" ^/^ pp_type_expr type_expr)
and pp_type_decl decl =
let {name; type_expr; _} = decl.value in
let padding = match type_expr with TSum _ -> 0 | _ -> 2 in
string "type " ^^ string name.value ^^ string " ="
^^ group (nest padding (break 1 ^^ pp_type_expr type_expr))
and pp_expr = function
ECase e -> pp_case_expr e
| ECond e -> group (pp_cond_expr e)
| EAnnot e -> pp_annot_expr e
| ELogic e -> group (pp_logic_expr e)
| EArith e -> group (pp_arith_expr e)
| EString e -> pp_string_expr e
| EList e -> group (pp_list_expr e)
| EConstr e -> pp_constr_expr e
| ERecord e -> pp_record_expr e
| EProj e -> pp_projection e
| EUpdate e -> pp_update e
| EVar v -> pp_ident v
| ECall e -> pp_call_expr e
| EBytes e -> pp_bytes e
| EUnit _ -> string "()"
| ETuple e -> pp_tuple_expr e
| EPar e -> pp_par_expr e
| ELetIn e -> pp_let_in e
| EFun e -> pp_fun e
| ESeq e -> pp_seq e
and pp_case_expr {value; _} =
let {expr; cases; _} = value in
group (string "match " ^^ nest 6 (pp_expr expr) ^/^ string "with")
^^ hardline ^^ pp_cases cases
and pp_cases {value; _} =
let head, tail = value in
let head = pp_clause head in
let head = if tail = [] then head else blank 2 ^^ head in
let rest = List.map snd tail in
let app clause = break 1 ^^ string "| " ^^ pp_clause clause
in head ^^ concat_map app rest
and pp_clause {value; _} =
let {pattern; rhs; _} = value in
pp_pattern pattern ^^ prefix 4 1 (string " ->") (pp_expr rhs)
and pp_cond_expr {value; _} =
let {test; ifso; kwd_else; ifnot; _} = value in
let test = string "if " ^^ group (nest 3 (pp_expr test))
and ifso = string "then" ^^ group (nest 2 (break 1 ^^ pp_expr ifso))
and ifnot = string "else" ^^ group (nest 2 (break 1 ^^ pp_expr ifnot))
in if kwd_else#is_ghost
then test ^/^ ifso
else test ^/^ ifso ^/^ ifnot
and pp_annot_expr {value; _} =
let expr, _, type_expr = value.inside in
group (string "(" ^^ nest 1 (pp_expr expr ^/^ string ": "
^^ pp_type_expr type_expr ^^ string ")"))
and pp_logic_expr = function
BoolExpr e -> pp_bool_expr e
| CompExpr e -> pp_comp_expr e
and pp_bool_expr = function
Or e -> pp_bin_op "||" e
| And e -> pp_bin_op "&&" e
| Not e -> pp_un_op "not" e
| True _ -> string "true"
| False _ -> string "false"
and pp_bin_op op {value; _} =
let {arg1; arg2; _} = value
and length = String.length op + 1 in
pp_expr arg1 ^/^ string (op ^ " ") ^^ nest length (pp_expr arg2)
and pp_un_op op {value; _} =
string (op ^ " ") ^^ pp_expr value.arg
and pp_comp_expr = function
Lt e -> pp_bin_op "<" e
| Leq e -> pp_bin_op "<=" e
| Gt e -> pp_bin_op ">" e
| Geq e -> pp_bin_op ">=" e
| Equal e -> pp_bin_op "=" e
| Neq e -> pp_bin_op "<>" e
and pp_arith_expr = function
Add e -> pp_bin_op "+" e
| Sub e -> pp_bin_op "-" e
| Mult e -> pp_bin_op "*" e
| Div e -> pp_bin_op "/" e
| Mod e -> pp_bin_op "mod" e
| Neg e -> string "-" ^^ pp_expr e.value.arg
| Int e -> pp_int e
| Nat e -> pp_nat e
| Mutez e -> pp_mutez e
and pp_mutez {value; _} =
Z.to_string (snd value) ^ "mutez" |> string
and pp_string_expr = function
Cat e -> pp_bin_op "^" e
| String e -> pp_string e
| Verbatim e -> pp_verbatim e
and pp_list_expr = function
ECons e -> pp_bin_op "::" e
| EListComp e -> group (pp_injection pp_expr e)
and pp_injection :
'a.('a -> document) -> 'a injection reg -> document =
fun printer {value; _} ->
let {compound; elements; _} = value in
let sep = string ";" ^^ break 1 in
let elements = Utils.sepseq_to_list elements in
let elements = separate_map sep printer elements in
match pp_compound compound with
None -> elements
| Some (opening, closing) ->
string opening ^^ nest 1 elements ^^ string closing
and pp_compound = function
BeginEnd (start, _) ->
if start#is_ghost then None else Some ("begin","end")
| Braces (start, _) ->
if start#is_ghost then None else Some ("{","}")
| Brackets (start, _) ->
if start#is_ghost then None else Some ("[","]")
and pp_constr_expr = function
ENone _ -> string "None"
| ESomeApp a -> pp_some a
| EConstrApp a -> pp_constr_app a
and pp_some {value=_, e; _} =
prefix 4 1 (string "Some") (pp_expr e)
and pp_constr_app {value; _} =
let constr, arg = value in
let constr = string constr.value in
match arg with
None -> constr
| Some e -> prefix 2 1 constr (pp_expr e)
and pp_record_expr ne_inj = group (pp_ne_injection pp_field_assign ne_inj)
and pp_field_assign {value; _} =
let {field_name; field_expr; _} = value in
prefix 2 1 (pp_ident field_name ^^ string " =") (pp_expr field_expr)
and pp_ne_injection :
'a.('a -> document) -> 'a ne_injection reg -> document =
fun printer {value; _} ->
let {compound; ne_elements; _} = value in
let elements = pp_nsepseq ";" printer ne_elements in
match pp_compound compound with
None -> elements
| Some (opening, closing) ->
string opening ^^ nest 1 elements ^^ string closing
and pp_nsepseq :
'a.string -> ('a -> document) -> ('a, t) Utils.nsepseq -> document =
fun sep printer elements ->
let elems = Utils.nsepseq_to_list elements
and sep = string sep ^^ break 1
in separate_map sep printer elems
and pp_nseq : 'a.('a -> document) -> 'a Utils.nseq -> document =
fun printer (head, tail) -> separate_map (break 1) printer (head::tail)
and pp_projection {value; _} =
let {struct_name; field_path; _} = value in
let fields = Utils.nsepseq_to_list field_path
and sep = string "." ^^ break 0 in
let fields = separate_map sep pp_selection fields in
group (pp_ident struct_name ^^ string "." ^^ break 0 ^^ fields)
and pp_selection = function
FieldName v -> string v.value
| Component cmp -> cmp.value |> snd |> Z.to_string |> string
and pp_update {value; _} =
let {record; updates; _} = value in
let updates = group (pp_ne_injection pp_field_path_assign updates)
and record = pp_path record in
string "{" ^^ record ^^ string " with"
^^ nest 2 (break 1 ^^ updates ^^ string "}")
and pp_field_path_assign {value; _} =
let {field_path; field_expr; _} = value in
let path = pp_path field_path in
prefix 2 1 (path ^^ string " =") (pp_expr field_expr)
and pp_path = function
Name v -> pp_ident v
| Path p -> pp_projection p
and pp_call_expr {value; _} =
let lambda, arguments = value in
let arguments = pp_nseq pp_expr arguments in
group (pp_expr lambda ^^ nest 2 (break 1 ^^ arguments))
and pp_tuple_expr {value; _} =
let head, tail = value in
let rec app = function
[] -> empty
| [e] -> group (break 1 ^^ pp_expr e)
| e::items ->
group (break 1 ^^ pp_expr e ^^ string ",") ^^ app items
in if tail = []
then pp_expr head
else pp_expr head ^^ string "," ^^ app (List.map snd tail)
and pp_par_expr e = pp_par pp_expr e
and pp_let_in {value; _} =
let {binding; kwd_rec; body; attributes; _} = value in
let let_str =
match kwd_rec with
None -> "let "
| Some _ -> "let rec " in
let binding = pp_let_binding binding
and attr = pp_attributes attributes
in string let_str ^^ binding ^^ attr
^^ hardline ^^ group (string "in " ^^ nest 3 (pp_expr body))
and pp_fun {value; _} =
let {binders; lhs_type; body; _} = value in
let binders = pp_nseq pp_pattern binders
and annot =
match lhs_type with
None -> empty
| Some (_,e) ->
group (break 1 ^^ string ": " ^^ nest 2 (break 1 ^^ pp_type_expr e))
in group (string "fun " ^^ nest 4 binders ^^ annot
^^ string " ->" ^^ nest 2 (break 1 ^^ pp_expr body))
and pp_seq {value; _} =
let {compound; elements; _} = value in
let sep = string ";" ^^ hardline in
let elements = Utils.sepseq_to_list elements in
let elements = separate_map sep pp_expr elements in
match pp_compound compound with
None -> elements
| Some (opening, closing) ->
string opening
^^ nest 2 (hardline ^^ elements) ^^ hardline
^^ string closing
and pp_type_expr = function
TProd t -> pp_cartesian t
| TSum t -> pp_variants t
| TRecord t -> pp_fields t
| TApp t -> pp_type_app t
| TFun t -> pp_fun_type t
| TPar t -> pp_type_par t
| TVar t -> pp_ident t
| TString s -> pp_string s
and pp_cartesian {value; _} =
let head, tail = value in
let rec app = function
[] -> empty
| [e] -> group (break 1 ^^ pp_type_expr e)
| e::items ->
group (break 1 ^^ pp_type_expr e ^^ string " *") ^^ app items
in pp_type_expr head ^^ string " *" ^^ app (List.map snd tail)
and pp_variants {value; _} =
let head, tail = value in
let head = pp_variant head in
let head = if tail = [] then head else ifflat head (blank 2 ^^ head) in
let rest = List.map snd tail in
let app variant = break 1 ^^ string "| " ^^ pp_variant variant
in head ^^ concat_map app rest
and pp_variant {value; _} =
let {constr; arg} = value in
match arg with
None -> pp_ident constr
| Some (_, e) ->
prefix 4 1 (pp_ident constr ^^ string " of") (pp_type_expr e)
and pp_fields fields = group (pp_ne_injection pp_field_decl fields)
and pp_field_decl {value; _} =
let {field_name; field_type; _} = value in
let name = pp_ident field_name in
let t_expr = pp_type_expr field_type
in prefix 2 1 (name ^^ string " :") t_expr
and pp_type_app {value = ctor, tuple; _} =
pp_type_tuple tuple ^^ group (nest 2 (break 1 ^^ pp_type_constr ctor))
and pp_type_tuple {value; _} =
let head, tail = value.inside in
let rec app = function
[] -> empty
| [e] -> group (break 1 ^^ pp_type_expr e)
| e::items ->
group (break 1 ^^ pp_type_expr e ^^ string ",") ^^ app items in
if tail = []
then pp_type_expr head
else
let components =
pp_type_expr head ^^ string "," ^^ app (List.map snd tail)
in string "(" ^^ nest 1 (components ^^ string ")")
and pp_type_constr ctor = string ctor.value
and pp_fun_type {value; _} =
let lhs, _, rhs = value in
group (pp_type_expr lhs ^^ string " ->" ^/^ pp_type_expr rhs)
and pp_type_par t = pp_par pp_type_expr t

71
src/passes/01-parser/cameligo/Tests/pp.mligo
View File

@ -1,29 +1,54 @@
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 patch_ (m : foobar) : foobar = Map.literal [(0, 5); (1, 6); (2, 7)]
let x = 4
let y : t = (if true then -3 + f x x else 0) - 1
let f (x: int) y = (x : int)
let (greet_num : int), (greeting : string), one_more_component =
different_types of_many_things + ffffff 124312
type storage = int * int
let main (n : int * storage)
: operation list * storage =
let x : int * int =
let x : int = 7
in x + n.0.asdasdasd.4, n.1.0 + n.1.1.1111111.aaaa.ddddddd.eeeeeee
in ([] : operation list), x
let y : t =
if true then ffffffffff (-30000 * 10000 - 100000 + f x x y y y y - ((x / 4000) * -5), 103+5) else (10000 + 100000) / 10000000000
type return = operation list * (storage * fsdgsdgf * sdfsdfsdf * ssdf)
let xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx =
ttttttttttttt <= (aaaaaaaaaaaaaaaaaaaaaaaa - bbbbbbbbbbbbbbbbbbbb)
let x = tttt * ((fffffffff /55555555) - 3455 * 5135664) - 134 * (-4)
type x = AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA | B
let or_true (b : bool) : bool = bbbbbbbbbbbbb || true && cccccccccccccccccc
type x = A | B of t * int | CCC of int -> (string -> int) -> (string, address, timestamp, int) map
let c = CCCCCCCCCCCC (aaaaa, BBBBBBBBB aaaaaaaaaaaa)
let e = Some (a, B b)
type w = timestamp * nat -> (string, address) map -> t
type v = int * (a_long_type_name * (another_long_one * address * and_so_on) * more_of_a_very_long_type)
type r = int list
type t = int
type s = (int,address,a_long_type_name, more_of_a_very_long_type * foo_bar_baz) t
type q = {a: int; b: {c: string}; c: timestamp * (address, string) big_map -> longer_type_name}
type u = {a: int; b: t * char; c: int * (a_long_type_name * (another_long_one * address * and_so_on) * more_of_a_very_long_type)}
let f xxxxxxxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz ttttt : type_annotation_which_is_very_verbose = this_too_short_a_variable
let g : type_annotation_which_is_very_verbose = fun x y z t -> this_too_short_a_variable [@@inline]
let yyyyyyyyyyy : a_very_long_and_specific_type_of_string = "foo and bar"
let rec x (_, (yyyyyyyyyyyyyyyy: tttttttttttttttttttttttt), very_long_variable_to_trigger_a_break) = 4
let y {xxxxxxxxx=(_,yyyyyyyy,more_components,another_one); zzzzzzz=34444444; ttttttt=3n} = xxxxxx
let z : (t) = y
let w =
match f 3 with
None -> []
| Some (1::[2;3]) -> [4;5]::[]
let f (xxxxxxxxxxx: tttttttttttttt) y = (xxxxxxxxxxxx : tttttttttttttttttt)
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")]
let r = { field = 0}
let r = { r with field = 42}
let z = let v = "hello" ^ "world" ^ "!" in v
let r = { field = 0; another = 11111111111111111; and_another_one = "dddddd"}
let r = { r with field = 42; another = 11111111111111111; and_another_one = "dddddddddddddddddddddd"}
let w = Map.literal [(11111111111111,"11111111111111"); (22222222222,"22222222222222222"); (1234567890,"1234567890")]
let z = z.1.a.0.4.c.6.7.8.9.cccccccccccc.ccccccccccccccccc.ddddddddddddddddd.0.1.2
let y : t = (if true then -30000000000000 + f x x y y y y else 10000000000000000000) - 1
let w =
match f 3 with
None -> []
| Some (1::[2;3;4;5;6]) -> [4;5]::[]

8
src/passes/01-parser/cameligo/dune
View File

@ -15,8 +15,10 @@
(name parser_cameligo)
(public_name ligo.parser.cameligo)
(modules
Scoping AST cameligo Parser ParserLog LexToken ParErr)
Scoping AST cameligo Parser ParserLog LexToken ParErr Pretty)
(libraries
pprint
terminal_size
menhirLib
parser_shared
str
@ -26,8 +28,8 @@
(pps bisect_ppx --conditional))
(flags (:standard -open Parser_shared -open Simple_utils)))
;; Build of the unlexer (for covering the
;; error states of the LR automaton)
;; Build of the unlexer (for covering the error states of the LR
;; automaton)
(executable
(name Unlexer)

124
src/passes/01-parser/cameligo/error.messages.checked-in
View File

@ -1948,7 +1948,7 @@ interactive_expr: LBRACE Constr DOT Ident With
##
## Ends in an error in state: 523.
##
## projection -> Constr DOT Ident . DOT nsepseq(selection,DOT) [ With ]
## projection -> Constr DOT Ident . DOT nsepseq(selection,DOT) [ With EQ ]
##
## The known suffix of the stack is as follows:
## Constr DOT Ident
@ -1960,7 +1960,7 @@ interactive_expr: LBRACE Constr DOT With
##
## Ends in an error in state: 522.
##
## projection -> Constr DOT . Ident DOT nsepseq(selection,DOT) [ With ]
## projection -> Constr DOT . Ident DOT nsepseq(selection,DOT) [ With EQ ]
##
## The known suffix of the stack is as follows:
## Constr DOT
@ -1972,7 +1972,7 @@ interactive_expr: LBRACE Constr With
##
## Ends in an error in state: 521.
##
## projection -> Constr . DOT Ident DOT nsepseq(selection,DOT) [ With ]
## projection -> Constr . DOT Ident DOT nsepseq(selection,DOT) [ With EQ ]
##
## The known suffix of the stack is as follows:
## Constr
@ -2002,7 +2002,7 @@ interactive_expr: LBRACE Ident DOT Ident Verbatim
interactive_expr: LBRACE Ident EQ Bytes SEMI Ident EQ Bytes SEMI With
##
## Ends in an error in state: 551.
## Ends in an error in state: 552.
##
## nsepseq(field_assignment,SEMI) -> field_assignment SEMI . nsepseq(field_assignment,SEMI) [ RBRACE ]
## seq(__anonymous_0(field_assignment,SEMI)) -> field_assignment SEMI . seq(__anonymous_0(field_assignment,SEMI)) [ RBRACE ]
@ -2015,7 +2015,7 @@ interactive_expr: LBRACE Ident EQ Bytes SEMI Ident EQ Bytes SEMI With
interactive_expr: LBRACE Ident EQ Bytes SEMI Ident EQ Bytes With
##
## Ends in an error in state: 550.
## Ends in an error in state: 551.
##
## nsepseq(field_assignment,SEMI) -> field_assignment . [ RBRACE ]
## nsepseq(field_assignment,SEMI) -> field_assignment . SEMI nsepseq(field_assignment,SEMI) [ RBRACE ]
@ -2047,7 +2047,7 @@ interactive_expr: LBRACE Ident EQ Bytes SEMI Ident EQ Bytes With
interactive_expr: LBRACE Ident EQ Bytes SEMI Ident With
##
## Ends in an error in state: 547.
## Ends in an error in state: 548.
##
## field_assignment -> Ident . EQ expr [ SEMI RBRACE ]
##
@ -2059,7 +2059,7 @@ interactive_expr: LBRACE Ident EQ Bytes SEMI Ident With
interactive_expr: LBRACE Ident EQ Bytes SEMI With
##
## Ends in an error in state: 546.
## Ends in an error in state: 547.
##
## nsepseq(field_assignment,SEMI) -> field_assignment SEMI . nsepseq(field_assignment,SEMI) [ RBRACE ]
## nseq(__anonymous_0(field_assignment,SEMI)) -> field_assignment SEMI . seq(__anonymous_0(field_assignment,SEMI)) [ RBRACE ]
@ -2072,7 +2072,7 @@ interactive_expr: LBRACE Ident EQ Bytes SEMI With
interactive_expr: LBRACE Ident EQ Bytes With
##
## Ends in an error in state: 545.
## Ends in an error in state: 546.
##
## nsepseq(field_assignment,SEMI) -> field_assignment . [ RBRACE ]
## nsepseq(field_assignment,SEMI) -> field_assignment . SEMI nsepseq(field_assignment,SEMI) [ RBRACE ]
@ -2128,9 +2128,9 @@ interactive_expr: LBRACE Ident WILD
<YOUR SYNTAX ERROR MESSAGE HERE>
interactive_expr: LBRACE Ident With Int EQ Bytes SEMI Int EQ Bytes SEMI With
interactive_expr: LBRACE Ident With Ident DOT Ident EQ Bytes SEMI Ident DOT Ident EQ Bytes SEMI With
##
## Ends in an error in state: 541.
## Ends in an error in state: 542.
##
## nsepseq(field_path_assignment,SEMI) -> field_path_assignment SEMI . nsepseq(field_path_assignment,SEMI) [ RBRACE ]
## seq(__anonymous_0(field_path_assignment,SEMI)) -> field_path_assignment SEMI . seq(__anonymous_0(field_path_assignment,SEMI)) [ RBRACE ]
@ -2141,9 +2141,9 @@ interactive_expr: LBRACE Ident With Int EQ Bytes SEMI Int EQ Bytes SEMI With
<YOUR SYNTAX ERROR MESSAGE HERE>
interactive_expr: LBRACE Ident With Int EQ Bytes SEMI Int EQ Bytes With
interactive_expr: LBRACE Ident With Ident DOT Ident EQ Bytes SEMI Ident DOT Ident EQ Bytes With
##
## Ends in an error in state: 540.
## Ends in an error in state: 541.
##
## nsepseq(field_path_assignment,SEMI) -> field_path_assignment . [ RBRACE ]
## nsepseq(field_path_assignment,SEMI) -> field_path_assignment . SEMI nsepseq(field_path_assignment,SEMI) [ RBRACE ]
@ -2168,14 +2168,14 @@ interactive_expr: LBRACE Ident With Int EQ Bytes SEMI Int EQ Bytes With
## In state 368, spurious reduction of production base_expr(expr) -> disj_expr_level
## In state 370, spurious reduction of production base_cond__open(expr) -> base_expr(expr)
## In state 371, spurious reduction of production expr -> base_cond__open(expr)
## In state 534, spurious reduction of production field_path_assignment -> nsepseq(selection,DOT) EQ expr
## In state 534, spurious reduction of production field_path_assignment -> path EQ expr
##
<YOUR SYNTAX ERROR MESSAGE HERE>
interactive_expr: LBRACE Ident With Int EQ Bytes SEMI With
interactive_expr: LBRACE Ident With Ident DOT Ident EQ Bytes SEMI With
##
## Ends in an error in state: 537.
## Ends in an error in state: 538.
##
## nsepseq(field_path_assignment,SEMI) -> field_path_assignment SEMI . nsepseq(field_path_assignment,SEMI) [ RBRACE ]
## nseq(__anonymous_0(field_path_assignment,SEMI)) -> field_path_assignment SEMI . seq(__anonymous_0(field_path_assignment,SEMI)) [ RBRACE ]
@ -2186,9 +2186,9 @@ interactive_expr: LBRACE Ident With Int EQ Bytes SEMI With
<YOUR SYNTAX ERROR MESSAGE HERE>
interactive_expr: LBRACE Ident With Int EQ Bytes With
interactive_expr: LBRACE Ident With Ident DOT Ident EQ Bytes With
##
## Ends in an error in state: 536.
## Ends in an error in state: 537.
##
## nsepseq(field_path_assignment,SEMI) -> field_path_assignment . [ RBRACE ]
## nsepseq(field_path_assignment,SEMI) -> field_path_assignment . SEMI nsepseq(field_path_assignment,SEMI) [ RBRACE ]
@ -2213,37 +2213,52 @@ interactive_expr: LBRACE Ident With Int EQ Bytes With
## In state 368, spurious reduction of production base_expr(expr) -> disj_expr_level
## In state 370, spurious reduction of production base_cond__open(expr) -> base_expr(expr)
## In state 371, spurious reduction of production expr -> base_cond__open(expr)
## In state 534, spurious reduction of production field_path_assignment -> nsepseq(selection,DOT) EQ expr
## In state 534, spurious reduction of production field_path_assignment -> path EQ expr
##
<YOUR SYNTAX ERROR MESSAGE HERE>
interactive_expr: LBRACE Ident With Int EQ With
interactive_expr: LBRACE Ident With Ident DOT Ident EQ With
##
## Ends in an error in state: 533.
##
## field_path_assignment -> nsepseq(selection,DOT) EQ . expr [ SEMI RBRACE ]
## field_path_assignment -> path EQ . expr [ SEMI RBRACE ]
##
## The known suffix of the stack is as follows:
## nsepseq(selection,DOT) EQ
## path EQ
##
<YOUR SYNTAX ERROR MESSAGE HERE>
interactive_expr: LBRACE Ident With Int With
interactive_expr: LBRACE Ident With Ident DOT Ident With
##
## Ends in an error in state: 532.
##
## field_path_assignment -> nsepseq(selection,DOT) . EQ expr [ SEMI RBRACE ]
## field_path_assignment -> path . EQ expr [ SEMI RBRACE ]
##
## The known suffix of the stack is as follows:
## nsepseq(selection,DOT)
## path
##
## WARNING: This example involves spurious reductions.
## This implies that, although the LR(1) items shown above provide an
## accurate view of the past (what has been recognized so far), they
## may provide an INCOMPLETE view of the future (what was expected next).
## In state 187, spurious reduction of production nsepseq(selection,DOT) -> selection
## In state 190, spurious reduction of production projection -> Ident DOT nsepseq(selection,DOT)
## In state 526, spurious reduction of production path -> projection
##
<YOUR SYNTAX ERROR MESSAGE HERE>
interactive_expr: LBRACE Ident With Ident With
##
## Ends in an error in state: 529.
##
## path -> Ident . [ EQ ]
## projection -> Ident . DOT nsepseq(selection,DOT) [ EQ ]
##
## The known suffix of the stack is as follows:
## Ident
##
<YOUR SYNTAX ERROR MESSAGE HERE>
@ -2275,7 +2290,7 @@ interactive_expr: LBRACE With
interactive_expr: LBRACKET Verbatim SEMI Verbatim SEMI With
##
## Ends in an error in state: 566.
## Ends in an error in state: 567.
##
## nsepseq(expr,SEMI) -> expr SEMI . nsepseq(expr,SEMI) [ RBRACKET ]
## seq(__anonymous_0(expr,SEMI)) -> expr SEMI . seq(__anonymous_0(expr,SEMI)) [ RBRACKET ]
@ -2288,7 +2303,7 @@ interactive_expr: LBRACKET Verbatim SEMI Verbatim SEMI With
interactive_expr: LBRACKET Verbatim SEMI Verbatim With
##
## Ends in an error in state: 565.
## Ends in an error in state: 566.
##
## nsepseq(expr,SEMI) -> expr . [ RBRACKET ]
## nsepseq(expr,SEMI) -> expr . SEMI nsepseq(expr,SEMI) [ RBRACKET ]
@ -2319,7 +2334,7 @@ interactive_expr: LBRACKET Verbatim SEMI Verbatim With
interactive_expr: LBRACKET Verbatim SEMI With
##
## Ends in an error in state: 562.
## Ends in an error in state: 563.
##
## nsepseq(expr,SEMI) -> expr SEMI . nsepseq(expr,SEMI) [ RBRACKET ]
## nseq(__anonymous_0(expr,SEMI)) -> expr SEMI . seq(__anonymous_0(expr,SEMI)) [ RBRACKET ]
@ -2332,7 +2347,7 @@ interactive_expr: LBRACKET Verbatim SEMI With
interactive_expr: LBRACKET Verbatim With
##
## Ends in an error in state: 561.
## Ends in an error in state: 562.
##
## nsepseq(expr,SEMI) -> expr . [ RBRACKET ]
## nsepseq(expr,SEMI) -> expr . SEMI nsepseq(expr,SEMI) [ RBRACKET ]
@ -2373,14 +2388,14 @@ interactive_expr: LBRACKET With
<YOUR SYNTAX ERROR MESSAGE HERE>
interactive_expr: LPAR Verbatim COLON String VBAR
interactive_expr: LPAR Verbatim COLON Ident VBAR
##
## Ends in an error in state: 579.
## Ends in an error in state: 581.
##
## par(__anonymous_1) -> LPAR expr COLON type_expr . RPAR [ With Verbatim VBAR Type True Then TIMES String SLASH SEMI RPAR RBRACKET RBRACE PLUS Or Nat NE Mutez Mod MINUS Let LT LPAR LE LBRACKET LBRACE Int In Ident GT GE False End Else EQ EOF Constr CONS COMMA COLON CAT Bytes Begin BOOL_OR BOOL_AND Attr ]
## par(annot_expr) -> LPAR annot_expr . RPAR [ With Verbatim VBAR Type True Then TIMES String SLASH SEMI RPAR RBRACKET RBRACE PLUS Or Nat NE Mutez Mod MINUS Let LT LPAR LE LBRACKET LBRACE Int In Ident GT GE False End Else EQ EOF Constr CONS COMMA COLON CAT Bytes Begin BOOL_OR BOOL_AND Attr ]
##
## The known suffix of the stack is as follows:
## LPAR expr COLON type_expr
## LPAR annot_expr
##
## WARNING: This example involves spurious reductions.
## This implies that, although the LR(1) items shown above provide an
@ -2389,27 +2404,28 @@ interactive_expr: LPAR Verbatim COLON String VBAR
## In state 28, spurious reduction of production cartesian -> core_type
## In state 36, spurious reduction of production fun_type -> cartesian
## In state 27, spurious reduction of production type_expr -> fun_type
## In state 580, spurious reduction of production annot_expr -> expr COLON type_expr
##
<YOUR SYNTAX ERROR MESSAGE HERE>
interactive_expr: LPAR Verbatim COLON With
##
## Ends in an error in state: 578.
## Ends in an error in state: 579.
##
## par(__anonymous_1) -> LPAR expr COLON . type_expr RPAR [ With Verbatim VBAR Type True Then TIMES String SLASH SEMI RPAR RBRACKET RBRACE PLUS Or Nat NE Mutez Mod MINUS Let LT LPAR LE LBRACKET LBRACE Int In Ident GT GE False End Else EQ EOF Constr CONS COMMA COLON CAT Bytes Begin BOOL_OR BOOL_AND Attr ]
## annot_expr -> expr COLON . type_expr [ RPAR ]
##
## The known suffix of the stack is as follows:
## LPAR expr COLON
## expr COLON
##
<YOUR SYNTAX ERROR MESSAGE HERE>
interactive_expr: LPAR Verbatim With
##
## Ends in an error in state: 576.
## Ends in an error in state: 577.
##
## par(__anonymous_1) -> LPAR expr . COLON type_expr RPAR [ With Verbatim VBAR Type True Then TIMES String SLASH SEMI RPAR RBRACKET RBRACE PLUS Or Nat NE Mutez Mod MINUS Let LT LPAR LE LBRACKET LBRACE Int In Ident GT GE False End Else EQ EOF Constr CONS COMMA COLON CAT Bytes Begin BOOL_OR BOOL_AND Attr ]
## annot_expr -> expr . COLON type_expr [ RPAR ]
## par(expr) -> LPAR expr . RPAR [ With Verbatim VBAR Type True Then TIMES String SLASH SEMI RPAR RBRACKET RBRACE PLUS Or Nat NE Mutez Mod MINUS Let LT LPAR LE LBRACKET LBRACE Int In Ident GT GE False End Else EQ EOF Constr CONS COMMA COLON CAT Bytes Begin BOOL_OR BOOL_AND Attr ]
##
## The known suffix of the stack is as follows:
@ -2439,7 +2455,7 @@ interactive_expr: LPAR With
##
## Ends in an error in state: 167.
##
## par(__anonymous_1) -> LPAR . expr COLON type_expr RPAR [ With Verbatim VBAR Type True Then TIMES String SLASH SEMI RPAR RBRACKET RBRACE PLUS Or Nat NE Mutez Mod MINUS Let LT LPAR LE LBRACKET LBRACE Int In Ident GT GE False End Else EQ EOF Constr CONS COMMA COLON CAT Bytes Begin BOOL_OR BOOL_AND Attr ]
## par(annot_expr) -> LPAR . annot_expr RPAR [ With Verbatim VBAR Type True Then TIMES String SLASH SEMI RPAR RBRACKET RBRACE PLUS Or Nat NE Mutez Mod MINUS Let LT LPAR LE LBRACKET LBRACE Int In Ident GT GE False End Else EQ EOF Constr CONS COMMA COLON CAT Bytes Begin BOOL_OR BOOL_AND Attr ]
## par(expr) -> LPAR . expr RPAR [ With Verbatim VBAR Type True Then TIMES String SLASH SEMI RPAR RBRACKET RBRACE PLUS Or Nat NE Mutez Mod MINUS Let LT LPAR LE LBRACKET LBRACE Int In Ident GT GE False End Else EQ EOF Constr CONS COMMA COLON CAT Bytes Begin BOOL_OR BOOL_AND Attr ]
## unit -> LPAR . RPAR [ With Verbatim VBAR Type True Then TIMES String SLASH SEMI RPAR RBRACKET RBRACE PLUS Or Nat NE Mutez Mod MINUS Let LT LPAR LE LBRACKET LBRACE Int In Ident GT GE False End Else EQ EOF Constr CONS COMMA COLON CAT Bytes Begin BOOL_OR BOOL_AND Attr ]
##
@ -2524,7 +2540,7 @@ interactive_expr: Let Rec With
interactive_expr: Let WILD EQ Bytes Attr Type
##
## Ends in an error in state: 554.
## Ends in an error in state: 555.
##
## let_expr(expr) -> Let let_binding seq(Attr) . In expr [ With Type Then SEMI RPAR RBRACKET RBRACE Let In EOF COLON Attr ]
##
@ -2543,7 +2559,7 @@ interactive_expr: Let WILD EQ Bytes Attr Type
interactive_expr: Let WILD EQ Bytes In With
##
## Ends in an error in state: 555.
## Ends in an error in state: 556.
##
## let_expr(expr) -> Let let_binding seq(Attr) In . expr [ With Type Then SEMI RPAR RBRACKET RBRACE Let In EOF COLON Attr ]
##
@ -2555,7 +2571,7 @@ interactive_expr: Let WILD EQ Bytes In With
interactive_expr: Let WILD EQ Bytes With
##
## Ends in an error in state: 553.
## Ends in an error in state: 554.
##
## let_expr(expr) -> Let let_binding . seq(Attr) In expr [ With Type Then SEMI RPAR RBRACKET RBRACE Let In EOF COLON Attr ]
##
@ -2610,7 +2626,7 @@ interactive_expr: MINUS With
interactive_expr: Match Verbatim Type
##
## Ends in an error in state: 569.
## Ends in an error in state: 570.
##
## match_expr(base_cond) -> Match expr . With option(VBAR) cases(base_cond) [ With Type Then SEMI RPAR RBRACKET RBRACE Let In EOF COLON Attr ]
##
@ -2652,7 +2668,7 @@ interactive_expr: Match Verbatim With LPAR Bytes RPAR With
interactive_expr: Match Verbatim With VBAR Begin
##
## Ends in an error in state: 571.
## Ends in an error in state: 572.
##
## match_expr(base_cond) -> Match expr With option(VBAR) . cases(base_cond) [ With Type Then SEMI RPAR RBRACKET RBRACE Let In EOF COLON Attr ]
##
@ -2664,7 +2680,7 @@ interactive_expr: Match Verbatim With VBAR Begin
interactive_expr: Match Verbatim With WILD ARROW Bytes VBAR With
##
## Ends in an error in state: 575.
## Ends in an error in state: 576.
##
## cases(base_cond) -> cases(base_cond) VBAR . case_clause(base_cond) [ With VBAR Type Then SEMI RPAR RBRACKET RBRACE Let In EOF COLON Attr ]
##
@ -3199,7 +3215,7 @@ interactive_expr: Match Verbatim With WILD ARROW Let With
interactive_expr: Match Verbatim With WILD ARROW Verbatim COMMA Bytes Else
##
## Ends in an error in state: 574.
## Ends in an error in state: 575.
##
## cases(base_cond) -> cases(base_cond) . VBAR case_clause(base_cond) [ With VBAR Type Then SEMI RPAR RBRACKET RBRACE Let In EOF COLON Attr ]
## match_expr(base_cond) -> Match expr With option(VBAR) cases(base_cond) . [ With Type Then SEMI RPAR RBRACKET RBRACE Let In EOF COLON Attr ]
@ -3263,7 +3279,7 @@ interactive_expr: Match Verbatim With WILD ARROW Verbatim End
interactive_expr: Match Verbatim With WILD ARROW With
##
## Ends in an error in state: 573.
## Ends in an error in state: 574.
##
## case_clause(base_cond) -> pattern ARROW . base_cond [ With VBAR Type Then SEMI RPAR RBRACKET RBRACE Let In EOF COLON Attr ]
##
@ -3312,7 +3328,7 @@ interactive_expr: Match Verbatim With WILD COMMA With
interactive_expr: Match Verbatim With WILD CONS Bytes SEMI
##
## Ends in an error in state: 572.
## Ends in an error in state: 573.
##
## case_clause(base_cond) -> pattern . ARROW base_cond [ With VBAR Type Then SEMI RPAR RBRACKET RBRACE Let In EOF COLON Attr ]
##
@ -3356,7 +3372,7 @@ interactive_expr: Match Verbatim With WILD With
interactive_expr: Match Verbatim With With
##
## Ends in an error in state: 570.
## Ends in an error in state: 571.
##
## match_expr(base_cond) -> Match expr With . option(VBAR) cases(base_cond) [ With Type Then SEMI RPAR RBRACKET RBRACE Let In EOF COLON Attr ]
##
@ -3746,7 +3762,7 @@ interactive_expr: Verbatim WILD
interactive_expr: Verbatim With
##
## Ends in an error in state: 596.
## Ends in an error in state: 598.
##
## interactive_expr -> expr . EOF [ # ]
##
@ -3775,7 +3791,7 @@ interactive_expr: Verbatim With
interactive_expr: With
##
## Ends in an error in state: 594.
## Ends in an error in state: 596.
##
## interactive_expr' -> . interactive_expr [ # ]
##
@ -4221,7 +4237,7 @@ contract: Let LPAR With
contract: Let Rec WILD EQ Bytes With
##
## Ends in an error in state: 583.
## Ends in an error in state: 585.
##
## let_declaration -> Let Rec let_binding . seq(Attr) [ Type Let EOF ]
##
@ -4346,7 +4362,7 @@ contract: Let WILD EQ Bytes Attr With
contract: Let WILD EQ Bytes With
##
## Ends in an error in state: 585.
## Ends in an error in state: 587.
##
## let_declaration -> Let let_binding . seq(Attr) [ Type Let EOF ]
##
@ -4482,7 +4498,7 @@ contract: Type Ident EQ Constr With
contract: Type Ident EQ Ident VBAR
##
## Ends in an error in state: 591.
## Ends in an error in state: 593.
##
## declarations -> declaration . [ EOF ]
## declarations -> declaration . declarations [ EOF ]
@ -4498,7 +4514,7 @@ contract: Type Ident EQ Ident VBAR
## In state 36, spurious reduction of production fun_type -> cartesian
## In state 27, spurious reduction of production type_expr -> fun_type
## In state 61, spurious reduction of production type_decl -> Type Ident EQ type_expr
## In state 587, spurious reduction of production declaration -> type_decl
## In state 589, spurious reduction of production declaration -> type_decl
##
<YOUR SYNTAX ERROR MESSAGE HERE>

5
src/passes/01-parser/pascaligo.ml
View File

@ -19,7 +19,8 @@ module SubIO =
ext : string; (* ".ligo" *)
mode : [`Byte | `Point];
cmd : EvalOpt.command;
mono : bool
mono : bool;
pretty : bool
>
let options : options =
@ -34,6 +35,7 @@ module SubIO =
method mode = `Point
method cmd = EvalOpt.Quiet
method mono = false
method pretty = false
end
let make =
@ -46,6 +48,7 @@ module SubIO =
~mode:options#mode
~cmd:options#cmd
~mono:options#mono
~pretty:options#pretty
end
module Parser =

2
src/passes/01-parser/pascaligo/.links
View File

@ -21,5 +21,3 @@ $HOME/git/OCaml-build/Makefile
../shared/ParserUnit.mli
../shared/ParserUnit.ml
../shared/LexerLib.ml
$HOME/git/ligo/_build/default/src/passes/1-parser/pascaligo/ParErr.ml

176
src/passes/01-parser/pascaligo/AST.ml
View File

@ -106,14 +106,15 @@ type eof = Region.t
(* Literals *)
type variable = string reg
type fun_name = string reg
type type_name = string reg
type field_name = string reg
type map_name = string reg
type set_name = string reg
type constr = string reg
type attribute = string reg
type variable = string reg
type fun_name = string reg
type type_name = string reg
type type_constr = string reg
type field_name = string reg
type map_name = string reg
type set_name = string reg
type constr = string reg
type attribute = string reg
(* Parentheses *)
@ -181,11 +182,11 @@ and type_expr =
TProd of cartesian
| TSum of (variant reg, vbar) nsepseq reg
| TRecord of field_decl reg ne_injection reg
| TApp of (type_name * type_tuple) reg
| TApp of (type_constr * type_tuple) reg
| TFun of (type_expr * arrow * type_expr) reg
| TPar of type_expr par reg
| TVar of variable
| TStringLiteral of Lexer.lexeme reg
| TString of Lexer.lexeme reg
and cartesian = (type_expr, times) nsepseq reg
@ -205,7 +206,6 @@ and type_tuple = (type_expr, comma) nsepseq par reg
(* Function and procedure declarations *)
and fun_expr = {
kwd_recursive: kwd_recursive option;
kwd_function : kwd_function;
param : parameters;
colon : colon;
@ -215,17 +215,17 @@ and fun_expr = {
}
and fun_decl = {
kwd_recursive: kwd_recursive option;
kwd_function : kwd_function;
fun_name : variable;
param : parameters;
colon : colon;
ret_type : type_expr;
kwd_is : kwd_is;
block_with : (block reg * kwd_with) option;
return : expr;
terminator : semi option;
attributes : attr_decl option
kwd_recursive : kwd_recursive option;
kwd_function : kwd_function;
fun_name : variable;
param : parameters;
colon : colon;
ret_type : type_expr;
kwd_is : kwd_is;
block_with : (block reg * kwd_with) option;
return : expr;
terminator : semi option;
attributes : attr_decl option
}
and parameters = (param_decl, semi) nsepseq par reg
@ -249,19 +249,14 @@ and param_var = {
}
and block = {
opening : block_opening;
enclosing : block_enclosing;
statements : statements;
terminator : semi option;
closing : block_closing
terminator : semi option
}
and block_opening =
Block of kwd_block * lbrace
| Begin of kwd_begin
and block_closing =
Block of rbrace
| End of kwd_end
and block_enclosing =
Block of kwd_block * lbrace * rbrace
| BeginEnd of kwd_begin * kwd_end
and statements = (statement, semi) nsepseq
@ -378,10 +373,10 @@ and set_membership = {
and 'a case = {
kwd_case : kwd_case;
expr : expr;
opening : opening;
kwd_of : kwd_of;
enclosing : enclosing;
lead_vbar : vbar option;
cases : ('a case_clause reg, vbar) nsepseq reg;
closing : closing
cases : ('a case_clause reg, vbar) nsepseq reg
}
and 'a case_clause = {
@ -417,13 +412,12 @@ and for_loop =
| ForCollect of for_collect reg
and for_int = {
kwd_for : kwd_for;
assign : var_assign reg;
kwd_to : kwd_to;
bound : expr;
kwd_step : kwd_step option;
step : expr option;
block : block reg
kwd_for : kwd_for;
assign : var_assign reg;
kwd_to : kwd_to;
bound : expr;
step : (kwd_step * expr) option;
block : block reg
}
and var_assign = {
@ -452,7 +446,7 @@ and collection =
and expr =
ECase of expr case reg
| ECond of cond_expr reg
| EAnnot of annot_expr reg
| EAnnot of annot_expr par reg
| ELogic of logic_expr
| EArith of arith_expr
| EString of string_expr
@ -471,34 +465,12 @@ and expr =
| EPar of expr par reg
| EFun of fun_expr reg
and annot_expr = (expr * type_expr)
and annot_expr = expr * colon * type_expr
and set_expr =
SetInj of expr injection reg
| SetMem of set_membership reg
and 'a injection = {
opening : opening;
elements : ('a, semi) sepseq;
terminator : semi option;
closing : closing
}
and 'a ne_injection = {
opening : opening;
ne_elements : ('a, semi) nsepseq;
terminator : semi option;
closing : closing
}
and opening =
Kwd of keyword
| KwdBracket of keyword * lbracket
and closing =
End of kwd_end
| RBracket of rbracket
and map_expr =
MapLookUp of map_lookup reg
| MapInj of binding reg injection reg
@ -520,7 +492,7 @@ and logic_expr =
and bool_expr =
Or of kwd_or bin_op reg
| And of kwd_and bin_op reg
| Not of kwd_not un_op reg
| Not of kwd_not un_op reg
| False of c_False
| True of c_True
@ -544,15 +516,15 @@ and comp_expr =
| Neq of neq bin_op reg
and arith_expr =
Add of plus bin_op reg
| Sub of minus bin_op reg
| Mult of times bin_op reg
| Div of slash bin_op reg
| Mod of kwd_mod bin_op reg
| Neg of minus un_op reg
| Int of (Lexer.lexeme * Z.t) reg
| Nat of (Lexer.lexeme * Z.t) reg
| Mutez of (Lexer.lexeme * Z.t) reg
Add of plus bin_op reg
| Sub of minus bin_op reg
| Mult of times bin_op reg
| Div of slash bin_op reg
| Mod of kwd_mod bin_op reg
| Neg of minus un_op reg
| Int of (Lexer.lexeme * Z.t) reg
| Nat of (Lexer.lexeme * Z.t) reg
| Mutez of (Lexer.lexeme * Z.t) reg
and string_expr =
Cat of cat bin_op reg
@ -569,13 +541,13 @@ and constr_expr =
| NoneExpr of c_None
| ConstrApp of (constr * arguments option) reg
and field_assign = {
and field_assignment = {
field_name : field_name;
equal : equal;
assignment : equal;
field_expr : expr
}
and record = field_assign reg ne_injection
and record = field_assignment reg ne_injection
and projection = {
struct_name : variable;
@ -584,14 +556,14 @@ and projection = {
}
and update = {
record : path;
record : path;
kwd_with : kwd_with;
updates : field_path_assign reg ne_injection reg
updates : field_path_assignment reg ne_injection reg
}
and field_path_assign = {
field_path : (selection, dot) nsepseq;
equal : equal;
and field_path_assignment = {
field_path : path;
assignment : equal;
field_expr : expr
}
@ -605,6 +577,38 @@ and fun_call = (expr * arguments) reg
and arguments = tuple_expr
(* Injections *)
and 'a injection = {
kind : injection_kwd;
enclosing : enclosing;
elements : ('a, semi) sepseq;
terminator : semi option
}
and injection_kwd =
InjSet of keyword
| InjMap of keyword
| InjBigMap of keyword
| InjList of keyword
and enclosing =
Brackets of lbracket * rbracket
| End of kwd_end
and 'a ne_injection = {
kind : ne_injection_kwd;
enclosing : enclosing;
ne_elements : ('a, semi) nsepseq;
terminator : semi option
}
and ne_injection_kwd =
NEInjAttr of keyword
| NEInjSet of keyword
| NEInjMap of keyword
| NEInjRecord of keyword
(* Patterns *)
and pattern =
@ -635,7 +639,7 @@ and list_pattern =
| PCons of (pattern, cons) nsepseq reg
(* Projecting regions *)
(* PROJECTING REGIONS *)
let rec last to_region = function
[] -> Region.ghost
@ -660,7 +664,7 @@ let type_expr_to_region = function
| TApp {region; _}
| TFun {region; _}
| TPar {region; _}
| TStringLiteral {region; _}
| TString {region; _}
| TVar {region; _} -> region
let rec expr_to_region = function

306
src/passes/01-parser/pascaligo/Parser.mly
View File

@ -122,7 +122,8 @@ attr_decl:
open_attr_decl ";"? { $1 }
open_attr_decl:
ne_injection("attributes","<string>") { $1 }
ne_injection("attributes","<string>") {
$1 (fun region -> NEInjAttr region) }
(* Type declarations *)
@ -160,9 +161,9 @@ cartesian:
in TProd {region; value} }
core_type:
type_name { TVar $1 }
| "<string>" { TStringLiteral $1 }
| par(type_expr) { TPar $1 }
type_name { TVar $1 }
| "<string>" { TString $1 }
| par(type_expr) { TPar $1 }
| type_name type_tuple {
let region = cover $1.region $2.region
in TApp {region; value = $1,$2}
@ -214,19 +215,19 @@ record_type:
let () = Utils.nsepseq_to_list ne_elements
|> Scoping.check_fields in
let region = cover $1 $3
and value = {opening = Kwd $1;
and value = {kind = NEInjRecord $1;
enclosing = End $3;
ne_elements;
terminator;
closing = End $3}
terminator}
in TRecord {region; value}
}
| "record" "[" sep_or_term_list(field_decl,";") "]" {
let ne_elements, terminator = $3 in
let region = cover $1 $4
and value = {opening = KwdBracket ($1,$2);
and value = {kind = NEInjRecord $1;
enclosing = Brackets ($2,$4);
ne_elements;
terminator;
closing = RBracket $4}
terminator}
in TRecord {region; value} }
field_decl:
@ -238,16 +239,15 @@ field_decl:
fun_expr:
| ioption ("recursive") "function" parameters ":" type_expr "is" expr {
let stop = expr_to_region $7 in
let region = cover $2 stop
and value = {kwd_recursive= $1;
kwd_function = $2;
param = $3;
colon = $4;
ret_type = $5;
kwd_is = $6;
return = $7}
"function" parameters ":" type_expr "is" expr {
let stop = expr_to_region $6 in
let region = cover $1 stop
and value = {kwd_function = $1;
param = $2;
colon = $3;
ret_type = $4;
kwd_is = $5;
return = $6}
in {region; value} }
(* Function declarations *)
@ -271,7 +271,8 @@ open_fun_decl:
attributes = None}
in {region; value}
}
| ioption ("recursive") "function" fun_name parameters ":" type_expr "is" expr {
| ioption ("recursive") "function" fun_name parameters ":" type_expr "is"
expr {
Scoping.check_reserved_name $3;
let stop = expr_to_region $8 in
let region = cover $2 stop
@ -326,19 +327,17 @@ block:
"begin" sep_or_term_list(statement,";") "end" {
let statements, terminator = $2 in
let region = cover $1 $3
and value = {opening = Begin $1;
and value = {enclosing = BeginEnd ($1,$3);
statements;
terminator;
closing = End $3}
terminator}
in {region; value}
}
| "block" "{" sep_or_term_list(statement,";") "}" {
let statements, terminator = $3 in
let region = cover $1 $4
and value = {opening = Block ($1,$2);
and value = {enclosing = Block ($1,$2,$4);
statements;
terminator;
closing = Block $4}
terminator}
in {region; value} }
statement:
@ -404,124 +403,122 @@ instruction:
set_remove:
"remove" expr "from" "set" path {
let region = cover $1 (path_to_region $5) in
let value = {
kwd_remove = $1;
element = $2;
kwd_from = $3;
kwd_set = $4;
set = $5}
let value = {kwd_remove = $1;
element = $2;
kwd_from = $3;
kwd_set = $4;
set = $5}
in {region; value} }
map_remove:
"remove" expr "from" "map" path {
let region = cover $1 (path_to_region $5) in
let value = {
kwd_remove = $1;
key = $2;
kwd_from = $3;
kwd_map = $4;
map = $5}
let value = {kwd_remove = $1;
key = $2;
kwd_from = $3;
kwd_map = $4;
map = $5}
in {region; value} }
set_patch:
"patch" path "with" ne_injection("set",expr) {
let region = cover $1 $4.region in
let value = {
kwd_patch = $1;
path = $2;
kwd_with = $3;
set_inj = $4}
let set_inj = $4 (fun region -> NEInjSet region) in
let region = cover $1 set_inj.region in
let value = {kwd_patch = $1;
path = $2;
kwd_with = $3;
set_inj}
in {region; value} }
map_patch:
"patch" path "with" ne_injection("map",binding) {
let region = cover $1 $4.region in
let value = {
kwd_patch = $1;
path = $2;
kwd_with = $3;
map_inj = $4}
let map_inj = $4 (fun region -> NEInjMap region) in
let region = cover $1 map_inj.region in
let value = {kwd_patch = $1;
path = $2;
kwd_with = $3;
map_inj}
in {region; value} }
injection(Kind,element):
Kind sep_or_term_list(element,";") "end" {
let elements, terminator = $2 in
let region = cover $1 $3
and value = {
opening = Kwd $1;
elements = Some elements;
terminator;
closing = End $3}
in {region; value}
fun mk_kwd ->
let elements, terminator = $2 in
let region = cover $1 $3
and value = {
kind = mk_kwd $1;
enclosing = End $3;
elements = Some elements;
terminator}
in {region; value}
}
| Kind "end" {
let region = cover $1 $2
and value = {
opening = Kwd $1;
elements = None;
terminator = None;
closing = End $2}
in {region; value}
fun mk_kwd ->
let region = cover $1 $2
and value = {kind = mk_kwd $1;
enclosing = End $2;
elements = None;
terminator = None}
in {region; value}
}
| Kind "[" sep_or_term_list(element,";") "]" {
let elements, terminator = $3 in
let region = cover $1 $4
and value = {
opening = KwdBracket ($1,$2);
elements = Some elements;
terminator;
closing = RBracket $4}
in {region; value}
fun mk_kwd ->
let elements, terminator = $3 in
let region = cover $1 $4
and value = {kind = mk_kwd $1;
enclosing = Brackets ($2,$4);
elements = Some elements;
terminator}
in {region; value}
}
| Kind "[" "]" {
let region = cover $1 $3
and value = {
opening = KwdBracket ($1,$2);
elements = None;
terminator = None;
closing = RBracket $3}
in {region; value} }
fun mk_kwd ->
let region = cover $1 $3
and value = {kind = mk_kwd $1;
enclosing = Brackets ($2,$3);
elements = None;
terminator = None}
in {region; value} }
ne_injection(Kind,element):
Kind sep_or_term_list(element,";") "end" {
let ne_elements, terminator = $2 in
let region = cover $1 $3
and value = {
opening = Kwd $1;
ne_elements;
terminator;
closing = End $3}
in {region; value}
fun mk_kwd ->
let ne_elements, terminator = $2 in
let region = cover $1 $3
and value = {kind = mk_kwd $1;
enclosing = End $3;
ne_elements;
terminator}
in {region; value}
}
| Kind "[" sep_or_term_list(element,";") "]" {
let ne_elements, terminator = $3 in
let region = cover $1 $4
and value = {
opening = KwdBracket ($1,$2);
ne_elements;
terminator;
closing = RBracket $4}
in {region; value} }
fun mk_kwd ->
let ne_elements, terminator = $3 in
let region = cover $1 $4
and value = {kind = mk_kwd $1;
enclosing = Brackets ($2,$4);
ne_elements;
terminator}
in {region; value} }
binding:
expr "->" expr {
let start = expr_to_region $1
and stop = expr_to_region $3 in
let region = cover start stop
and value = {
source = $1;
arrow = $2;
image = $3}
and value = {source = $1;
arrow = $2;
image = $3}
in {region; value} }
record_patch:
"patch" path "with" ne_injection("record",field_assignment) {
let region = cover $1 $4.region in
let value = {
kwd_patch = $1;
path = $2;
kwd_with = $3;
record_inj = $4}
let record_inj = $4 (fun region -> NEInjRecord region) in
let region = cover $1 record_inj.region in
let value = {kwd_patch = $1;
path = $2;
kwd_with = $3;
record_inj}
in {region; value} }
proc_call:
@ -547,12 +544,9 @@ if_clause:
clause_block:
block { LongBlock $1 }
| "{" sep_or_term_list(statement,";") "}" {
let statements, terminator = $2 in
let region = cover $1 $3 in
let value = {lbrace = $1;
inside = statements, terminator;
rbrace = $3} in
ShortBlock {value; region} }
let value = {lbrace=$1; inside=$2; rbrace=$3}
in ShortBlock {value; region} }
case_instr:
case(if_clause) { $1 if_clause_to_region }
@ -563,10 +557,10 @@ case(rhs):
let region = cover $1 $6 in
let value = {kwd_case = $1;
expr = $2;
opening = Kwd $3;
kwd_of = $3;
enclosing = End $6;
lead_vbar = $4;
cases = $5 rhs_to_region;
closing = End $6}
cases = $5 rhs_to_region}
in {region; value}
}
| "case" expr "of" "[" "|"? cases(rhs) "]" {
@ -574,10 +568,10 @@ case(rhs):
let region = cover $1 $7 in
let value = {kwd_case = $1;
expr = $2;
opening = KwdBracket ($3,$4);
kwd_of = $3;
enclosing = Brackets ($4,$7);
lead_vbar = $5;
cases = $6 rhs_to_region;
closing = RBracket $7}
cases = $6 rhs_to_region}
in {region; value} }
cases(rhs):
@ -628,7 +622,6 @@ for_loop:
assign = $2;
kwd_to = $3;
bound = $4;
kwd_step = None;
step = None;
block = $5}
in For (ForInt {region; value})
@ -639,8 +632,7 @@ for_loop:
assign = $2;
kwd_to = $3;
bound = $4;
kwd_step = Some $5;
step = Some $6;
step = Some ($5, $6);
block = $7}
in For (ForInt {region; value})
}
@ -854,7 +846,7 @@ core_expr:
| "False" { ELogic (BoolExpr (False $1)) }
| "True" { ELogic (BoolExpr (True $1)) }
| "Unit" { EUnit $1 }
| annot_expr { EAnnot $1 }
| par(annot_expr) { EAnnot $1 }
| tuple_expr { ETuple $1 }
| list_expr { EList $1 }
| "None" { EConstr (NoneExpr $1) }
@ -896,20 +888,20 @@ fun_call_or_par_or_projection:
| fun_call { ECall $1 }
annot_expr:
"(" disj_expr ":" type_expr ")" {
let start = expr_to_region $2
and stop = type_expr_to_region $4 in
let region = cover start stop
and value = $2, $4
in {region; value} }
disj_expr ":" type_expr { $1,$2,$3 }
set_expr:
injection("set",expr) { SetInj $1 }
injection("set",expr) { SetInj ($1 (fun region -> InjSet region)) }
map_expr:
map_lookup { MapLookUp $1 }
| injection("map",binding) { MapInj $1 }
| injection("big_map",binding) { BigMapInj $1 }
map_lookup {
MapLookUp $1
}
| injection("map",binding) {
MapInj ($1 (fun region -> InjMap region))
}
| injection("big_map",binding) {
BigMapInj ($1 (fun region -> InjBigMap region)) }
map_lookup:
path brackets(expr) {
@ -957,41 +949,40 @@ record_expr:
"record" sep_or_term_list(field_assignment,";") "end" {
let ne_elements, terminator = $2 in
let region = cover $1 $3
and value : field_assign AST.reg ne_injection = {
opening = Kwd $1;
and value : field_assignment AST.reg ne_injection = {
kind = NEInjRecord $1;
enclosing = End $3;
ne_elements;
terminator;
closing = End $3}
terminator}
in {region; value}
}
| "record" "[" sep_or_term_list(field_assignment,";") "]" {
let ne_elements, terminator = $3 in
let region = cover $1 $4
and value : field_assign AST.reg ne_injection = {
opening = KwdBracket ($1,$2);
ne_elements;
terminator;
closing = RBracket $4}
in {region; value} }
let ne_elements, terminator = $3 in
let region = cover $1 $4
and value : field_assignment AST.reg ne_injection = {
kind = NEInjRecord $1;
enclosing = Brackets ($2,$4);
ne_elements;
terminator}
in {region; value} }
update_record:
path "with" ne_injection("record",field_path_assignment){
let region = cover (path_to_region $1) $3.region in
let value = {record=$1; kwd_with=$2; updates=$3}
path "with" ne_injection("record",field_path_assignment) {
let updates = $3 (fun region -> NEInjRecord region) in
let region = cover (path_to_region $1) updates.region in
let value = {record=$1; kwd_with=$2; updates}
in {region; value} }
field_assignment:
field_name "=" expr {
let region = cover $1.region (expr_to_region $3)
and value = {field_name=$1; equal=$2; field_expr=$3}
and value = {field_name=$1; assignment=$2; field_expr=$3}
in {region; value} }
field_path_assignment:
nsepseq(selection,".") "=" expr {
let start = nsepseq_to_region selection_to_region $1
and stop = expr_to_region $3 in
let region = cover start stop
and value = {field_path=$1; equal=$2; field_expr=$3}
path "=" expr {
let region = cover (path_to_region $1) (expr_to_region $3)
and value = {field_path=$1; assignment=$2; field_expr=$3}
in {region; value} }
fun_call:
@ -1010,8 +1001,8 @@ arguments:
par(nsepseq(expr,",")) { $1 }
list_expr:
injection("list",expr) { EListComp $1 }
| "nil" { ENil $1 }
injection("list",expr) { EListComp ($1 (fun region -> InjList region)) }
| "nil" { ENil $1 }
(* Patterns *)
@ -1034,9 +1025,10 @@ core_pattern:
| constr_pattern { PConstr $1 }
list_pattern:
injection("list",core_pattern) { PListComp $1 }
| "nil" { PNil $1 }
"nil" { PNil $1 }
| par(cons_pattern) { PParCons $1 }
| injection("list",core_pattern) {
PListComp ($1 (fun region -> InjList region)) }
cons_pattern:
core_pattern "#" pattern { $1,$2,$3 }

315
src/passes/01-parser/pascaligo/ParserLog.ml
View File

@ -27,11 +27,11 @@ let mk_state ~offsets ~mode ~buffer =
val pad_node = ""
method pad_node = pad_node
(** The method [pad] updates the current padding, which is
comprised of two components: the padding to reach the new node
(space before reaching a subtree, then a vertical bar for it)
and the padding for the new node itself (Is it the last child
of its parent?).
(* The method [pad] updates the current padding, which is
comprised of two components: the padding to reach the new node
(space before reaching a subtree, then a vertical bar for it)
and the padding for the new node itself (Is it the last child
of its parent?).
*)
method pad arity rank =
{< pad_path =
@ -44,7 +44,7 @@ let mk_state ~offsets ~mode ~buffer =
let compact state (region: Region.t) =
region#compact ~offsets:state#offsets state#mode
(** {1 Printing the tokens with their source regions} *)
(* Printing the tokens with their source regions *)
let print_nsepseq :
state -> string -> (state -> 'a -> unit) ->
@ -117,7 +117,7 @@ let rec print_tokens state ast =
print_token state eof "EOF"
and print_attr_decl state =
print_ne_injection state "attributes" print_string
print_ne_injection state print_string
and print_decl state = function
TypeDecl decl -> print_type_decl state decl
@ -153,7 +153,7 @@ and print_type_expr state = function
| 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
| TStringLiteral s -> print_string state s
| TString str -> print_string state str
and print_cartesian state {value; _} =
print_nsepseq state "*" print_type_expr value
@ -170,8 +170,8 @@ and print_variant state ({value; _}: variant reg) =
and print_sum_type state {value; _} =
print_nsepseq state "|" print_variant value
and print_record_type state record_type =
print_ne_injection state "record" print_field_decl record_type
and print_record_type state =
print_ne_injection state print_field_decl
and print_type_app state {value; _} =
let type_name, type_tuple = value in
@ -180,9 +180,9 @@ and print_type_app state {value; _} =
and print_type_fun state {value; _} =
let type_expr_a, arrow, type_expr_b = value in
print_type_expr state type_expr_a;
print_token state arrow "->";
print_type_expr state 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 state {value; _} =
let {lpar; inside; rpar} = value in
@ -206,12 +206,12 @@ and print_fun_decl state {value; _} =
let {kwd_function; fun_name; param; colon;
ret_type; kwd_is; block_with;
return; terminator; _} = value in
print_token state kwd_function "function";
print_var state fun_name;
print_parameters state param;
print_token state colon ":";
print_type_expr state ret_type;
print_token state kwd_is "is";
print_token state kwd_function "function";
print_var state fun_name;
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) ->
@ -221,15 +221,14 @@ and print_fun_decl state {value; _} =
print_terminator state terminator;
and print_fun_expr state {value; _} =
let {kwd_recursive; kwd_function; param; colon;
let {kwd_function; param; colon;
ret_type; kwd_is; return} : fun_expr = value in
print_token_opt state kwd_recursive "recursive";
print_token state kwd_function "function";
print_parameters state param;
print_token state colon ":";
print_type_expr state ret_type;
print_token state kwd_is "is";
print_expr state return
print_token state kwd_function "function";
print_parameters state param;
print_token state colon ":";
print_type_expr state ret_type;
print_token state kwd_is "is";
print_expr state return
and print_parameters state {value; _} =
let {lpar; inside; rpar} = value in
@ -256,22 +255,19 @@ and print_param_var state {value; _} =
print_type_expr state param_type
and print_block state block =
let {opening; statements; terminator; closing} = block.value in
print_block_opening state opening;
print_statements state statements;
print_terminator state terminator;
print_block_closing state closing
and print_block_opening state = function
Block (kwd_block, lbrace) ->
print_token state kwd_block "block";
print_token state lbrace "{"
| Begin kwd_begin ->
print_token state kwd_begin "begin"
and print_block_closing state = function
Block rbrace -> print_token state rbrace "}"
| End kwd_end -> print_token state kwd_end "end"
let {enclosing; statements; terminator} = block.value in
match enclosing with
Block (kwd_block, lbrace, rbrace) ->
print_token state kwd_block "block";
print_token state lbrace "{";
print_statements state statements;
print_terminator state terminator;
print_token state rbrace "}"
| BeginEnd (kwd_begin, kwd_end) ->
print_token state kwd_begin "begin";
print_statements state statements;
print_terminator state terminator;
print_token state kwd_end "end"
and print_data_decl state = function
LocalConst decl -> print_const_decl state decl
@ -344,14 +340,20 @@ and print_clause_block state = function
print_token state rbrace "}"
and print_case_instr state (node : if_clause case) =
let {kwd_case; expr; opening;
lead_vbar; cases; closing} = node in
let {kwd_case; expr; kwd_of; enclosing; lead_vbar; cases} = node in
print_token state kwd_case "case";
print_expr state expr;
print_opening state "of" opening;
print_token_opt state lead_vbar "|";
print_cases_instr state cases;
print_closing state closing
print_token state kwd_of "of";
match enclosing with
Brackets (lbracket, rbracket) ->
print_token state lbracket "[";
print_token_opt state lead_vbar "|";
print_cases_instr state cases;
print_token state rbracket "]"
| End kwd_end ->
print_token_opt state lead_vbar "|";
print_cases_instr state cases;
print_token state kwd_end "end"
and print_token_opt state = function
None -> fun _ -> ()
@ -393,19 +395,16 @@ and print_for_loop state = function
| ForCollect for_collect -> print_for_collect state for_collect
and print_for_int state ({value; _} : for_int reg) =
let {kwd_for; assign; kwd_to; bound; kwd_step; step; block} = value in
let {kwd_for; assign; kwd_to; bound; step; block} = value in
print_token state kwd_for "for";
print_var_assign state assign;
print_token state kwd_to "to";
print_expr state bound;
match kwd_step with
| None -> ();
| Some kwd_step ->
print_token state kwd_step "step";
match step with
| None -> ();
| Some step ->
print_expr state step;
(match step with
None -> ();
| Some (kwd_step, expr) ->
print_token state kwd_step "step";
print_expr state expr);
print_block state block
and print_var_assign state {value; _} =
@ -461,19 +460,27 @@ and print_expr state = function
| EPar e -> print_par_expr state e
| EFun e -> print_fun_expr state e
and print_annot_expr state (expr , type_expr) =
and print_annot_expr state node =
let {inside; _} : annot_expr par = node in
let expr, _, type_expr = inside in
print_expr state expr;
print_type_expr state type_expr
and print_case_expr state (node : expr case) =
let {kwd_case; expr; opening;
lead_vbar; cases; closing} = node in
let {kwd_case; expr; kwd_of; enclosing; lead_vbar; cases} = node in
print_token state kwd_case "case";
print_expr state expr;
print_opening state "of" opening;
print_token_opt state lead_vbar "|";
print_cases_expr state cases;
print_closing state closing
print_token state kwd_of "of";
match enclosing with
Brackets (lbracket, rbracket) ->
print_token state lbracket "[";
print_token_opt state lead_vbar "|";
print_cases_expr state cases;
print_token state rbracket "]"
| End kwd_end ->
print_token_opt state lead_vbar "|";
print_cases_expr state cases;
print_token state kwd_end "end"
and print_cases_expr state {value; _} =
print_nsepseq state "|" print_case_clause_expr value
@ -486,11 +493,11 @@ and print_case_clause_expr state {value; _} =
and print_map_expr state = function
MapLookUp {value; _} -> print_map_lookup state value
| MapInj inj -> print_injection state "map" print_binding inj
| BigMapInj inj -> print_injection state "big_map" print_binding inj
| MapInj inj -> print_injection state print_binding inj
| BigMapInj inj -> print_injection state print_binding inj
and print_set_expr state = function
SetInj inj -> print_injection state "set" print_expr inj
SetInj inj -> print_injection state print_expr inj
| SetMem mem -> print_set_membership state mem
and print_set_membership state {value; _} =
@ -600,7 +607,7 @@ and print_list_expr state = function
print_expr state arg1;
print_token state op "#";
print_expr state arg2
| EListComp e -> print_injection state "list" print_expr e
| EListComp e -> print_injection state print_expr e
| ENil e -> print_nil state e
and print_constr_expr state = function
@ -608,27 +615,26 @@ and print_constr_expr state = function
| NoneExpr e -> print_none_expr state e
| ConstrApp e -> print_constr_app state e
and print_record_expr state e =
print_ne_injection state "record" print_field_assign e
and print_record_expr state =
print_ne_injection state print_field_assignment
and print_field_assign state {value; _} =
let {field_name; equal; field_expr} = value in
and print_field_assignment state {value; _} =
let {field_name; assignment; field_expr} = value in
print_var state field_name;
print_token state equal "=";
print_token state assignment "=";
print_expr state field_expr
and print_field_path_assign state {value; _} =
let {field_path; equal; field_expr} = value in
print_nsepseq state "field_path" print_selection field_path;
print_token state equal "=";
and print_field_path_assignment state {value; _} =
let {field_path; assignment; field_expr} = value in
print_path state field_path;
print_token state assignment "=";
print_expr state field_expr
and print_update_expr state {value; _} =
let {record; kwd_with; updates} = value in
print_path state record;
print_token state kwd_with "with";
print_ne_injection state "updates field" print_field_path_assign updates
print_ne_injection state print_field_path_assignment updates
and print_projection state {value; _} =
let {struct_name; selector; field_path} = value in
@ -648,21 +654,21 @@ and print_record_patch state node =
print_token state kwd_patch "patch";
print_path state path;
print_token state kwd_with "with";
print_ne_injection state "record" print_field_assign record_inj
print_ne_injection state print_field_assignment record_inj
and print_set_patch state node =
let {kwd_patch; path; kwd_with; set_inj} = node in
print_token state kwd_patch "patch";
print_path state path;
print_token state kwd_with "with";
print_ne_injection state "set" print_expr set_inj
print_ne_injection state print_expr set_inj
and print_map_patch state node =
let {kwd_patch; path; kwd_with; map_inj} = node in
print_token state kwd_patch "patch";
print_path state path;
print_token state kwd_with "with";
print_ne_injection state "map" print_binding map_inj
print_ne_injection state print_binding map_inj
and print_map_remove state node =
let {kwd_remove; key; kwd_from; kwd_map; map} = node in
@ -681,35 +687,48 @@ and print_set_remove state node =
print_path state set
and print_injection :
'a.state -> string -> (state -> 'a -> unit) ->
'a injection reg -> unit =
fun state kwd print {value; _} ->
let {opening; elements; terminator; closing} = value in
print_opening state kwd opening;
print_sepseq state ";" print elements;
print_terminator state terminator;
print_closing state closing
'a.state -> (state -> 'a -> unit) -> 'a injection reg -> unit =
fun state print {value; _} ->
let {kind; enclosing; elements; terminator} = value in
print_injection_kwd state kind;
match enclosing with
Brackets (lbracket, rbracket) ->
print_token state lbracket "[";
print_sepseq state ";" print elements;
print_terminator state terminator;
print_token state rbracket "]"
| End kwd_end ->
print_sepseq state ";" print elements;
print_terminator state terminator;
print_token state kwd_end "end"
and print_injection_kwd state = function
InjSet kwd_set -> print_token state kwd_set "set"
| InjMap kwd_map -> print_token state kwd_map "map"
| InjBigMap kwd_big_map -> print_token state kwd_big_map "big_map"
| InjList kwd_list -> print_token state kwd_list "list"
and print_ne_injection :
'a.state -> string -> (state -> 'a -> unit) ->
'a ne_injection reg -> unit =
fun state kwd print {value; _} ->
let {opening; ne_elements; terminator; closing} = value in
print_opening state kwd opening;
print_nsepseq state ";" print ne_elements;
print_terminator state terminator;
print_closing state closing
'a.state -> (state -> 'a -> unit) -> 'a ne_injection reg -> unit =
fun state print {value; _} ->
let {kind; enclosing; ne_elements; terminator} = value in
print_ne_injection_kwd state kind;
match enclosing with
Brackets (lbracket, rbracket) ->
print_token state lbracket "[";
print_nsepseq state ";" print ne_elements;
print_terminator state terminator;
print_token state rbracket "]"
| End kwd_end ->
print_nsepseq state ";" print ne_elements;
print_terminator state terminator;
print_token state kwd_end "end"
and print_opening state lexeme = function
Kwd kwd ->
print_token state kwd lexeme
| KwdBracket (kwd, lbracket) ->
print_token state kwd lexeme;
print_token state lbracket "["
and print_closing state = function
RBracket rbracket -> print_token state rbracket "]"
| End kwd_end -> print_token state kwd_end "end"
and print_ne_injection_kwd state = function
NEInjAttr kwd_attributes -> print_token state kwd_attributes "attributes"
| NEInjSet kwd_set -> print_token state kwd_set "set"
| NEInjMap kwd_map -> print_token state kwd_map "map"
| NEInjRecord kwd_record -> print_token state kwd_record "record"
and print_binding state {value; _} =
let {source; arrow; image} = value in
@ -787,7 +806,7 @@ and print_patterns state {value; _} =
and print_list_pattern state = function
PListComp comp ->
print_injection state "list" print_pattern comp
print_injection state print_pattern comp
| PNil kwd_nil ->
print_token state kwd_nil "nil"
| PParCons cons ->
@ -831,7 +850,7 @@ let pattern_to_string ~offsets ~mode =
let instruction_to_string ~offsets ~mode =
to_string ~offsets ~mode print_instruction
(** {1 Pretty-printing the AST} *)
(* Pretty-printing the AST *)
let pp_ident state {value=name; region} =
let reg = compact state region in
@ -842,12 +861,20 @@ let pp_node state name =
let node = sprintf "%s%s\n" state#pad_path name
in Buffer.add_string state#buffer node
let pp_string state = pp_ident state
let pp_string 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_verbatim 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_loc_node state name region =
pp_ident state {value=name; region}
let rec pp_ast state {decl; _} =
let rec pp_cst state {decl; _} =
let apply len rank =
pp_declaration (state#pad len rank) in
let decls = Utils.nseq_to_list decl in
@ -943,9 +970,9 @@ and pp_type_expr state = function
field_decl.value in
let fields = Utils.nsepseq_to_list value.ne_elements in
List.iteri (List.length fields |> apply) fields
| TStringLiteral s ->
pp_node state "String";
pp_string (state#pad 1 0) s
| TString s ->
pp_node state "TString";
pp_string (state#pad 1 0) s
and pp_cartesian state {value; _} =
let apply len rank =
@ -1244,8 +1271,8 @@ and pp_projection state proj =
List.iteri (apply len) selections
and pp_update state update =
pp_path state update.record;
pp_ne_injection pp_field_path_assign state update.updates.value
pp_path (state#pad 2 0) update.record;
pp_ne_injection pp_field_path_assignment state update.updates.value
and pp_selection state = function
FieldName name ->
@ -1285,17 +1312,27 @@ and pp_for_loop state = function
pp_for_collect state value
and pp_for_int state for_int =
let {assign; bound; step; block; _} = for_int in
let arity =
match step with None -> 3 | Some _ -> 4 in
let () =
let state = state#pad 3 0 in
let state = state#pad arity 0 in
pp_node state "<init>";
pp_var_assign state for_int.assign.value in
pp_var_assign state assign.value in
let () =
let state = state#pad 3 1 in
let state = state#pad arity 1 in
pp_node state "<bound>";
pp_expr (state#pad 1 0) for_int.bound in
pp_expr (state#pad 1 0) bound in
let () =
let state = state#pad 3 2 in
let statements = for_int.block.value.statements in
match step with
None -> ()
| Some (_, expr) ->
let state = state#pad arity 2 in
pp_node state "<step>";
pp_expr (state#pad 1 0) expr in
let () =
let state = state#pad arity (arity-1) in
let statements = block.value.statements in
pp_node state "<statements>";
pp_statements state statements
in ()
@ -1318,10 +1355,10 @@ and pp_for_collect state collect =
pp_collection (state#pad 2 0) collect.collection;
pp_expr (state#pad 1 0) collect.expr in
let () =
let state = state#pad 3 2 in
let statements = collect.block.value.statements in
pp_node state "<statements>";
pp_statements state statements
let state = state#pad 3 2 in
let statements = collect.block.value.statements in
pp_node state "<statements>";
pp_statements state statements
in ()
and pp_collection state = function
@ -1343,18 +1380,18 @@ and pp_fun_call state (expr, args) =
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
pp_ne_injection pp_field_assignment state patch.record_inj.value
and pp_field_assign state {value; _} =
and pp_field_assignment state {value; _} =
pp_node state "<field assignment>";
pp_ident (state#pad 2 0) value.field_name;
pp_expr (state#pad 2 1) value.field_expr
and pp_field_path_assign state {value; _} =
pp_node state "<field path for update>";
let path = Utils.nsepseq_to_list value.field_path in
List.iter (pp_selection (state#pad 2 0)) path;
pp_expr (state#pad 2 1) value.field_expr
and pp_field_path_assignment state {value; _} =
let {field_path; field_expr; _} = value in
pp_node state "<update>";
pp_path (state#pad 2 0) field_path;
pp_expr (state#pad 2 1) field_expr
and pp_map_patch state patch =
pp_path (state#pad 2 0) patch.path;
@ -1403,7 +1440,7 @@ and pp_expr state = function
pp_cond_expr state value
| EAnnot {value; region} ->
pp_loc_node state "EAnnot" region;
pp_annotated state value
pp_annotated state value.inside
| ELogic e_logic ->
pp_node state "ELogic";
pp_e_logic (state#pad 1 0) e_logic
@ -1424,7 +1461,7 @@ and pp_expr state = function
pp_constr_expr (state#pad 1 0) e_constr
| ERecord {value; region} ->
pp_loc_node state "ERecord" region;
pp_ne_injection pp_field_assign state value
pp_ne_injection pp_field_assignment state value
| EProj {value; region} ->
pp_loc_node state "EProj" region;
pp_projection state value
@ -1576,9 +1613,9 @@ and pp_string_expr state = function
pp_string (state#pad 1 0) s
| Verbatim v ->
pp_node state "Verbatim";
pp_string (state#pad 1 0) v
pp_verbatim (state#pad 1 0) v
and pp_annotated state (expr, t_expr) =
and pp_annotated state (expr, _, t_expr) =
pp_expr (state#pad 2 0) expr;
pp_type_expr (state#pad 2 1) t_expr

2
src/passes/01-parser/pascaligo/ParserLog.mli
View File

@ -33,5 +33,5 @@ val instruction_to_string :
(** {1 Pretty-printing of AST nodes} *)
val pp_ast : state -> AST.t -> unit
val pp_cst : state -> AST.t -> unit
val pp_expr : state -> AST.expr -> unit

25
src/passes/01-parser/pascaligo/ParserMain.ml
View File

@ -22,7 +22,8 @@ module SubIO =
ext : string;
mode : [`Byte | `Point];
cmd : EvalOpt.command;
mono : bool
mono : bool;
pretty : bool
>
let options : options =
@ -36,6 +37,7 @@ module SubIO =
method mode = IO.options#mode
method cmd = IO.options#cmd
method mono = IO.options#mono
method pretty = IO.options#pretty
end
let make =
@ -48,6 +50,7 @@ module SubIO =
~mode:options#mode
~cmd:options#cmd
~mono:options#mono
~pretty:options#pretty
end
module Parser =
@ -67,14 +70,28 @@ module ParserLog =
module Lexer = Lexer.Make (LexToken)
module Unit =
ParserUnit.Make (Lexer)(AST)(Parser)(ParErr)(ParserLog)(SubIO)
ParserUnit.Make (Lexer)(AST)(Parser)(Parser_msg)(ParserLog)(SubIO)
(* Main *)
let wrap = function
Stdlib.Ok _ -> flush_all ()
Stdlib.Ok ast ->
if IO.options#pretty then
begin
let doc = Pretty.print ast in
let width =
match Terminal_size.get_columns () with
None -> 60
| Some c -> c in
PPrint.ToChannel.pretty 1.0 width stdout doc;
print_newline ()
end;
flush_all ()
| Error msg ->
(flush_all (); Printf.eprintf "\027[31m%s\027[0m%!" msg.Region.value)
begin
flush_all ();
Printf.eprintf "\027[31m%s\027[0m%!" msg.Region.value
end
let () =
match IO.options#input with

632
src/passes/01-parser/pascaligo/Pretty.ml Normal file
View File

@ -0,0 +1,632 @@
[@@@warning "-42"]
[@@@warning "-27"]
[@@@warning "-26"]
open AST
module Region = Simple_utils.Region
open! Region
open! PPrint
let pp_par : ('a -> document) -> 'a par reg -> document =
fun printer {value; _} ->
string "(" ^^ nest 1 (printer value.inside ^^ string ")")
let pp_brackets : ('a -> document) -> 'a brackets reg -> document =
fun printer {value; _} ->
string "[" ^^ nest 1 (printer value.inside ^^ string "]")
let pp_braces : ('a -> document) -> 'a braces reg -> document =
fun printer {value; _} ->
string "{" ^^ nest 1 (printer value.inside ^^ string "}")
let rec print ast =
let app decl = group (pp_declaration decl) in
let decl = Utils.nseq_to_list ast.decl in
separate_map (hardline ^^ hardline) app decl
and pp_declaration = function
TypeDecl d -> pp_type_decl d
| ConstDecl d -> pp_const_decl d
| FunDecl d -> pp_fun_decl d
| AttrDecl d -> pp_attr_decl d
and pp_attr_decl decl = pp_ne_injection pp_string decl
and pp_const_decl {value; _} =
let {name; const_type; init; attributes; _} = value in
let start = string ("const " ^ name.value) in
let t_expr = pp_type_expr const_type in
let attr = match attributes with
None -> empty
| Some a -> hardline ^^ pp_attr_decl a in
group (start ^/^ nest 2 (string ": " ^^ t_expr))
^^ group (break 1 ^^ nest 2 (string "= " ^^ pp_expr init))
^^ attr
(* Type declarations *)
and pp_type_decl decl =
let {name; type_expr; _} = decl.value in
string "type " ^^ string name.value ^^ string " is"
^^ group (nest 2 (break 1 ^^ pp_type_expr type_expr))
and pp_type_expr = function
TProd t -> pp_cartesian t
| TSum t -> pp_variants t
| TRecord t -> pp_fields t
| TApp t -> pp_type_app t
| TFun t -> pp_fun_type t
| TPar t -> pp_type_par t
| TVar t -> pp_ident t
| TString s -> pp_string s
and pp_cartesian {value; _} =
let head, tail = value in
let rec app = function
[] -> empty
| [e] -> group (break 1 ^^ pp_type_expr e)
| e::items ->
group (break 1 ^^ pp_type_expr e ^^ string " *") ^^ app items
in pp_type_expr head ^^ string " *" ^^ app (List.map snd tail)
and pp_variants {value; _} =
let head, tail = value in
let head = pp_variant head in
let head = if tail = [] then head
else ifflat head (string " " ^^ head) in
let rest = List.map snd tail in
let app variant = break 1 ^^ string "| " ^^ pp_variant variant
in head ^^ concat_map app rest
and pp_variant {value; _} =
let {constr; arg} = value in
match arg with
None -> pp_ident constr
| Some (_, e) ->
prefix 4 1 (pp_ident constr ^^ string " of") (pp_type_expr e)
and pp_fields fields = pp_ne_injection pp_field_decl fields
and pp_field_decl {value; _} =
let {field_name; field_type; _} = value in
let name = pp_ident field_name in
let t_expr = pp_type_expr field_type
in prefix 2 1 (name ^^ string " :") t_expr
and pp_fun_type {value; _} =
let lhs, _, rhs = value in
group (pp_type_expr lhs ^^ string " ->" ^/^ pp_type_expr rhs)
and pp_type_par t = pp_par pp_type_expr t
and pp_type_app {value = ctor, tuple; _} =
prefix 2 1 (pp_type_constr ctor) (pp_type_tuple tuple)
and pp_type_constr ctor = string ctor.value
and pp_type_tuple {value; _} =
let head, tail = value.inside in
let rec app = function
[] -> empty
| [e] -> group (break 1 ^^ pp_type_expr e)
| e::items ->
group (break 1 ^^ pp_type_expr e ^^ string ",") ^^ app items in
let components =
if tail = []
then pp_type_expr head
else pp_type_expr head ^^ string "," ^^ app (List.map snd tail)
in string "(" ^^ nest 1 (components ^^ string ")")
(* Function and procedure declarations *)
and pp_fun_expr {value; _} =
let {param; ret_type; return; _} : fun_expr = value in
let start = string "function" in
let parameters = pp_par pp_parameters param in
let return_t = pp_type_expr ret_type in
let expr = pp_expr return in
group (start ^^ nest 2 (break 1 ^^ parameters))
^^ group (break 1 ^^ nest 2 (string ": " ^^ return_t))
^^ string " is" ^^ group (nest 4 (break 1 ^^ expr))
and pp_fun_decl {value; _} =
let {kwd_recursive; fun_name; param;
ret_type; block_with; return; attributes; _} = value in
let start =
match kwd_recursive with
None -> string "function"
| Some _ -> string "recursive" ^/^ string "function" in
let start = start ^^ group (break 1 ^^ nest 2 (pp_ident fun_name)) in
let parameters = pp_par pp_parameters param in
let return_t = pp_type_expr ret_type in
let expr = pp_expr return in
let body =
match block_with with
None -> group (nest 2 (break 1 ^^ expr))
| Some (b,_) -> hardline ^^ pp_block b ^^ string " with"
^^ group (nest 4 (break 1 ^^ expr))
and attr =
match attributes with
None -> empty
| Some a -> hardline ^^ pp_attr_decl a in
prefix 2 1 start parameters
^^ group (nest 2 (break 1 ^^ string ": " ^^ nest 2 return_t ^^ string " is"))
^^ body ^^ attr
and pp_parameters p = pp_nsepseq ";" pp_param_decl p
and pp_param_decl = function
ParamConst c -> pp_param_const c
| ParamVar v -> pp_param_var v
and pp_param_const {value; _} =
let {var; param_type; _} : param_const = value in
let name = string ("const " ^ var.value) in
let t_expr = pp_type_expr param_type
in prefix 2 1 (name ^^ string " :") t_expr
and pp_param_var {value; _} =
let {var; param_type; _} : param_var = value in
let name = string ("var " ^ var.value) in
let t_expr = pp_type_expr param_type
in prefix 2 1 (name ^^ string " :") t_expr
and pp_block {value; _} =
string "block {"
^^ nest 2 (hardline ^^ pp_statements value.statements)
^^ hardline ^^ string "}"
and pp_statements s = pp_nsepseq ";" pp_statement s
and pp_statement = function
Instr s -> pp_instruction s
| Data s -> pp_data_decl s
| Attr s -> pp_attr_decl s
and pp_data_decl = function
LocalConst d -> pp_const_decl d
| LocalVar d -> pp_var_decl d
| LocalFun d -> pp_fun_decl d
and pp_var_decl {value; _} =
let {name; var_type; init; _} = value in
let start = string ("var " ^ name.value) in
let t_expr = pp_type_expr var_type in
group (start ^/^ nest 2 (string ": " ^^ t_expr))
^^ group (break 1 ^^ nest 2 (string ":= " ^^ pp_expr init))
and pp_instruction = function
Cond i -> group (pp_conditional i)
| CaseInstr i -> pp_case pp_if_clause i
| Assign i -> pp_assignment i
| Loop i -> pp_loop i
| ProcCall i -> pp_fun_call i
| Skip _ -> string "skip"
| RecordPatch i -> pp_record_patch i
| MapPatch i -> pp_map_patch i
| SetPatch i -> pp_set_patch i
| MapRemove i -> pp_map_remove i
| SetRemove i -> pp_set_remove i
and pp_set_remove {value; _} =
let {element; set; _} : set_remove = value in
string "remove" ^^ group (nest 2 (break 1 ^^ pp_expr element))
^^ group (break 1 ^^ prefix 2 1 (string "from set") (pp_path set))
and pp_map_remove {value; _} =
let {key; map; _} = value in
string "remove" ^^ group (nest 2 (break 1 ^^ pp_expr key))
^^ group (break 1 ^^ prefix 2 1 (string "from map") (pp_path map))
and pp_set_patch {value; _} =
let {path; set_inj; _} = value in
let inj = pp_ne_injection pp_expr set_inj in
string "patch"
^^ group (nest 2 (break 1 ^^ pp_path path) ^/^ string "with")
^^ group (nest 2 (break 1 ^^ inj))
and pp_map_patch {value; _} =
let {path; map_inj; _} = value in
let inj = pp_ne_injection pp_binding map_inj in
string "patch"
^^ group (nest 2 (break 1 ^^ pp_path path) ^/^ string "with")
^^ group (nest 2 (break 1 ^^ inj))
and pp_binding {value; _} =
let {source; image; _} = value in
pp_expr source
^^ string " ->" ^^ group (nest 2 (break 1 ^^ pp_expr image))
and pp_record_patch {value; _} =
let {path; record_inj; _} = value in
let inj = pp_record record_inj in
string "patch"
^^ group (nest 2 (break 1 ^^ pp_path path) ^/^ string "with")
^^ group (nest 2 (break 1 ^^ inj))
and pp_cond_expr {value; _} =
let {test; ifso; ifnot; _} : cond_expr = value in
let test = string "if " ^^ group (nest 3 (pp_expr test))
and ifso = string "then" ^^ group (nest 2 (break 1 ^^ pp_expr ifso))
and ifnot = string "else" ^^ group (nest 2 (break 1 ^^ pp_expr ifnot))
in test ^/^ ifso ^/^ ifnot
and pp_conditional {value; _} =
let {test; ifso; ifnot; _} : conditional = value in
let test = string "if " ^^ group (nest 3 (pp_expr test))
and ifso = match ifso with
ClauseInstr _ | ClauseBlock LongBlock _ ->
string "then"
^^ group (nest 2 (break 1 ^^ pp_if_clause ifso))
| ClauseBlock ShortBlock _ ->
string "then {"
^^ group (nest 2 (hardline ^^ pp_if_clause ifso))
^^ hardline ^^ string "}"
and ifnot = match ifnot with
ClauseInstr _ | ClauseBlock LongBlock _ ->
string "else"
^^ group (nest 2 (break 1 ^^ pp_if_clause ifnot))
| ClauseBlock ShortBlock _ ->
string "else {"
^^ group (nest 2 (hardline ^^ pp_if_clause ifnot))
^^ hardline ^^ string "}"
in test ^/^ ifso ^/^ ifnot
and pp_if_clause = function
ClauseInstr i -> pp_instruction i
| ClauseBlock b -> pp_clause_block b
and pp_clause_block = function
LongBlock b -> pp_block b
| ShortBlock b -> Utils.(pp_statements <@ fst) b.value.inside
and pp_set_membership {value; _} =
let {set; element; _} : set_membership = value in
group (pp_expr set ^/^ string "contains" ^/^ pp_expr element)
and pp_case : 'a.('a -> document) -> 'a case Region.reg -> document =
fun printer {value; _} ->
let {expr; cases; _} = value in
group (string "case " ^^ nest 5 (pp_expr expr) ^/^ string "of [")
^^ hardline ^^ pp_cases printer cases
^^ hardline ^^ string "]"
and pp_cases :
'a.('a -> document) ->
('a case_clause reg, vbar) Utils.nsepseq Region.reg ->
document =
fun printer {value; _} ->
let head, tail = value in
let head = pp_case_clause printer head in
let head = blank 2 ^^ head in
let rest = List.map snd tail in
let app clause = break 1 ^^ string "| " ^^ pp_case_clause printer clause
in head ^^ concat_map app rest
and pp_case_clause :
'a.('a -> document) -> 'a case_clause Region.reg -> document =
fun printer {value; _} ->
let {pattern; rhs; _} = value in
pp_pattern pattern ^^ prefix 4 1 (string " ->") (printer rhs)
and pp_assignment {value; _} =
let {lhs; rhs; _} = value in
prefix 2 1 (pp_lhs lhs ^^ string " :=") (pp_expr rhs)
and pp_lhs : lhs -> document = function
Path p -> pp_path p
| MapPath p -> pp_map_lookup p
and pp_loop = function
While l -> pp_while_loop l
| For f -> pp_for_loop f
and pp_while_loop {value; _} =
let {cond; block; _} = value in
prefix 2 1 (string "while") (pp_expr cond) ^^ hardline ^^ pp_block block
and pp_for_loop = function
ForInt l -> pp_for_int l
| ForCollect l -> pp_for_collect l
and pp_for_int {value; _} =
let {assign; bound; step; block; _} = value in
let step =
match step with
None -> empty
| Some (_, e) -> prefix 2 1 (string " step") (pp_expr e) in
prefix 2 1 (string "for") (pp_var_assign assign)
^^ prefix 2 1 (string " to") (pp_expr bound)
^^ step ^^ hardline ^^ pp_block block
and pp_var_assign {value; _} =
let {name; expr; _} = value in
prefix 2 1 (pp_ident name ^^ string " :=") (pp_expr expr)
and pp_for_collect {value; _} =
let {var; bind_to; collection; expr; block; _} = value in
let binding =
match bind_to with
None -> pp_ident var
| Some (_, dest) -> pp_ident var ^^ string " -> " ^^ pp_ident dest in
prefix 2 1 (string "for") binding
^^ prefix 2 1 (string " in") (pp_collection collection ^/^ pp_expr expr)
^^ hardline ^^ pp_block block
and pp_collection = function
Map _ -> string "map"
| Set _ -> string "set"
| List _ -> string "list"
(* Expressions *)
and pp_expr = function
ECase e -> pp_case pp_expr e
| ECond e -> group (pp_cond_expr e)
| EAnnot e -> pp_annot_expr e
| ELogic e -> group (pp_logic_expr e)
| EArith e -> group (pp_arith_expr e)
| EString e -> pp_string_expr e
| EList e -> group (pp_list_expr e)
| ESet e -> pp_set_expr e
| EConstr e -> pp_constr_expr e
| ERecord e -> pp_record e
| EProj e -> pp_projection e
| EUpdate e -> pp_update e
| EMap e -> pp_map_expr e
| EVar e -> pp_ident e
| ECall e -> pp_fun_call e
| EBytes e -> pp_bytes e
| EUnit _ -> string "Unit"
| ETuple e -> pp_tuple_expr e
| EPar e -> pp_par pp_expr e
| EFun e -> pp_fun_expr e
and pp_annot_expr {value; _} =
let expr, _, type_expr = value.inside in
group (string "(" ^^ nest 1 (pp_expr expr ^/^ string ": "
^^ pp_type_expr type_expr ^^ string ")"))
and pp_set_expr = function
SetInj inj -> pp_injection pp_expr inj
| SetMem mem -> pp_set_membership mem
and pp_map_expr = function
MapLookUp fetch -> pp_map_lookup fetch
| MapInj inj -> pp_injection pp_binding inj
| BigMapInj inj -> pp_injection pp_binding inj
and pp_map_lookup {value; _} =
prefix 2 1 (pp_path value.path) (pp_brackets pp_expr value.index)
and pp_path = function
Name v -> pp_ident v
| Path p -> pp_projection p
and pp_logic_expr = function
BoolExpr e -> pp_bool_expr e
| CompExpr e -> pp_comp_expr e
and pp_bool_expr = function
Or e -> pp_bin_op "or" e
| And e -> pp_bin_op "and" e
| Not e -> pp_un_op "not" e
| True _ -> string "True"
| False _ -> string "False"
and pp_bin_op op {value; _} =
let {arg1; arg2; _} = value
and length = String.length op + 1 in
pp_expr arg1 ^/^ string (op ^ " ") ^^ nest length (pp_expr arg2)
and pp_un_op op {value; _} =
string (op ^ " ") ^^ pp_expr value.arg
and pp_comp_expr = function
Lt e -> pp_bin_op "<" e
| Leq e -> pp_bin_op "<=" e
| Gt e -> pp_bin_op ">" e
| Geq e -> pp_bin_op ">=" e
| Equal e -> pp_bin_op "=" e
| Neq e -> pp_bin_op "=/=" e
and pp_arith_expr = function
Add e -> pp_bin_op "+" e
| Sub e -> pp_bin_op "-" e
| Mult e -> pp_bin_op "*" e
| Div e -> pp_bin_op "/" e
| Mod e -> pp_bin_op "mod" e
| Neg e -> string "-" ^^ pp_expr e.value.arg
| Int e -> pp_int e
| Nat e -> pp_nat e
| Mutez e -> pp_mutez e
and pp_mutez {value; _} =
Z.to_string (snd value) ^ "mutez" |> string
and pp_string_expr = function
Cat e -> pp_bin_op "^" e
| String e -> pp_string e
| Verbatim e -> pp_verbatim e
and pp_ident {value; _} = string value
and pp_string s = string "\"" ^^ pp_ident s ^^ string "\""
and pp_verbatim s = string "{|" ^^ pp_ident s ^^ string "|}"
and pp_list_expr = function
ECons e -> pp_bin_op "#" e
| EListComp e -> pp_injection pp_expr e
| ENil _ -> string "nil"
and pp_constr_expr = function
SomeApp a -> pp_some_app a
| NoneExpr _ -> string "None"
| ConstrApp a -> pp_constr_app a
and pp_some_app {value; _} =
prefix 4 1 (string "Some") (pp_arguments (snd value))
and pp_constr_app {value; _} =
let constr, args = value in
let constr = string constr.value in
match args with
None -> constr
| Some tuple -> prefix 2 1 constr (pp_tuple_expr tuple)
and pp_field_assign {value; _} =
let {field_name; field_expr; _} = value in
prefix 2 1 (pp_ident field_name ^^ string " =") (pp_expr field_expr)
and pp_record ne_inj = group (pp_ne_injection pp_field_assign ne_inj)
and pp_projection {value; _} =
let {struct_name; field_path; _} = value in
let fields = Utils.nsepseq_to_list field_path
and sep = string "." ^^ break 0 in
let fields = separate_map sep pp_selection fields in
group (pp_ident struct_name ^^ string "." ^^ break 0 ^^ fields)
and pp_update {value; _} =
let {record; updates; _} = value in
let updates = group (pp_ne_injection pp_field_path_assign updates)
and record = pp_path record in
record ^^ string " with" ^^ nest 2 (break 1 ^^ updates)
and pp_field_path_assign {value; _} =
let {field_path; field_expr; _} = value in
let path = pp_path field_path in
prefix 2 1 (path ^^ string " =") (pp_expr field_expr)
and pp_selection = function
FieldName v -> string v.value
| Component cmp -> cmp.value |> snd |> Z.to_string |> string
and pp_tuple_expr {value; _} =
let head, tail = value.inside in
let rec app = function
[] -> empty
| [e] -> group (break 1 ^^ pp_expr e)
| e::items ->
group (break 1 ^^ pp_expr e ^^ string ",") ^^ app items in
let components =
if tail = []
then pp_expr head
else pp_expr head ^^ string "," ^^ app (List.map snd tail)
in string "(" ^^ nest 1 (components ^^ string ")")
and pp_fun_call {value; _} =
let lambda, arguments = value in
let arguments = pp_tuple_expr arguments in
group (pp_expr lambda ^^ nest 2 (break 1 ^^ arguments))
and pp_arguments v = pp_tuple_expr v
(* Injections *)
and pp_injection :
'a.('a -> document) -> 'a injection reg -> document =
fun printer {value; _} ->
let {kind; elements; _} = value in
let sep = string ";" ^^ break 1 in
let elements = Utils.sepseq_to_list elements in
let elements = separate_map sep printer elements in
let kwd = pp_injection_kwd kind in
group (string (kwd ^ " [")
^^ nest 2 (break 0 ^^ elements) ^^ break 0 ^^ string "]")
and pp_injection_kwd = function
InjSet _ -> "set"
| InjMap _ -> "map"
| InjBigMap _ -> "big_map"
| InjList _ -> "list"
and pp_ne_injection :
'a.('a -> document) -> 'a ne_injection reg -> document =
fun printer {value; _} ->
let {kind; ne_elements; _} = value in
let elements = pp_nsepseq ";" printer ne_elements in
let kwd = pp_ne_injection_kwd kind in
group (string (kwd ^ " [")
^^ group (nest 2 (break 0 ^^ elements ))
^^ break 0 ^^ string "]")
and pp_ne_injection_kwd = function
NEInjAttr _ -> "attributes"
| NEInjSet _ -> "set"
| NEInjMap _ -> "map"
| NEInjRecord _ -> "record"
and pp_nsepseq :
'a.string -> ('a -> document) -> ('a, t) Utils.nsepseq -> document =
fun sep printer elements ->
let elems = Utils.nsepseq_to_list elements
and sep = string sep ^^ break 1
in separate_map sep printer elems
(* Patterns *)
and pp_pattern = function
PConstr p -> pp_constr_pattern p
| PVar v -> pp_ident v
| PWild _ -> string "_"
| PInt i -> pp_int i
| PNat n -> pp_nat n
| PBytes b -> pp_bytes b
| PString s -> pp_string s
| PList l -> pp_list_pattern l
| PTuple t -> pp_tuple_pattern t
and pp_int {value; _} =
string (Z.to_string (snd value))
and pp_nat {value; _} =
string (Z.to_string (snd value) ^ "n")
and pp_bytes {value; _} =
string ("0x" ^ Hex.show (snd value))
and pp_constr_pattern = function
PUnit _ -> string "Unit"
| PFalse _ -> string "False"
| PTrue _ -> string "True"
| PNone _ -> string "None"
| PSomeApp a -> pp_psome a
| PConstrApp a -> pp_pconstr_app a
and pp_psome {value=_, p; _} =
prefix 4 1 (string "Some") (pp_par pp_pattern p)
and pp_pconstr_app {value; _} =
match value with
constr, None -> pp_ident constr
| constr, Some ptuple ->
prefix 4 1 (pp_ident constr) (pp_tuple_pattern ptuple)
and pp_tuple_pattern {value; _} =
let head, tail = value.inside in
let rec app = function
[] -> empty
| [e] -> group (break 1 ^^ pp_pattern e)
| e::items ->
group (break 1 ^^ pp_pattern e ^^ string ",") ^^ app items in
let components =
if tail = []
then pp_pattern head
else pp_pattern head ^^ string "," ^^ app (List.map snd tail)
in string "(" ^^ nest 1 (components ^^ string ")")
and pp_list_pattern = function
PListComp cmp -> pp_list_comp cmp
| PNil _ -> string "nil"
| PParCons p -> pp_ppar_cons p
| PCons p -> nest 4 (pp_nsepseq " #" pp_pattern p.value)
and pp_list_comp e = pp_injection pp_pattern e
and pp_ppar_cons {value; _} =
let patt1, _, patt2 = value.inside in
let comp = prefix 2 1 (pp_pattern patt1 ^^ string " ::") (pp_pattern patt2)
in string "(" ^^ nest 1 (comp ^^ string ")")

45
src/passes/01-parser/pascaligo/Tests/pp.ligo
View File

@ -1,19 +1,23 @@
function incr_map (const l : list (int)) : list (int) is
List.map (function (const i : int) : int is i + 1, l)
type t is timestamp * nat -> map (string, address)
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
type v is record aaaaaa : ttttttt; bbbbbb : record ccccccccc : string end end
function back (var store : store) : list (operation) * store is
begin
var operations : list (operation) := list [];
const a : nat = 0n;
x0 := record foo = "1"; bar = 4n end;
x1 := nil;
x2 := list end;
var operations : list (operation) := list [];
const operations : list (operation) = list [];
const a : nat = 0n;
x0 := record foo = "1"; bar = 4n end;
x1 := nil;
x2 := list end;
x3 := 3#4# list [5; 6];
case foo of
10n -> skip
end;
if s contains x then skip else skip;
if saaa.0.1.2.a.b.b.x contains xxxxxxxxxxxxxxx[123] then skip else skip;
s := set [3_000mutez; -2; 1n];
a := A;
b := B (a);
@ -21,12 +25,12 @@ function back (var store : store) : list (operation) * store is
d := None;
e := Some (a, B (b));
z := z.1.2;
x := map [1 -> "1"; 2 -> "2"];
x := if true then map [1 -> "1"; 2 -> "2"; 3 -> "3"; 4 -> "4"; 5 -> "5555555555555555"] else Unit;
y := a.b.c[3];
a := "hello " ^ "world" ^ "!";
r := record a = 0 end;
r := r with record a = 42 end;
patch store.backers with set [(1); f(2*3)];
r := record aaaaaaaaaaaa = 100000000; bbbbbbb = ffffff (2, aa, x, y) + 1 end;
r := r with record aaaaaaaaaaa = 444442; bbbbbbbbb = 43 + f (z) / 234 end;
patch store.backers.8.aa.33333.5 with set [(1); f(2*3); 123124234/2345];
remove (1,2,3) from set foo.bar;
remove 3 from map foo.bar;
patch store.backers with map [sender -> amount];
@ -39,7 +43,7 @@ function back (var store : store) : list (operation) * store is
begin
acc := 2 - (if toggle then f(x) else Unit);
end;
for i := 1n to 10n
for i := 1n to 10n step 2n
begin
acc := acc + i;
end;
@ -52,27 +56,32 @@ function back (var store : store) : list (operation) * store is
| B (x, C (y,z)) -> skip
| False#True#Unit#0xAA#"hi"#4#nil -> skip
]
end with (operations, store)
end with (operations, store, (more_stuff, and_here_too))
function claim (var store : store) : list (operation) * store is
function claim (var store : store; const bar : t; const baz : u; var z : operations * store * (more_stuff * and_here_too)) : list (operation) * store * timestamp * nat -> map (string, address) is
begin
var operations : list (operation) := nil;
const operations : list (operation * map (address, map (longname, domain))) = nilllllllllll;
var operations : list (operation * map (address, map (longname, domain))) := nilllllllllll;
attributes ["foo"; "inline"];
if now <= store.deadline then
failwith ("Too soon.")
else
case store.backers[sender] of
None ->
failwith ("Not a backer.")
| Some (0) -> skip
| Some (quantity) ->
if balance >= store.goal or store.funded then
failwith ("Goal reached: no refund.")
else
begin
operations.0.foo := list [transaction (unit, sender, quantity)];
remove sender from map store.backers
operations.0.foo := list [transaction (unit, sender, quantity); transaction (foo, bar, bazzzzzzzzzzzzzzz)];
remove sender.0099999.fffff [fiar (abaxxasfdf)] from map store.backers.foooooo.barrrrr.01.bazzzzzzz
end
end
end with (operations, store)
end with long_function_name (operations, store, (more_stuff, (and_here_too, well_in_here_too), hello))
attributes ["inline"; "foo"]
function withdraw (var store : store) : list (operation) * store is
begin

4
src/passes/01-parser/pascaligo/dune
View File

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

1058
src/passes/01-parser/pascaligo/error.messages.checked-in
View File

File diff suppressed because it is too large Load Diff

21
src/passes/01-parser/reasonligo.ml
View File

@ -8,6 +8,7 @@ module Region = Simple_utils.Region
module ParErr = Parser_reasonligo.ParErr
module SyntaxError = Parser_reasonligo.SyntaxError
module SSet = Set.Make (String)
module Pretty = Parser_reasonligo.Pretty
(* Mock IOs TODO: Fill them with CLI options *)
@ -22,7 +23,8 @@ module SubIO =
ext : string; (* ".religo" *)
mode : [`Byte | `Point];
cmd : EvalOpt.command;
mono : bool
mono : bool;
pretty : bool
>
let options : options =
@ -37,6 +39,7 @@ module SubIO =
method mode = `Point
method cmd = EvalOpt.Quiet
method mono = false
method pretty = false
end
let make =
@ -49,6 +52,7 @@ module SubIO =
~mode:options#mode
~cmd:options#cmd
~mono:options#mono
~pretty:options#pretty
end
module Parser =
@ -178,3 +182,18 @@ let parse_expression source = apply (fun () -> Unit.expr_in_string source)
(* Preprocessing a contract in a file *)
let preprocess source = apply (fun () -> Unit.preprocess source)
(* Pretty-print a file (after parsing it). *)
let pretty_print source =
match parse_file source with
Stdlib.Error _ as e -> e
| Ok ast ->
let doc = Pretty.print (fst ast) in
let buffer = Buffer.create 131 in
let width =
match Terminal_size.get_columns () with
None -> 60
| Some c -> c in
let () = PPrint.ToBuffer.pretty 1.0 width buffer doc
in Trace.ok buffer

3
src/passes/01-parser/reasonligo.mli
View File

@ -19,3 +19,6 @@ val parse_expression : string -> AST.expr Trace.result
(** Preprocess a given ReasonLIGO file and preprocess it. *)
val preprocess : string -> Buffer.t Trace.result
(** Pretty-print a given CameLIGO file (after parsing it). *)
val pretty_print : string -> Buffer.t Trace.result

2
src/passes/01-parser/reasonligo/.links
View File

@ -27,5 +27,3 @@ Stubs/Parser_cameligo.ml
../cameligo/ParserLog.ml
../cameligo/Scoping.mli
../cameligo/Scoping.ml
$HOME/git/ligo/_build/default/src/passes/1-parser/reasonligo/ParErr.ml

155
src/passes/01-parser/reasonligo/Parser.mly
View File

@ -125,7 +125,7 @@ nsepseq(item,sep):
(* Non-empty comma-separated values (at least two values) *)
tuple(item):
item "," nsepseq(item,",") { let h,t = $3 in $1,($2,h)::t }
item "," nsepseq(item,",") { let h,t = $3 in $1, ($2,h)::t }
(* Possibly empty semicolon-separated values between brackets *)
@ -279,15 +279,12 @@ let_binding:
| par(closed_irrefutable) type_annotation? "=" expr {
wild_error $4;
Scoping.check_pattern $1.value.inside;
{binders = PPar $1, []; lhs_type=$2; eq=$3; let_rhs=$4}
{binders = $1.value.inside, []; lhs_type=$2; eq=$3; let_rhs=$4}
}
| tuple(sub_irrefutable) type_annotation? "=" expr {
wild_error $4;
Utils.nsepseq_iter Scoping.check_pattern $1;
let hd, tl = $1 in
let start = pattern_to_region hd in
let stop = last fst tl in
let region = cover start stop in
let region = nsepseq_to_region pattern_to_region $1 in
let binders = PTuple {value=$1; region}, [] in
{binders; lhs_type=$2; eq=$3; let_rhs=$4} }
@ -433,7 +430,18 @@ type_expr_simple:
TProd {region = cover $1 $3; value=$2}
}
| "(" type_expr_simple "=>" type_expr_simple ")" {
TFun {region = cover $1 $5; value=$2,$3,$4} }
TPar {
value = {
lpar = $1;
rpar = $5;
inside = TFun {
region = cover (type_expr_to_region $2) (type_expr_to_region $4);
value=$2,$3,$4
}
};
region = cover $1 $5;
}
}
type_annotation_simple:
":" type_expr_simple { $1,$2 }
@ -456,8 +464,15 @@ fun_expr(right_expr):
)
| EAnnot {region; value = {inside = EVar v, colon, typ; _}} ->
Scoping.check_reserved_name v;
let value = {pattern = PVar v; colon; type_expr = typ}
in PTyped {region; value}
let value = {pattern = PVar v; colon; type_expr = typ} in
PPar {
value = {
lpar = Region.ghost;
rpar = Region.ghost;
inside = PTyped {region; value}
};
region
}
| EPar p ->
let value =
{p.value with inside = arg_to_pattern p.value.inside}
@ -497,7 +512,13 @@ fun_expr(right_expr):
(arg_to_pattern fun_arg, [])
| EPar {value = {inside = EFun {
value = {
binders = PTyped { value = { pattern; colon; type_expr }; region = fun_region }, [];
binders = PPar {
value = {
inside = PTyped { value = { pattern; colon; type_expr }; region = fun_region };
_
};
_
}, [];
arrow;
body;
_
@ -531,7 +552,7 @@ fun_expr(right_expr):
};
region;
}, []
| EPar {value = {inside = fun_arg; _ }; _} ->
| EPar {value = {inside = fun_arg; _ }; _} ->
arg_to_pattern fun_arg, []
| EAnnot _ as e ->
arg_to_pattern e, []
@ -656,7 +677,7 @@ disj_expr_level:
disj_expr
| conj_expr_level { $1 }
| par(tuple(disj_expr_level)) type_annotation_simple? {
let region = $1.region in
let region = nsepseq_to_region expr_to_region $1.value.inside in
let tuple = ETuple {value=$1.value.inside; region} in
let region =
match $2 with
@ -891,9 +912,9 @@ update_record:
lbrace = $1;
record = $3;
kwd_with = $4;
updates = {value = {compound = Braces($1,$6);
ne_elements;
terminator};
updates = {value = {compound = Braces (ghost, ghost);
ne_elements;
terminator};
region = cover $4 $6};
rbrace = $6}
in {region; value} }
@ -902,48 +923,47 @@ expr_with_let_expr:
expr
| let_expr(expr_with_let_expr) { $1 }
exprs:
expr_with_let_expr ";"? {
(($1, []), $2)
exprs:
expr_with_let_expr ";"? {
(($1, []), $2)
}
| expr_with_let_expr ";" exprs {
let rec fix_let_in a b c =
match a with
match a with
| ELetIn {value = {body; _} as v; _} -> (
let end_ = (nsepseq_to_region expr_to_region (fst c)) in
let sequence_region =
let sequence_region =
cover (expr_to_region body) end_
in
let val_ =
match body with
let val_ =
match body with
| ELetIn _ -> fst (fix_let_in body b c)
| e -> Utils.nsepseq_cons e b (fst c)
in
let sequence = ESeq {
value = {
compound = BeginEnd(Region.ghost, Region.ghost);
elements = Some val_;
terminator = (snd c)
};
compound = BeginEnd (ghost, ghost);
elements = Some val_;
terminator = snd c};
region = sequence_region
}
in
let region =
in
let region =
cover (expr_to_region a) end_
in
let let_in =
ELetIn {
let let_in =
ELetIn {
value = {
v with
body = sequence
};
region
};
region
}
in
((let_in, []), snd c)
((let_in, []), snd c)
)
| e -> Utils.nsepseq_cons e b (fst c), None
in
in
fix_let_in $1 $2 $3
}
@ -952,25 +972,24 @@ more_field_assignments:
let elts, _region = $2
in $1, elts }
sequence:
sequence:
"{" exprs "}" {
let elts, _region = $2 in
let elts, _region = $2 in
let compound = Braces ($1, $3) in
let value = {compound;
elements = Some elts;
terminator = None} in
let region = cover $1 $3 in
{region; value}
}
let value = {compound;
elements = Some elts;
terminator = None} in
let region = cover $1 $3
in {region; value} }
record:
record:
"{" field_assignment more_field_assignments? "}" {
let compound = Braces ($1,$4) in
let region = cover $1 $4 in
match $3 with
| Some (comma, elts) ->
let ne_elements = Utils.nsepseq_cons $2 comma elts in
let ne_elements = Utils.nsepseq_cons $2 comma elts in
{ value = {compound; ne_elements; terminator = None}; region }
| None ->
let ne_elements = ($2,[]) in
@ -986,55 +1005,29 @@ record:
let ne_elements = Utils.nsepseq_cons field_name comma elts in
let compound = Braces ($1,$4) in
let region = cover $1 $4 in
{ value = {compound; ne_elements; terminator = None}; region }
}
{value = {compound; ne_elements; terminator = None}; region} }
field_assignment_punning:
(* This can only happen with multiple fields -
one item punning does NOT work in ReasonML *)
field_name {
let value = {
field_name = $1;
assignment = ghost;
field_expr = EVar $1 }
let value = {field_name = $1;
assignment = ghost;
field_expr = EVar $1}
in {$1 with value}
}
| field_assignment { $1 }
field_assignment:
field_name ":" expr {
let start = $1.region in
let stop = expr_to_region $3 in
let region = cover start stop in
let value = {
field_name = $1;
assignment = $2;
field_expr = $3}
let region = cover $1.region (expr_to_region $3)
and value = {field_name = $1;
assignment = $2;
field_expr = $3}
in {region; value} }
real_selection:
field_name { FieldName $1 }
| "<int>" { Component $1 }
field_path_assignment:
real_selection {
let region = selection_to_region $1
and value = {
field_path = ($1,[]);
assignment = ghost;
field_expr = match $1 with
FieldName var -> EVar var
| Component {value;region} ->
let value = Z.to_string (snd value) in
EVar {value;region} }
in {region; value}
}
| nsepseq(real_selection,".") ":" expr {
let start = nsepseq_to_region selection_to_region $1
and stop = expr_to_region $3 in
let region = cover start stop
and value = {
field_path = $1;
assignment = $2;
field_expr = $3}
path ":" expr {
let region = cover (path_to_region $1) (expr_to_region $3)
and value = {field_path=$1; assignment=$2; field_expr=$3}
in {region; value} }

20
src/passes/01-parser/reasonligo/ParserMain.ml
View File

@ -22,7 +22,8 @@ module SubIO =
ext : string;
mode : [`Byte | `Point];
cmd : EvalOpt.command;
mono : bool
mono : bool;
pretty : bool
>
let options : options =
@ -36,6 +37,7 @@ module SubIO =
method mode = IO.options#mode
method cmd = IO.options#cmd
method mono = IO.options#mono
method pretty = IO.options#pretty
end
let make =
@ -48,6 +50,7 @@ module SubIO =
~mode:options#mode
~cmd:options#cmd
~mono:options#mono
~pretty:options#pretty
end
module Parser =
@ -67,12 +70,23 @@ module ParserLog =
module Lexer = Lexer.Make (LexToken)
module Unit =
ParserUnit.Make (Lexer)(AST)(Parser)(ParErr)(ParserLog)(SubIO)
ParserUnit.Make (Lexer)(AST)(Parser)(Parser_msg)(ParserLog)(SubIO)
(* Main *)
let wrap = function
Stdlib.Ok _ -> flush_all ()
Stdlib.Ok ast ->
if IO.options#pretty then
begin
let doc = Pretty.print ast in
let width =
match Terminal_size.get_columns () with
None -> 60
| Some c -> c in
PPrint.ToChannel.pretty 1.0 width stdout doc;
print_newline ()
end;
flush_all ()
| Error msg ->
(flush_all (); Printf.eprintf "\027[31m%s\027[0m%!" msg.Region.value)

471
src/passes/01-parser/reasonligo/Pretty.ml Normal file
View File

@ -0,0 +1,471 @@
[@@@warning "-42"]
open AST
module Region = Simple_utils.Region
open! Region
open! PPrint
let rec print ast =
let app decl = group (pp_declaration decl) in
separate_map (hardline ^^ hardline) app (Utils.nseq_to_list ast.decl)
and pp_declaration = function
Let decl -> pp_let_decl decl
| TypeDecl decl -> pp_type_decl decl
and pp_let_decl = function
| {value = (_,rec_opt, binding, attr); _} ->
let let_str =
match rec_opt with
None -> "let "
| Some _ -> "let rec " in
let bindings = pp_let_binding let_str binding
and attr = pp_attributes attr
in group (attr ^^ bindings ^^ string ";")
and pp_attributes = function
[] -> empty
| attr ->
let make s = string "[@" ^^ string s.value ^^ string "]" in
group (break 0 ^^ separate_map (break 0) make attr) ^^ hardline
and pp_ident {value; _} = string value
and pp_string s = string "\"" ^^ pp_ident s ^^ string "\""
and pp_verbatim s = string "{|" ^^ pp_ident s ^^ string "|}"
and pp_let_binding let_ (binding : let_binding) =
let {binders; lhs_type; let_rhs; _} = binding in
let patterns = Utils.nseq_to_list binders in
let patterns = group (separate_map (break 0) pp_pattern patterns) in
let lhs =
string let_ ^^
match lhs_type with
None -> patterns ^^ string " = "
| Some (_,e) ->
patterns ^^ group (break 0 ^^ string ": " ^^ pp_type_expr e ^^ string " = ")
in
let rhs = pp_expr let_rhs in
match let_rhs with
| EFun _
| ESeq _
| ERecord _ -> lhs ^^ rhs
| _ -> prefix 2 0 lhs rhs
and pp_pattern = function
PConstr p -> pp_pconstr p
| PUnit _ -> string "()"
| PFalse _ -> string "false"
| PTrue _ -> string "true"
| PVar v -> pp_ident v
| PInt i -> pp_int i
| PNat n -> pp_nat n
| PBytes b -> pp_bytes b
| PString s -> pp_string s
| PVerbatim s -> pp_verbatim s
| PWild _ -> string "_"
| PList l -> pp_plist l
| PTuple t -> pp_ptuple t
| PPar p -> pp_ppar p
| PRecord r -> pp_precord r
| PTyped t -> pp_ptyped t
and pp_pconstr = function
PNone _ -> string "None"
| PSomeApp p -> pp_patt_some p
| PConstrApp a -> pp_patt_c_app a
and pp_patt_c_app {value; _} =
match value with
constr, None -> pp_ident constr
| constr, Some (PVar _ as pat) ->
prefix 2 1 (pp_ident constr) (pp_pattern pat)
| constr, Some (_ as pat)->
prefix 2 0 (pp_ident constr) (pp_pattern pat)
and pp_patt_some {value; _} =
prefix 2 0 (string "Some") (pp_pattern (snd value))
and pp_int {value; _} =
string (Z.to_string (snd value))
and pp_nat {value; _} =
string (Z.to_string (snd value) ^ "n")
and pp_bytes {value; _} =
string ("0x" ^ Hex.show (snd value))
and pp_ppar {value; _} =
if value.lpar = Region.ghost then
nest 1 (pp_pattern value.inside)
else
string "(" ^^ nest 1 (pp_pattern value.inside) ^^ string ")"
and pp_plist = function
PListComp cmp -> pp_list_comp cmp
| PCons cons -> pp_cons cons
and pp_list_comp e = group (pp_injection pp_pattern e)
and pp_cons {value; _} =
let patt1, _, patt2 = value in
string "[" ^^ (pp_pattern patt1 ^^ string ", ") ^^ group ( break 0 ^^ string "..." ^^ pp_pattern patt2) ^^ string "]"
and pp_ptuple {value; _} =
let head, tail = value in
let rec app = function
[] -> empty
| [p] -> group (break 1 ^^ pp_pattern p)
| p::items ->
group (break 1 ^^ pp_pattern p ^^ string ",") ^^ app items
in if tail = []
then string "(" ^^ nest 1 (pp_pattern head) ^^ string ")"
else string "(" ^^ nest 1 (pp_pattern head ^^ string "," ^^ app (List.map snd tail)) ^^ string ")"
and pp_precord fields = pp_ne_injection pp_field_pattern fields
and pp_field_pattern {value; _} =
let {field_name; pattern; _} = value in
prefix 2 1 (pp_ident field_name ^^ string " =") (pp_pattern pattern)
and pp_ptyped {value; _} =
let {pattern; type_expr; _} = value in
group (pp_pattern pattern ^^ string ": " ^^ pp_type_expr type_expr)
and pp_type_decl decl =
let {name; type_expr; _} = decl.value in
string "type " ^^ string name.value ^^ string " = "
^^ group (pp_type_expr type_expr) ^^ string ";"
and pp_expr = function
ECase e -> pp_case_expr e
| ECond e -> group (pp_cond_expr e)
| EAnnot e -> pp_annot_expr e
| ELogic e -> pp_logic_expr e
| EArith e -> group (pp_arith_expr e)
| EString e -> pp_string_expr e
| EList e -> group (pp_list_expr e)
| EConstr e -> pp_constr_expr e
| ERecord e -> pp_record_expr e
| EProj e -> pp_projection e
| EUpdate e -> pp_update e
| EVar v -> pp_ident v
| ECall e -> pp_call_expr e
| EBytes e -> pp_bytes e
| EUnit _ -> string "()"
| ETuple e -> pp_tuple_expr e
| EPar e -> pp_par_expr e
| ELetIn e -> pp_let_in e
| EFun e -> pp_fun e
| ESeq e -> pp_seq e
and pp_case_expr {value; _} =
let {expr; cases; _} = value in
group (string "switch" ^^ string "(" ^^ nest 1 (pp_expr expr)
^^ string ") " ^^ string "{"
^^ pp_cases cases ^^ hardline ^^ string "}")
and pp_cases {value; _} =
let head, tail = value in
let rest = List.map snd tail in
let app clause = break 1 ^^ string "| " ^^ pp_clause clause
in concat_map app (head :: rest)
and pp_clause {value; _} =
let {pattern; rhs; _} = value in
prefix 4 1 (pp_pattern pattern ^^ string " =>") (pp_expr rhs)
and pp_cond_expr {value; _} =
let {test; ifso; kwd_else; ifnot; _} = value in
let if_then =
string "if" ^^ string " (" ^^ pp_expr test ^^ string ")" ^^ string " {" ^^ break 0
^^ group (nest 2 (break 2 ^^ pp_expr ifso)) ^^ hardline ^^ string "}" in
if kwd_else#is_ghost then
if_then
else
if_then
^^ string " else" ^^ string " {" ^^ break 0 ^^ group (nest 2 (break 2 ^^ pp_expr ifnot)) ^^ hardline ^^ string "}"
and pp_annot_expr {value; _} =
let expr, _, type_expr = value.inside in
group (nest 1 (pp_expr expr ^/^ string ": "
^^ pp_type_expr type_expr))
and pp_logic_expr = function
BoolExpr e -> pp_bool_expr e
| CompExpr e -> pp_comp_expr e
and pp_bool_expr = function
Or e -> pp_bin_op "||" e
| And e -> pp_bin_op "&&" e
| Not e -> pp_un_op "!" e
| True _ -> string "true"
| False _ -> string "false"
and pp_bin_op op {value; _} =
let {arg1; arg2; _} = value
and length = String.length op + 1 in
pp_expr arg1 ^^ string " " ^^ string (op ^ " ") ^^ nest length (pp_expr arg2)
and pp_un_op op {value; _} =
string (op ^ " ") ^^ pp_expr value.arg
and pp_comp_expr = function
Lt e -> pp_bin_op "<" e
| Leq e -> pp_bin_op "<=" e
| Gt e -> pp_bin_op ">" e
| Geq e -> pp_bin_op ">=" e
| Equal e -> pp_bin_op "==" e
| Neq e -> pp_bin_op "!=" e
and pp_arith_expr = function
Add e -> pp_bin_op "+" e
| Sub e -> pp_bin_op "-" e
| Mult e -> pp_bin_op "*" e
| Div e -> pp_bin_op "/" e
| Mod e -> pp_bin_op "mod" e
| Neg e -> string "-" ^^ pp_expr e.value.arg
| Int e -> pp_int e
| Nat e -> pp_nat e
| Mutez e -> pp_mutez e
and pp_mutez {value; _} =
Z.to_string (snd value) ^ "mutez" |> string
and pp_string_expr = function
Cat e -> pp_bin_op "++" e
| String e -> pp_string e
| Verbatim e -> pp_verbatim e
and pp_list_expr = function
| ECons {value = {arg1; arg2; _}; _ } ->
string "[" ^^ pp_expr arg1 ^^ string "," ^^ break 1 ^^ string "..." ^^ pp_expr arg2 ^^ string "]"
| EListComp e -> group (pp_injection pp_expr e)
and pp_injection :
'a.('a -> document) -> 'a injection reg -> document =
fun printer {value; _} ->
let {compound; elements; _} = value in
let sep = (string ",") ^^ break 1 in
let elements = Utils.sepseq_to_list elements in
let elements = separate_map sep printer elements in
match pp_compound compound with
None -> elements
| Some (opening, closing) ->
string opening ^^ nest 1 elements ^^ string closing
and pp_compound = function
BeginEnd (start, _) ->
if start#is_ghost then None else Some ("begin","end")
| Braces (start, _) ->
if start#is_ghost then None else Some ("{","}")
| Brackets (start, _) ->
if start#is_ghost then None else Some ("[","]")
and pp_constr_expr = function
ENone _ -> string "None"
| ESomeApp a -> pp_some a
| EConstrApp a -> pp_constr_app a
and pp_some {value=_, e; _} =
prefix 4 1 (string "Some") (pp_expr e)
and pp_constr_app {value; _} =
let constr, arg = value in
let constr = string constr.value in
match arg with
None -> constr
| Some e -> prefix 2 1 constr (pp_expr e)
and pp_record_expr ne_inj = pp_ne_injection pp_field_assign ne_inj
and pp_field_assign {value; _} =
let {field_name; field_expr; _} = value in
prefix 2 1 (pp_ident field_name ^^ string ":") (pp_expr field_expr)
and pp_ne_injection :
'a.('a -> document) -> 'a ne_injection reg -> document =
fun printer {value; _} ->
let {compound; ne_elements; _} = value in
let elements = pp_nsepseq "," printer ne_elements in
match pp_compound compound with
None -> elements
| Some (opening, closing) ->
string opening ^^ nest 2 (break 0 ^^ elements) ^^ break 1 ^^ string closing
and pp_nsepseq :
'a.string -> ('a -> document) -> ('a, t) Utils.nsepseq -> document =
fun sep printer elements ->
let elems = Utils.nsepseq_to_list elements
and sep = string sep ^^ break 1
in separate_map sep printer elems
and pp_projection {value; _} =
let {struct_name; field_path; _} = value in
let subpath = Utils.nsepseq_to_list field_path in
let subpath = concat_map pp_selection subpath in
group (pp_ident struct_name ^^ subpath)
and pp_selection = function
FieldName v -> string "." ^^ break 0 ^^ string v.value
| Component cmp ->
string "[" ^^ (cmp.value |> snd |> Z.to_string |> string) ^^ string "]"
and pp_update {value; _} =
let {record; updates; _} = value in
let updates = group (pp_ne_injection pp_field_path_assign updates)
and record = pp_path record in
string "{..." ^^ record ^^ string ","
^^ nest 2 (break 1 ^^ updates ^^ string "}")
and pp_field_path_assign {value; _} =
let {field_path; field_expr; _} = value in
let path = pp_path field_path in
prefix 2 1 (path ^^ string ":") (pp_expr field_expr)
and pp_path = function
Name v -> pp_ident v
| Path p -> pp_projection p
and pp_call_expr {value; _} =
let lambda, arguments = value in
let arguments = Utils.nseq_to_list arguments in
let arguments = string "(" ^^ group (separate_map (string "," ^^ break 0 ^^ string " ") pp_expr arguments) ^^ string ")" in
group (break 0 ^^ pp_expr lambda ^^ nest 2 arguments)
and pp_tuple_expr {value; _} =
let head, tail = value in
let rec app = function
[] -> empty
| [e] -> group (break 1 ^^ pp_expr e)
| e::items ->
group (break 1 ^^ pp_expr e ^^ string ",") ^^ app items
in if tail = []
then string "(" ^^ nest 1 (pp_expr head) ^^ string ")"
else string "(" ^^ nest 1 (pp_expr head ^^ string "," ^^ app (List.map snd tail)) ^^ string ")"
and pp_par_expr {value; _} =
string "(" ^^ nest 1 (pp_expr value.inside ^^ string ")")
and pp_let_in {value; _} =
let {binding; kwd_rec; body; attributes; _} = value in
let let_str =
match kwd_rec with
None -> "let "
| Some _ -> "let rec " in
let bindings = pp_let_binding let_str binding
and attr = pp_attributes attributes
in attr ^^ bindings
^^ string ";" ^^ hardline ^^ pp_expr body
and pp_fun {value; _} =
let {binders; lhs_type; body; _} = value in
let patterns = Utils.nseq_to_list binders in
let binders = group (separate_map (string "," ^^ break 0 ^^ string " ") pp_pattern patterns)
and annot =
match lhs_type with
None -> empty
| Some (_,e) ->
group (break 0 ^^ string ": " ^^ nest 2 (pp_type_expr e))
in
match body with
| ESeq _ -> string "(" ^^ nest 1 binders ^^ string ")" ^^ annot ^^ string " => " ^^ pp_expr body
| _ -> (prefix 2 0 (string "(" ^^ nest 1 binders ^^ string ")" ^^ annot
^^ string " => ") (pp_expr body))
and pp_seq {value; _} =
let {compound; elements; _} = value in
let sep = string ";" ^^ hardline in
let elements = Utils.sepseq_to_list elements in
let elements = separate_map sep pp_expr elements in
match pp_compound compound with
None -> elements
| Some (opening, closing) ->
string opening
^^ nest 2 (hardline ^^ elements) ^^ hardline
^^ string closing
and pp_type_expr = function
TProd t -> pp_cartesian t
| TSum t -> break 0 ^^ pp_variants t
| TRecord t -> pp_fields t
| TApp t -> pp_type_app t
| TFun t -> pp_fun_type t
| TPar t -> pp_type_par t
| TVar t -> pp_ident t
| TString s -> pp_string s
and pp_cartesian {value; _} =
let head, tail = value in
let rec app = function
[] -> empty
| [e] -> group (break 1 ^^ pp_type_expr e)
| e::items ->
group (break 1 ^^ pp_type_expr e ^^ string ",") ^^ app items
in
string "(" ^^ nest 1 (pp_type_expr head ^^ (if tail <> [] then string "," else empty) ^^ app (List.map snd tail)) ^^ string ")"
and pp_variants {value; _} =
let head, tail = value in
let head = pp_variant head in
let head = if tail = [] then head
else ifflat head (string " " ^^ head) in
let rest = List.map snd tail in
let app variant = break 1 ^^ string "| " ^^ pp_variant variant
in head ^^ concat_map app rest
and pp_variant {value; _} =
let {constr; arg} = value in
match arg with
None -> pp_ident constr
| Some (_, e) ->
prefix 2 0 (pp_ident constr) (string "(" ^^ pp_type_expr e ^^ string ")")
and pp_fields fields = group (pp_ne_injection pp_field_decl fields)
and pp_field_decl {value; _} =
let {field_name; field_type; _} = value in
let name = pp_ident field_name in
match field_type with
| TVar v when v = field_name ->
name
| _ ->
let t_expr = pp_type_expr field_type
in prefix 2 1 (name ^^ string ":") t_expr
and pp_type_app {value; _} =
let ctor, tuple = value in
prefix 2 0 (pp_type_constr ctor) (string "(" ^^ nest 1 (pp_type_tuple tuple) ^^ string ")")
and pp_type_tuple {value; _} =
let head, tail = value.inside in
let rec app = function
[] -> empty
| [e] -> group (break 1 ^^ pp_type_expr e)
| e::items ->
group (break 1 ^^ pp_type_expr e ^^ string ",") ^^ app items in
if tail = []
then pp_type_expr head
else
let components =
pp_type_expr head ^^ string "," ^^ app (List.map snd tail)
in components
and pp_type_constr ctor = string ctor.value
and pp_fun_args {value; _} =
let lhs, _, rhs = value in
match rhs with
| TFun tf -> group (pp_type_expr lhs ^^ string ", " ^^ pp_fun_args tf)
| _ -> group (pp_type_expr lhs ^^ string ")" ^^ string " =>" ^/^ pp_type_expr rhs)
and pp_fun_type {value; _} =
let lhs, _, rhs = value in
match lhs, rhs with
| _, TFun tf -> string "(" ^^ pp_type_expr lhs ^^ string ", " ^^ pp_fun_args tf
| TVar _ , _ -> group (pp_type_expr lhs ^^ string " =>" ^/^ pp_type_expr rhs)
| _ -> group (string "(" ^^ nest 1 (pp_type_expr lhs) ^^ string ")" ^^ string " =>" ^/^ pp_type_expr rhs)
and pp_type_par {value; _} =
string "(" ^^ nest 1 (pp_type_expr value.inside ^^ string ")")

2
src/passes/01-parser/reasonligo/dune
View File

@ -15,7 +15,7 @@
(name parser_reasonligo)
(public_name ligo.parser.reasonligo)
(modules
SyntaxError reasonligo LexToken ParErr Parser)
SyntaxError reasonligo LexToken ParErr Parser Pretty)
(libraries
menhirLib
parser_shared

1423
src/passes/01-parser/reasonligo/error.messages.checked-in
View File

File diff suppressed because it is too large Load Diff

14
src/passes/01-parser/shared/EvalOpt.ml
View File

@ -29,11 +29,12 @@ type options = <
mode : [`Byte | `Point];
cmd : command;
mono : bool;
expr : bool
expr : bool;
pretty : bool
>
let make ~input ~libs ~verbose ~offsets ?block
?line ~ext ~mode ~cmd ~mono ~expr : options =
?line ~ext ~mode ~cmd ~mono ~expr ~pretty : options =
object
method input = input
method libs = libs
@ -46,6 +47,7 @@ let make ~input ~libs ~verbose ~offsets ?block
method cmd = cmd
method mono = mono
method expr = expr
method pretty = pretty
end
(* Auxiliary functions *)
@ -77,6 +79,7 @@ let help extension () =
print " --bytes Bytes for source locations";
print " --mono Use Menhir monolithic API";
print " --expr Parse an expression";
print " --pretty Pretty-print the input";
print " --verbose=<stages> cli, preproc, ast-tokens, ast (colon-separated)";
print " --version Commit hash on stdout";
print " -h, --help This help";
@ -100,6 +103,7 @@ and libs = ref []
and verb_str = ref ""
and mono = ref false
and expr = ref false
and pretty = ref false
let split_at_colon = Str.(split (regexp ":"))
@ -121,6 +125,7 @@ let specs extension =
noshort, "bytes", set bytes true, None;
noshort, "mono", set mono true, None;
noshort, "expr", set expr true, None;
noshort, "pretty", set pretty true, None;
noshort, "verbose", None, Some add_verbose;
'h', "help", Some (help extension), None;
noshort, "version", Some version, None
@ -156,6 +161,7 @@ let print_opt () =
printf "bytes = %b\n" !bytes;
printf "mono = %b\n" !mono;
printf "expr = %b\n" !expr;
printf "pretty = %b\n" !pretty;
printf "verbose = %s\n" !verb_str;
printf "input = %s\n" (string_of quote !input);
printf "libs = %s\n" (string_of_path !libs)
@ -185,6 +191,7 @@ let check ?block ?line ~ext =
and mono = !mono
and expr = !expr
and verbose = !verbose
and pretty = !pretty
and libs = !libs in
let () =
@ -199,6 +206,7 @@ let check ?block ?line ~ext =
printf "mode = %s\n" (if mode = `Byte then "`Byte" else "`Point");
printf "mono = %b\n" mono;
printf "expr = %b\n" expr;
printf "pretty = %b\n" pretty;
printf "verbose = %s\n" !verb_str;
printf "input = %s\n" (string_of quote input);
printf "libs = %s\n" (string_of_path libs)
@ -214,7 +222,7 @@ let check ?block ?line ~ext =
| _ -> abort "Choose one of -q, -c, -u, -t."
in make ~input ~libs ~verbose ~offsets ~mode
~cmd ~mono ~expr ?block ?line ~ext
~cmd ~mono ~expr ?block ?line ~ext ~pretty
(* Parsing the command-line options *)

9
src/passes/01-parser/shared/EvalOpt.mli
View File

@ -47,7 +47,10 @@ type command = Quiet | Copy | Units | Tokens
{li If the field [expr] is [true], then the parser for
expressions is used, otherwise a full-fledged contract is
expected.}
} *)
{li If the field [pretty] is [true], then the source is
pretty-printed on the standard out.}
} *)
module SSet : Set.S with type elt = string and type t = Set.Make(String).t
@ -67,7 +70,8 @@ type options = <
mode : [`Byte | `Point];
cmd : command;
mono : bool;
expr : bool
expr : bool;
pretty : bool
>
val make :
@ -82,6 +86,7 @@ val make :
cmd:command ->
mono:bool ->
expr:bool ->
pretty:bool ->
options
(** Parsing the command-line options on stdin. *)

7
src/passes/01-parser/shared/ParserUnit.ml
View File

@ -15,7 +15,8 @@ module type SubIO =
ext : string;
mode : [`Byte | `Point];
cmd : EvalOpt.command;
mono : bool
mono : bool;
pretty : bool
>
val options : options
@ -31,7 +32,7 @@ module type Printer =
val mk_state :
offsets:bool -> mode:[`Point|`Byte] -> buffer:Buffer.t -> state
val pp_ast : state -> ast -> unit
val pp_cst : state -> ast -> unit
val pp_expr : state -> expr -> unit
val print_tokens : state -> ast -> unit
val print_expr : state -> expr -> unit
@ -145,7 +146,7 @@ module Make (Lexer: Lexer.S)
if SSet.mem "ast" SubIO.options#verbose then
begin
Buffer.clear output;
ParserLog.pp_ast state ast;
ParserLog.pp_cst state ast;
Buffer.output_buffer stdout output
end
in flush_all (); close (); Ok ast

5
src/passes/01-parser/shared/ParserUnit.mli
View File

@ -17,7 +17,8 @@ module type SubIO =
ext : string;
mode : [`Byte | `Point];
cmd : EvalOpt.command;
mono : bool
mono : bool;
pretty : bool
>
val options : options
@ -35,7 +36,7 @@ module type Printer =
val mk_state :
offsets:bool -> mode:[`Point|`Byte] -> buffer:Buffer.t -> state
val pp_ast : state -> ast -> unit
val pp_cst : state -> ast -> unit
val pp_expr : state -> expr -> unit
val print_tokens : state -> ast -> unit
val print_expr : state -> expr -> unit

8
src/passes/01-parser/shared/Utils.mli
View File

@ -31,9 +31,9 @@ val sepseq_cons : 'a -> 'sep -> ('a,'sep) sepseq -> ('a,'sep) nsepseq
(* Reversing *)
val nseq_rev: 'a nseq -> 'a nseq
val nsepseq_rev: ('a,'sep) nsepseq -> ('a,'sep) nsepseq
val sepseq_rev: ('a,'sep) sepseq -> ('a,'sep) sepseq
val nseq_rev : 'a nseq -> 'a nseq
val nsepseq_rev : ('a,'sep) nsepseq -> ('a,'sep) nsepseq
val sepseq_rev : ('a,'sep) sepseq -> ('a,'sep) sepseq
(* Rightwards iterators *)
@ -55,7 +55,7 @@ val sepseq_foldr : ('a -> 'b -> 'b) -> ('a,'c) sepseq -> 'b -> 'b
val nseq_map : ('a -> 'b) -> 'a nseq -> 'b nseq
val nsepseq_map : ('a -> 'b) -> ('a,'c) nsepseq -> ('b,'c) nsepseq
val sepseq_map : ('a -> 'b) -> ('a,'c) sepseq -> ('b,'c) sepseq
val sepseq_map : ('a -> 'b) -> ('a,'c) sepseq -> ('b,'c) sepseq
(* Conversions to lists *)

58
src/passes/02-concrete_to_imperative/cameligo.ml
View File

@ -352,38 +352,32 @@ let rec compile_expression :
let compile_selection : Raw.selection -> access = fun s ->
match s with
| FieldName property -> Access_record property.value
| Component index -> (Access_tuple (snd index.value))
in
let compile_path : Raw.path -> string * access list = fun p ->
match p with
| Raw.Name v -> (v.value , [])
| Raw.Path p -> (
let p' = p.value in
let var = p'.struct_name.value in
let path = p'.field_path in
let path' = List.map compile_selection @@ npseq_to_list path in
(var , path')
)
in
let compile_update = fun (u:Raw.update Region.reg) ->
let (u, loc) = r_split u in
let (name, path) = compile_path u.record in
let record = match path with
| [] -> e_variable (Var.of_name name)
| _ -> e_accessor (e_variable (Var.of_name name)) path in
let updates = u.updates.value.ne_elements in
let%bind updates' =
let aux (f:Raw.field_path_assign Raw.reg) =
let (f,_) = r_split f in
let%bind expr = compile_expression f.field_expr in
ok ( List.map compile_selection (npseq_to_list f.field_path), expr)
in
bind_map_list aux @@ npseq_to_list updates
in
let aux ur (path, expr) = ok @@ e_update ~loc ur path expr in
bind_fold_list aux record updates'
in
trace (abstracting_expr t) @@
| Component index -> (Access_tuple (snd index.value)) in
let compile_path : Raw.path -> string * access list = function
Raw.Name v -> v.value, []
| Raw.Path {value; _} ->
let Raw.{struct_name; field_path; _} = value in
let var = struct_name.value in
let path = List.map compile_selection @@ npseq_to_list field_path
in var, path in
let compile_update (u: Raw.update Region.reg) =
let u, loc = r_split u in
let name, path = compile_path u.record in
let var = e_variable (Var.of_name name) in
let record = if path = [] then var else e_accessor var path in
let updates = u.updates.value.ne_elements in
let%bind updates' =
let aux (f: Raw.field_path_assignment Raw.reg) =
let f, _ = r_split f in
let%bind expr = compile_expression f.field_expr
in ok (compile_path f.field_path, expr)
in bind_map_list aux @@ npseq_to_list updates in
let aux ur ((var, path), expr) =
ok @@ e_update ~loc ur (Access_record var :: path) expr
in bind_fold_list aux record updates'
in trace (abstracting_expr t) @@
match t with
Raw.ELetIn e ->
let Raw.{kwd_rec; binding; body; attributes; _} = e.value in

207
src/passes/02-concrete_to_imperative/pascaligo.ml
View File

@ -152,7 +152,7 @@ let return_statement expr = ok @@ fun expr'_opt ->
| Some expr' -> ok @@ e_sequence expr expr'
let get_t_string_singleton_opt = function
| Raw.TStringLiteral s -> Some s.value
| Raw.TString s -> Some s.value
| _ -> None
@ -176,7 +176,7 @@ let rec compile_type_expression (t:Raw.type_expr) : type_expression result =
let (x, loc) = r_split x in
let (name, tuple) = x in
(match name.value with
| "michelson_or" ->
| "michelson_or" ->
let lst = npseq_to_list tuple.value.inside in
(match lst with
| [a ; b ; c ; d ] -> (
@ -252,7 +252,7 @@ let rec compile_type_expression (t:Raw.type_expr) : type_expression result =
@@ npseq_to_list s in
let m = List.fold_left (fun m ((x,i), y) -> CMap.add (Constructor x) {ctor_type=y;ctor_decl_pos=i} m) CMap.empty lst in
ok @@ make_t ~loc @@ T_sum m
| TStringLiteral _s -> simple_fail "we don't support singleton string type"
| TString _s -> simple_fail "we don't support singleton string type"
and compile_list_type_expression (lst:Raw.type_expr list) : type_expression result =
match lst with
@ -282,20 +282,21 @@ let rec compile_expression (t:Raw.expr) : expr result =
let return x = ok x in
match t with
| EAnnot a -> (
let ((expr , type_expr) , loc) = r_split a in
let par, loc = r_split a in
let expr, _, type_expr = par.inside in
let%bind expr' = compile_expression expr in
let%bind type_expr' = compile_type_expression type_expr in
return @@ e_annotation ~loc expr' type_expr'
)
| EVar c -> (
let (c' , loc) = r_split c in
let (c', loc) = r_split c in
match constants c' with
| None -> return @@ e_variable ~loc (Var.of_name c.value)
| Some s -> return @@ e_constant ~loc s []
)
| ECall x -> (
let ((f, args) , loc) = r_split x in
let (args , args_loc) = r_split args in
let ((f, args), loc) = r_split x in
let (args, args_loc) = r_split args in
let args' = npseq_to_list args.inside in
match f with
| EVar name -> (
@ -327,7 +328,8 @@ let rec compile_expression (t:Raw.expr) : expr result =
| ERecord r ->
let%bind fields = bind_list
@@ List.map (fun ((k : _ Raw.reg), v) -> let%bind v = compile_expression v in ok (k.value, v))
@@ List.map (fun (x:Raw.field_assign Raw.reg) -> (x.value.field_name, x.value.field_expr))
@@ List.map (fun (x:Raw.field_assignment Raw.reg) ->
(x.value.field_name, x.value.field_expr))
@@ npseq_to_list r.value.ne_elements in
let aux prev (k, v) = SMap.add k v prev in
return @@ e_record (List.fold_left aux SMap.empty fields)
@ -457,37 +459,28 @@ let rec compile_expression (t:Raw.expr) : expr result =
let (f , loc) = r_split f in
let%bind (_ty_opt, f') = compile_fun_expression ~loc f
in return @@ f'
and compile_update = fun (u:Raw.update Region.reg) ->
let (u, loc) = r_split u in
let (name, path) = compile_path u.record in
let record = match path with
| [] -> e_variable (Var.of_name name)
| _ -> e_accessor (e_variable (Var.of_name name)) path in
let updates = u.updates.value.ne_elements in
and compile_update (u: Raw.update Region.reg) =
let u, loc = r_split u in
let name, path = compile_path u.record in
let var = e_variable (Var.of_name name) in
let record = if path = [] then var else e_accessor var path in
let updates = u.updates.value.ne_elements in
let%bind updates' =
let aux (f:Raw.field_path_assign Raw.reg) =
let (f,_) = r_split f in
let%bind expr = compile_expression f.field_expr in
ok ( List.map compile_selection (npseq_to_list f.field_path), expr)
in
bind_map_list aux @@ npseq_to_list updates
in
let aux ur (path, expr) = ok @@ e_update ~loc ur path expr in
bind_fold_list aux record updates'
let aux (f: Raw.field_path_assignment Raw.reg) =
let f, _ = r_split f in
let%bind expr = compile_expression f.field_expr
in ok (compile_path f.field_path, expr)
in bind_map_list aux @@ npseq_to_list updates in
let aux ur ((var, path), expr) =
ok @@ e_update ~loc ur (Access_record var :: path) expr
in bind_fold_list aux record updates'
and compile_logic_expression (t:Raw.logic_expr) : expression result =
let return x = ok x in
match t with
| BoolExpr (False reg) -> (
let loc = Location.lift reg in
return @@ e_bool ~loc false
)
| BoolExpr (True reg) -> (
let loc = Location.lift reg in
return @@ e_bool ~loc true
)
| BoolExpr (False reg) ->
ok @@ e_bool ~loc:(Location.lift reg) false
| BoolExpr (True reg) ->
ok @@ e_bool ~loc:(Location.lift reg) true
| BoolExpr (Or b) ->
compile_binop "OR" b
| BoolExpr (And b) ->
@ -640,11 +633,11 @@ and compile_fun_decl :
let binder = Var.of_name binder in
let fun_name = Var.of_name fun_name.value in
let fun_type = t_function input_type output_type in
let expression : expression =
let expression : expression =
e_lambda ~loc binder (Some input_type)(Some output_type) result in
let%bind expression = match kwd_recursive with
None -> ok @@ expression |
Some _ -> ok @@ e_recursive ~loc fun_name fun_type
Some _ -> ok @@ e_recursive ~loc fun_name fun_type
@@ {binder;input_type=Some input_type; output_type= Some output_type; result}
in
ok ((fun_name, Some fun_type), expression)
@ -675,11 +668,11 @@ and compile_fun_decl :
bind_fold_right_list aux result body in
let fun_name = Var.of_name fun_name.value in
let fun_type = t_function input_type output_type in
let expression : expression =
let expression : expression =
e_lambda ~loc binder (Some input_type)(Some output_type) result in
let%bind expression = match kwd_recursive with
None -> ok @@ expression |
Some _ -> ok @@ e_recursive ~loc fun_name fun_type
Some _ -> ok @@ e_recursive ~loc fun_name fun_type
@@ {binder;input_type=Some input_type; output_type= Some output_type; result}
in
ok ((fun_name, Some fun_type), expression)
@ -690,7 +683,7 @@ and compile_fun_expression :
loc:_ -> Raw.fun_expr -> (type_expression option * expression) result =
fun ~loc x ->
let open! Raw in
let {kwd_recursive;param;ret_type;return} : fun_expr = x in
let {param; ret_type; return; _} : fun_expr = x in
let statements = [] in
(match param.value.inside with
a, [] -> (
@ -706,10 +699,8 @@ and compile_fun_expression :
bind_fold_right_list aux result body in
let binder = Var.of_name binder in
let fun_type = t_function input_type output_type in
let expression = match kwd_recursive with
| None -> e_lambda ~loc binder (Some input_type)(Some output_type) result
| Some _ -> e_recursive ~loc binder fun_type
@@ {binder;input_type=Some input_type; output_type= Some output_type; result}
let expression =
e_lambda ~loc binder (Some input_type)(Some output_type) result
in
ok (Some fun_type , expression)
)
@ -737,10 +728,8 @@ and compile_fun_expression :
let aux prec cur = cur (Some prec) in
bind_fold_right_list aux result body in
let fun_type = t_function input_type output_type in
let expression = match kwd_recursive with
| None -> e_lambda ~loc binder (Some input_type)(Some output_type) result
| Some _ -> e_recursive ~loc binder fun_type
@@ {binder;input_type=Some input_type; output_type= Some output_type; result}
let expression =
e_lambda ~loc binder (Some input_type)(Some output_type) result
in
ok (Some fun_type , expression)
)
@ -814,7 +803,7 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res
let%bind bound = compile_expression fi.bound in
let%bind step = match fi.step with
| None -> ok @@ e_int_z Z.one
| Some step -> compile_expression step in
| Some (_, step) -> compile_expression step in
let%bind body = compile_block fi.block.value in
let%bind body = body @@ None in
return_statement @@ e_for ~loc binder start bound step body
@ -852,7 +841,7 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res
compile_block value
| ShortBlock {value; _} ->
compile_statements @@ fst value.inside in
let%bind match_true = match_true None in
let%bind match_false = match_false None in
return_statement @@ e_cond ~loc expr match_true match_false
@ -861,25 +850,25 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res
let (a , loc) = r_split a in
let%bind value_expr = compile_expression a.rhs in
match a.lhs with
| Path path -> (
let (name , path') = compile_path path in
| Path path ->
let name , path' = compile_path path in
let name = Var.of_name name in
return_statement @@ e_assign ~loc name path' value_expr
)
| MapPath v -> (
| MapPath v ->
let v' = v.value in
let%bind (varname,map,path) = match v'.path with
| Name name -> ok (name.value , e_variable (Var.of_name name.value), [])
| Name name ->
ok (name.value ,
e_variable (Var.of_name name.value), [])
| Path p ->
let (name,p') = compile_path v'.path in
let%bind accessor = compile_projection p in
ok @@ (name , accessor , p')
in
let%bind key_expr = compile_expression v'.index.value.inside in
let name, p' = compile_path v'.path in
let%bind accessor = compile_projection p in
ok @@ (name, accessor, p') in
let%bind key_expr =
compile_expression v'.index.value.inside in
let expr' = e_map_add key_expr value_expr map in
let varname = Var.of_name varname in
return_statement @@ e_assign ~loc varname path expr'
)
)
| CaseInstr c -> (
let (c , loc) = r_split c in
@ -895,7 +884,7 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res
LongBlock {value; _} ->
compile_block value
| ShortBlock {value; _} ->
compile_statements @@ fst value.inside in
compile_statements @@ fst value.inside in
let%bind case_clause = case_clause None in
ok (x.value.pattern, case_clause) in
bind_list
@ -904,27 +893,28 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res
let%bind m = compile_cases cases in
return_statement @@ e_matching ~loc expr m
)
| RecordPatch r -> (
| RecordPatch r ->
let reg = r.region in
let (r,loc) = r_split r in
let aux (fa :Raw.field_assign Raw.reg) : Raw.field_path_assign Raw.reg=
{value = {field_path = (FieldName fa.value.field_name, []); equal=fa.value.equal; field_expr = fa.value.field_expr};
region = fa.region}
in
let update : Raw.field_path_assign Raw.reg Raw.ne_injection Raw.reg = {
value = Raw.map_ne_injection aux r.record_inj.value;
region=r.record_inj.region
} in
let u : Raw.update = {record=r.path;kwd_with=r.kwd_with; updates=update} in
let r, loc = r_split r in
let aux (fa: Raw.field_assignment Raw.reg) : Raw.field_path_assignment Raw.reg =
{value = {field_path = Name fa.value.field_name;
assignment = fa.value.assignment;
field_expr = fa.value.field_expr};
region = fa.region} in
let update : Raw.field_path_assignment Raw.reg Raw.ne_injection Raw.reg = {
value = Raw.map_ne_injection aux r.record_inj.value;
region = r.record_inj.region} in
let u : Raw.update = {
record = r.path;
kwd_with = r.kwd_with;
updates = update} in
let%bind expr = compile_update {value=u;region=reg} in
let (name , access_path) = compile_path r.path in
let name, access_path = compile_path r.path in
let name = Var.of_name name in
return_statement @@ e_assign ~loc name access_path expr
)
| MapPatch patch -> (
let (map_p, loc) = r_split patch in
let (name, access_path) = compile_path map_p.path in
| MapPatch patch ->
let map_p, loc = r_split patch in
let name, access_path = compile_path map_p.path in
let%bind inj = bind_list
@@ List.map (fun (x:Raw.binding Region.reg) ->
let x = x.value in
@ -934,20 +924,18 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res
in ok @@ (key', value')
)
@@ npseq_to_list map_p.map_inj.value.ne_elements in
match inj with
(match inj with
| [] -> return_statement @@ e_skip ~loc ()
| _ :: _ ->
let assigns = List.fold_right
(fun (key, value) map -> (e_map_add key value map))
inj
(e_accessor ~loc (e_variable (Var.of_name name)) access_path)
in
let name = Var.of_name name in
return_statement @@ e_assign ~loc name access_path assigns
)
and name = Var.of_name name in
return_statement @@ e_assign ~loc name access_path assigns)
| SetPatch patch -> (
let (setp, loc) = r_split patch in
let (name , access_path) = compile_path setp.path in
let setp, loc = r_split patch in
let name, access_path = compile_path setp.path in
let%bind inj =
bind_list @@
List.map compile_expression @@
@ -961,13 +949,13 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res
let name = Var.of_name name in
return_statement @@ e_assign ~loc name access_path assigns
)
| MapRemove r -> (
| MapRemove r ->
let (v , loc) = r_split r in
let key = v.key in
let%bind (name,map,path) = match v.map with
| Name v -> ok (v.value , e_variable (Var.of_name v.value) , [])
| Path p ->
let (name,p') = compile_path v.map in
let name, p' = compile_path v.map in
let%bind accessor = compile_projection p in
ok @@ (name , accessor , p')
in
@ -975,37 +963,32 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res
let expr = e_constant ~loc C_MAP_REMOVE [key' ; map] in
let name = Var.of_name name in
return_statement @@ e_assign ~loc name path expr
)
| SetRemove r -> (
let (set_rm, loc) = r_split r in
let%bind (name, set, path) = match set_rm.set with
| Name v -> ok (v.value, e_variable (Var.of_name v.value), [])
| SetRemove r ->
let set_rm, loc = r_split r in
let%bind (name, set, path) =
match set_rm.set with
| Name v ->
ok (v.value, e_variable (Var.of_name v.value), [])
| Path path ->
let(name, p') = compile_path set_rm.set in
let%bind accessor = compile_projection path in
ok @@ (name, accessor, p')
in
let name, p' = compile_path set_rm.set in
let%bind accessor = compile_projection path in
ok @@ (name, accessor, p') in
let%bind removed' = compile_expression set_rm.element in
let expr = e_constant ~loc C_SET_REMOVE [removed' ; set] in
let name = Var.of_name name in
return_statement @@ e_assign ~loc name path expr
)
and compile_path : Raw.path -> string * access list = fun p ->
match p with
| Raw.Name v -> (v.value , [])
| Raw.Path p -> (
let p' = p.value in
let var = p'.struct_name.value in
let path = p'.field_path in
let path' = List.map compile_selection @@ npseq_to_list path in
(var , path')
)
and compile_path : Raw.path -> string * access list = function
Raw.Name v -> v.value, []
| Raw.Path {value; _} ->
let Raw.{struct_name; field_path; _} = value in
let var = struct_name.value in
let path = List.map compile_selection @@ npseq_to_list field_path
in var, path
and compile_selection : Raw.selection -> access = fun s ->
match s with
| FieldName property -> Access_record property.value
| Component index -> (Access_tuple (snd index.value))
and compile_selection : Raw.selection -> access = function
FieldName property -> Access_record property.value
| Component index -> Access_tuple (snd index.value)
and compile_cases : (Raw.pattern * expression) list -> matching_expr result = fun t ->
let open Raw in

1515
src/test/contracts/dune Normal file
View File

File diff suppressed because it is too large Load Diff

172
src/test/contracts/expected/FA1.2.ligo.expected Normal file
View File

@ -0,0 +1,172 @@
type tokens is big_map (address, nat)
type allowances is big_map (address * address, nat)
type storage is
record [
tokens : tokens;
allowances : allowances;
total_amount : nat
]
type transfer is
record [
address_from : address;
address_to : address;
value : nat
]
type approve is record [spender : address; value : nat]
type getAllowance is
record [
owner : address;
spender : address;
callback : contract (nat)
]
type getBalance is
record [owner : address; callback : contract (nat)]
type getTotalSupply is record [callback : contract (nat)]
type action is
Transfer of transfer
| Approve of approve
| GetAllowance of getAllowance
| GetBalance of getBalance
| GetTotalSupply of getTotalSupply
function transfer (const p : transfer; const s : storage)
: list (operation) * storage is
block {
var new_allowances : allowances := Big_map.empty;
if Tezos.sender = p.address_from
then {
new_allowances := s.allowances
}
else {
var authorized_value : nat
:= case (Big_map.find_opt
((Tezos.sender, p.address_from), s.allowances))
of [
Some (value) -> value
| None -> 0n
];
if (authorized_value < p.value)
then {
failwith ("Not Enough Allowance")
}
else {
new_allowances :=
Big_map.update
((Tezos.sender, p.address_from),
(Some (abs (authorized_value - p.value))),
s.allowances)
}
};
var sender_balance : nat
:= case (Big_map.find_opt (p.address_from, s.tokens)) of [
Some (value) -> value
| None -> 0n
];
var new_tokens : tokens := Big_map.empty;
if (sender_balance < p.value)
then {
failwith ("Not Enough Balance")
}
else {
new_tokens :=
Big_map.update
(p.address_from,
(Some (abs (sender_balance - p.value))), s.tokens);
var receiver_balance : nat
:= case (Big_map.find_opt (p.address_to, s.tokens)) of [
Some (value) -> value
| None -> 0n
];
new_tokens :=
Big_map.update
(p.address_to, (Some (receiver_balance + p.value)),
new_tokens)
}
} with
((nil : list (operation)),
s with
record [
tokens = new_tokens;
allowances = new_allowances
])
function approve (const p : approve; const s : storage)
: list (operation) * storage is
block {
var previous_value : nat
:= case Big_map.find_opt
((p.spender, Tezos.sender), s.allowances)
of [
Some (value) -> value
| None -> 0n
];
var new_allowances : allowances := Big_map.empty;
if previous_value > 0n and p.value > 0n
then {
failwith ("Unsafe Allowance Change")
}
else {
new_allowances :=
Big_map.update
((p.spender, Tezos.sender), (Some (p.value)),
s.allowances)
}
} with
((nil : list (operation)),
s with
record [allowances = new_allowances])
function getAllowance
(const p : getAllowance;
const s : storage) : list (operation) * storage is
block {
var value : nat
:= case Big_map.find_opt
((p.owner, p.spender), s.allowances)
of [
Some (value) -> value
| None -> 0n
];
var op : operation
:= Tezos.transaction (value, 0mutez, p.callback)
} with (list [op], s)
function getBalance
(const p : getBalance;
const s : storage) : list (operation) * storage is
block {
var value : nat
:= case Big_map.find_opt (p.owner, s.tokens) of [
Some (value) -> value
| None -> 0n
];
var op : operation
:= Tezos.transaction (value, 0mutez, p.callback)
} with (list [op], s)
function getTotalSupply
(const p : getTotalSupply;
const s : storage) : list (operation) * storage is
block {
var total : nat := s.total_amount;
var op : operation
:= Tezos.transaction (total, 0mutez, p.callback)
} with (list [op], s)
function main (const a : action; const s : storage)
: list (operation) * storage is
case a of [
Transfer (p) -> transfer (p, s)
| Approve (p) -> approve (p, s)
| GetAllowance (p) -> getAllowance (p, s)
| GetBalance (p) -> getBalance (p, s)
| GetTotalSupply (p) -> getTotalSupply (p, s)
]

136
src/test/contracts/expected/FA1.2.mligo.expected Normal file
View File

@ -0,0 +1,136 @@
type tokens = (address, nat) big_map
type allowances = (address * address, nat) big_map
type storage =
{tokens : tokens;
allowances : allowances;
total_amount : nat}
type transfer =
{address_from : address;
address_to : address;
value : nat}
type approve = {spender : address; value : nat}
type getAllowance =
{owner : address;
spender : address;
callback : nat contract}
type getBalance = {owner : address; callback : nat contract}
type getTotalSupply = {callback : nat contract}
type action =
Transfer of transfer
| Approve of approve
| GetAllowance of getAllowance
| GetBalance of getBalance
| GetTotalSupply of getTotalSupply
let transfer (p, s : transfer * storage)
: operation list * storage =
let new_allowances =
if Tezos.sender = p.address_from
then s.allowances
else
let authorized_value =
match Big_map.find_opt
(Tezos.sender, p.address_from)
s.allowances
with
Some value -> value
| None -> 0n
in if (authorized_value < p.value)
then (failwith "Not Enough Allowance" : allowances)
else
Big_map.update
(Tezos.sender, p.address_from)
(Some (abs (authorized_value - p.value)))
s.allowances
in let sender_balance =
match Big_map.find_opt p.address_from s.tokens with
Some value -> value
| None -> 0n
in if (sender_balance < p.value)
then
(failwith "Not Enough Balance"
: operation list * storage)
else
let new_tokens =
Big_map.update
p.address_from
(Some (abs (sender_balance - p.value)))
s.tokens
in let receiver_balance =
match Big_map.find_opt p.address_to s.tokens
with
Some value -> value
| None -> 0n
in let new_tokens =
Big_map.update
p.address_to
(Some (receiver_balance + p.value))
new_tokens
in ([] : operation list),
{s with
tokens = new_tokens;
allowances = new_allowances}
let approve (p, s : approve * storage)
: operation list * storage =
let previous_value =
match Big_map.find_opt
(p.spender, Tezos.sender)
s.allowances
with
Some value -> value
| None -> 0n
in if previous_value > 0n && p.value > 0n
then
(failwith "Unsafe Allowance Change"
: operation list * storage)
else
let new_allowances =
Big_map.update
(p.spender, Tezos.sender)
(Some (p.value))
s.allowances
in ([] : operation list),
{s with
allowances = new_allowances}
let getAllowance (p, s : getAllowance * storage)
: operation list * storage =
let value =
match Big_map.find_opt (p.owner, p.spender) s.allowances
with
Some value -> value
| None -> 0n
in let op = Tezos.transaction value 0mutez p.callback
in ([op], s)
let getBalance (p, s : getBalance * storage)
: operation list * storage =
let value =
match Big_map.find_opt p.owner s.tokens with
Some value -> value
| None -> 0n
in let op = Tezos.transaction value 0mutez p.callback
in ([op], s)
let getTotalSupply (p, s : getTotalSupply * storage)
: operation list * storage =
let total = s.total_amount
in let op = Tezos.transaction total 0mutez p.callback
in ([op], s)
let main (a, s : action * storage) =
match a with
Transfer p -> transfer (p, s)
| Approve p -> approve (p, s)
| GetAllowance p -> getAllowance (p, s)
| GetBalance p -> getBalance (p, s)
| GetTotalSupply p -> getTotalSupply (p, s)

4
src/test/contracts/expected/address.ligo.expected Normal file
View File

@ -0,0 +1,4 @@
function main (const p : key_hash) : address is
block {
const c : contract (unit) = Tezos.implicit_account (p)
} with Tezos.address (c)

3
src/test/contracts/expected/address.mligo.expected Normal file
View File

@ -0,0 +1,3 @@
let main (p : key_hash) =
let c : unit contract = Tezos.implicit_account p
in Tezos.address c

4
src/test/contracts/expected/address.religo.expected Normal file
View File

@ -0,0 +1,4 @@
let main = (p: key_hash): address => {
let c: contract(unit) = Tezos.implicit_account(p);
Tezos.address(c)
};

7
src/test/contracts/expected/amount.ligo.expected Normal file
View File

@ -0,0 +1,7 @@
function check (const p : unit) : int is
block {
var result : int := 0;
if amount = 100000000mutez
then result := 42
else result := 0
} with result

2
src/test/contracts/expected/amount.mligo.expected Normal file
View File

@ -0,0 +1,2 @@
let check_ (p : unit) : int =
if Tezos.amount = 100000000mutez then 42 else 0

6
src/test/contracts/expected/amount.religo.expected Normal file
View File

@ -0,0 +1,6 @@
let check_ = (p: unit): int =>
if (Tezos.amount == 100000000mutez) {
42
} else {
0
};

10
src/test/contracts/expected/amount_lambda.mligo.expected Normal file
View File

@ -0,0 +1,10 @@
let f1 (x : unit) : unit -> tez =
let amt : tez = Current.amount
in fun (x : unit) -> amt
let f2 (x : unit) : unit -> tez =
fun (x : unit) -> Current.amount
let main (b, s : bool * (unit -> tez))
: operation list * (unit -> tez) =
(([] : operation list), (if b then f1 () else f2 ()))

4
src/test/contracts/expected/annotation.ligo.expected Normal file
View File

@ -0,0 +1,4 @@
const lst : list (int) = list []
const my_address : address
= ("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" : address)

13
src/test/contracts/expected/application.ligo.expected Normal file
View File

@ -0,0 +1,13 @@
type foo is record [bar : int -> int]
function f (const i : int) : int is i
function g (const i : unit) : int -> int is f
const r : foo = record [bar = f]
const x : int = f (42)
const y : int = r.bar (42)
const z : int = (g (unit)) (42)

16
src/test/contracts/expected/arithmetic.ligo.expected Normal file
View File

@ -0,0 +1,16 @@
function mod_op (const n : int) : nat is n mod 42
function plus_op (const n : int) : int is n + 42
function minus_op (const n : int) : int is n - 42
function times_op (const n : int) : int is n * 42
function div_op (const n : int) : int is n / 2
function int_op (const n : nat) : int is int (n)
function neg_op (const n : int) : int is -n
function ediv_op (const n : int) : option (int * nat) is
ediv (n, 2)

17
src/test/contracts/expected/arithmetic.mligo.expected Normal file
View File

@ -0,0 +1,17 @@
let mod_op (n : int) : nat = n mod 42
let plus_op (n : int) : int = n + 42
let minus_op (n : int) : int = n - 42
let times_op (n : int) : int = n * 42
let div_op (n : int) : int = n / 2
let neg_op (n : int) : int = -n
let foo (n : int) : int = n + 10
let neg_op_2 (b : int) : int = -(foo b)
let ediv_op (n : int) : (int * nat) option = ediv n 2

17
src/test/contracts/expected/arithmetic.religo.expected Normal file
View File

@ -0,0 +1,17 @@
let mod_op = (n: int): nat => n mod 42;
let plus_op = (n: int): int => n + 42;
let minus_op = (n: int): int => n - 42;
let times_op = (n: int): int => n * 42;
let div_op = (n: int): int => n / 2;
let neg_op = (n: int): int => -n;
let foo = (n: int): int => n + 10;
let neg_op_2 = (b: int): int => -foo(b);
let ediv_op = (n: int): option((int, nat)) => ediv(n, 2);

3
src/test/contracts/expected/assert.mligo.expected Normal file
View File

@ -0,0 +1,3 @@
let main (p, s : bool * unit) =
let u : unit = assert p
in ([] : operation list), s

4
src/test/contracts/expected/assign.ligo.expected Normal file
View File

@ -0,0 +1,4 @@
function main (const i : int) : int is
block {
i := i + 1
} with i

24
src/test/contracts/expected/attributes.ligo.expected Normal file
View File

@ -0,0 +1,24 @@
const x : int = 1
attributes ["inline"]
function foo (const a : int) : int is
block {
const test : int = 2 + a;
attributes ["inline"]
} with test
attributes ["inline"]
const y : int = 1
attributes ["inline"; "other"]
function bar (const b : int) : int is
block {
function test (const z : int) : int is
block {
const r : int = 2 + b + z
} with r;
attributes ["inline"; "foo"; "bar"]
} with test (b)

14
src/test/contracts/expected/attributes.mligo.expected Normal file
View File

@ -0,0 +1,14 @@
let x = 1 [@@inline]
let foo (a : int) : int =
(let test = 2 + a [@@inline]
in test) [@@inline]
let y = 1 [@@inline][@@other]
let bar (b : int) : int =
let test = fun (z : int) -> 2 + b + z
[@@inline]
[@@foo]
[@@bar]
in test b

2
src/test/contracts/expected/bad_address_format.religo.expected Normal file
View File

@ -0,0 +1,2 @@
let main = (parameter: int, storage: address) =>
([] : list(operation), "KT1badaddr" : address);

11
src/test/contracts/expected/bad_timestamp.ligo.expected Normal file
View File

@ -0,0 +1,11 @@
type parameter is unit
type storage is timestamp
type return is list (operation) * storage
function main (const p : parameter; const s : storage)
: return is
block {
var stamp : timestamp := ("badtimestamp" : timestamp)
} with ((nil : list (operation)), stamp)

12
src/test/contracts/expected/bad_type_operator.ligo.expected Normal file
View File

@ -0,0 +1,12 @@
type parameter is unit
type binding is nat * nat
type storage is map (binding)
type return is list (operation) * storage
function main
(const param : parameter;
const store : storage) : return is
((nil : list (operation)), store)

10
src/test/contracts/expected/balance_constant.ligo.expected Normal file
View File

@ -0,0 +1,10 @@
type parameter is unit
type storage is tez
type return is list (operation) * storage
function main
(const param : parameter;
const store : storage) : return is
((nil : list (operation)), Tezos.balance)

8
src/test/contracts/expected/balance_constant.mligo.expected Normal file
View File

@ -0,0 +1,8 @@
type parameter = unit
type storage = tez
type return = operation list * storage
let main (p, s : parameter * storage) : return =
([] : operation list), Tezos.balance

6
src/test/contracts/expected/balance_constant.religo.expected Normal file
View File

@ -0,0 +1,6 @@
type storage = tez;
let main2 = (p: unit, s: storage) =>
([] : list(operation), Tezos.balance);
let main = (x: (unit, storage)) => main2(x[0], x[1]);

3
src/test/contracts/expected/basic.mligo.expected Normal file
View File

@ -0,0 +1,3 @@
type toto = int
let foo : toto = 42 + 127

41
src/test/contracts/expected/big_map.ligo.expected Normal file
View File

@ -0,0 +1,41 @@
type parameter is unit
type storage is big_map (int, int) * unit
type return is list (operation) * storage
function main (const p : parameter; const s : storage)
: return is
block {
var toto : option (int) := Some (0);
toto := s.0 [23];
s.0 [2] := 444
} with ((nil : list (operation)), s)
type foo is big_map (int, int)
function set_ (var n : int; var m : foo) : foo is
block {
m [23] := n
} with m
function add (var n : int; var m : foo) : foo is set_ (n, m)
function rm (var m : foo) : foo is
block {
remove 42 from map m
} with m
function get (const m : foo) : option (int) is m [42]
const empty_big_map : big_map (int, int) = big_map []
const big_map1 : big_map (int, int)
= big_map [23 -> 0; 42 -> 0]
function mutimaps (const m : foo; const n : foo) : foo is
block {
var bar : foo := m;
bar [42] := 0;
n [42] := get_force (42, bar)
} with n

22
src/test/contracts/expected/big_map.mligo.expected Normal file
View File

@ -0,0 +1,22 @@
type foo = (int, int) big_map
let set_ (n, m : int * foo) : foo =
Big_map.update 23 (Some n) m
let add (n, m : int * foo) : foo = Big_map.add 23 n m
let rm (m : foo) : foo = Big_map.remove 42 m
let gf (m : foo) : int = Big_map.find 23 m
let get (m : foo) : int option = Big_map.find_opt 42 m
let empty_map : foo = Big_map.empty
let map1 : foo = Big_map.literal [(23, 0); (42, 0)]
let map1 : foo = Big_map.literal [(23, 0); (42, 0)]
let mutimaps (m : foo) (n : foo) : foo =
let bar : foo = Big_map.update 42 (Some 0) m
in Big_map.update 42 (get bar) n

11
src/test/contracts/expected/bitwise_arithmetic.ligo.expected Normal file
View File

@ -0,0 +1,11 @@
function or_op (const n : nat) : nat is Bitwise.or (n, 4n)
function and_op (const n : nat) : nat is Bitwise.and (n, 7n)
function xor_op (const n : nat) : nat is Bitwise.xor (n, 7n)
function lsl_op (const n : nat) : nat is
Bitwise.shift_left (n, 7n)
function lsr_op (const n : nat) : nat is
Bitwise.shift_right (n, 7n)

9
src/test/contracts/expected/bitwise_arithmetic.mligo.expected Normal file
View File

@ -0,0 +1,9 @@
let or_op (n : nat) : nat = Bitwise.or n 4n
let and_op (n : nat) : nat = Bitwise.and n 7n
let xor_op (n : nat) : nat = Bitwise.xor n 7n
let lsl_op (n : nat) : nat = Bitwise.shift_left n 7n
let lsr_op (n : nat) : nat = Bitwise.shift_right n 7n

9
src/test/contracts/expected/bitwise_arithmetic.religo.expected Normal file
View File

@ -0,0 +1,9 @@
let or_op = (n: nat): nat => Bitwise.or(n, 4n);
let and_op = (n: nat): nat => Bitwise.and(n, 7n);
let xor_op = (n: nat): nat => Bitwise.xor(n, 7n);
let lsl_op = (n: nat): nat => Bitwise.shift_left(n, 7n);
let lsr_op = (n: nat): nat => Bitwise.shift_right(n, 7n);

1
src/test/contracts/expected/blockless.ligo.expected Normal file
View File

@ -0,0 +1 @@
function blockless (const n : int) : int is n + 10

9
src/test/contracts/expected/boolean_operators.ligo.expected Normal file
View File

@ -0,0 +1,9 @@
function or_true (const b : bool) : bool is b or True
function or_false (const b : bool) : bool is b or False
function and_true (const b : bool) : bool is b and True
function and_false (const b : bool) : bool is b and False
function not_bool (const b : bool) : bool is not b

9
src/test/contracts/expected/boolean_operators.mligo.expected Normal file
View File

@ -0,0 +1,9 @@
let or_true (b : bool) : bool = b || true
let or_false (b : bool) : bool = b || false
let and_true (b : bool) : bool = b && true
let and_false (b : bool) : bool = b && false
let not_bool (b : bool) : bool = not b

9
src/test/contracts/expected/boolean_operators.religo.expected Normal file
View File

@ -0,0 +1,9 @@
let or_true = (b: bool): bool => b || true;
let or_false = (b: bool): bool => b || false;
let and_true = (b: bool): bool => b && true;
let and_false = (b: bool): bool => b && false;
let not_bool = (b: bool): bool => ! b;

8
src/test/contracts/expected/bytes_arithmetic.ligo.expected Normal file
View File

@ -0,0 +1,8 @@
function concat_op (const s : bytes) : bytes is
Bytes.concat (s, 0x7070)
function slice_op (const s : bytes) : bytes is
Bytes.sub (1n, 2n, s)
function hasherman (const s : bytes) : bytes is
Crypto.sha256 (s)

5
src/test/contracts/expected/bytes_arithmetic.mligo.expected Normal file
View File

@ -0,0 +1,5 @@
let concat_op (s : bytes) : bytes = Bytes.concat s 0x7070
let slice_op (s : bytes) : bytes = Bytes.sub 1n 2n s
let hasherman (s : bytes) : bytes = Crypto.sha256 s

5
src/test/contracts/expected/bytes_arithmetic.religo.expected Normal file
View File

@ -0,0 +1,5 @@
let concat_op = (s: bytes): bytes => Bytes.concat(s, 0x7070);
let slice_op = (s: bytes): bytes => Bytes.slice(1n, 2n, s);
let hasherman = (s: bytes): bytes => Crypto.sha256(s);

15
src/test/contracts/expected/bytes_unpack.ligo.expected Normal file
View File

@ -0,0 +1,15 @@
function id_string (const p : string) : option (string) is
block {
const packed : bytes = Bytes.pack (p)
} with (Bytes.unpack (packed) : option (string))
function id_int (const p : int) : option (int) is
block {
const packed : bytes = Bytes.pack (p)
} with (Bytes.unpack (packed) : option (int))
function id_address (const p : address)
: option (address) is
block {
const packed : bytes = Bytes.pack (p)
} with (Bytes.unpack (packed) : option (address))

11
src/test/contracts/expected/bytes_unpack.mligo.expected Normal file
View File

@ -0,0 +1,11 @@
let id_string (p : string) : string option =
let packed : bytes = Bytes.pack p
in (Bytes.unpack packed : string option)
let id_int (p : int) : int option =
let packed : bytes = Bytes.pack p
in (Bytes.unpack packed : int option)
let id_address (p : address) : address option =
let packed : bytes = Bytes.pack p
in (Bytes.unpack packed : address option)

14
src/test/contracts/expected/bytes_unpack.religo.expected Normal file
View File

@ -0,0 +1,14 @@
let id_string = (p: string): option(string) => {
let packed: bytes = Bytes.pack(p);
((Bytes.unpack(packed)) : option(string))
};
let id_int = (p: int): option(int) => {
let packed: bytes = Bytes.pack(p);
((Bytes.unpack(packed)) : option(int))
};
let id_address = (p: address): option(address) => {
let packed: bytes = Bytes.pack(p);
((Bytes.unpack(packed)) : option(address))
};

2
src/test/contracts/expected/chain_id.ligo.expected Normal file
View File

@ -0,0 +1,2 @@
function chain_id (const tt : chain_id) : chain_id is
Tezos.chain_id

5
src/test/contracts/expected/check_signature.ligo.expected Normal file
View File

@ -0,0 +1,5 @@
function check_signature
(const pk : key;
const signed : signature;
const msg : bytes) : bool is
Crypto.check (pk, signed, msg)

11
src/test/contracts/expected/check_signature.mligo.expected Normal file
View File

@ -0,0 +1,11 @@
let check_signature
(pk, signed, msg : key * signature * bytes) : bool =
Crypto.check pk signed msg
let example : bool =
Crypto.check
("edpktz4xg6csJnJ5vcmMb2H37sWXyBDcoAp3XrBvjRaTSQ1zmZTeRQ"
: key)
("edsigtnzKd51CDomKVMFBoU8SzFZgNqRkYUaQH4DLUg8Lsimz98DFB82uiHAkdvx29DDqHxPf1noQ8noWpKMZoxTCsfprrbs4Xo"
: signature)
0x05010000000568656c6c6f

4
src/test/contracts/expected/check_signature.religo.expected Normal file
View File

@ -0,0 +1,4 @@
let check_signature = (param: (key, signature, bytes)): bool => {
let (pk, signed, msg) = param;
Crypto.check(pk, signed, msg)
};

4
src/test/contracts/expected/closure-1.ligo.expected Normal file
View File

@ -0,0 +1,4 @@
function foo (const i : int) : int is
block {
function add (const j : int) : int is i + j
} with add (i)

5
src/test/contracts/expected/closure-2.ligo.expected Normal file
View File

@ -0,0 +1,5 @@
function foobar (const i : int) : int is
block {
const j : int = 3;
function add (const k : int) : int is i + j + k
} with add (42)

6
src/test/contracts/expected/closure-3.ligo.expected Normal file
View File

@ -0,0 +1,6 @@
function foobar (const i : int) : int is
block {
const j : int = 3;
const k : int = 4;
function add (const l : int) : int is i + j + k + l
} with add (42)

5
src/test/contracts/expected/closure.ligo.expected Normal file
View File

@ -0,0 +1,5 @@
function toto (const i : int) : int is
block {
function tata (const j : int) : int is i + j;
function titi (const j : int) : int is i + j
} with tata (i) + titi (i)

5
src/test/contracts/expected/closure.mligo.expected Normal file
View File

@ -0,0 +1,5 @@
let test (k : int) : int =
let j : int = k + 5
in let close : int -> int = fun (i : int) -> i + j
in let j : int = 20
in close 20

6
src/test/contracts/expected/closure.religo.expected Normal file
View File

@ -0,0 +1,6 @@
let test = (k: int): int => {
let j: int = k + 5;
let close: (int => int) = (i: int) => i + j;
let j: int = 20;
close(20)
};

137
src/test/contracts/expected/coase.ligo.expected Normal file
View File

@ -0,0 +1,137 @@
type card_pattern_id is nat
type card_pattern is
record [coefficient : tez; quantity : nat]
type card_patterns is map (card_pattern_id, card_pattern)
type card_id is nat
type card is
record [
card_owner : address;
card_pattern : card_pattern_id
]
type cards is map (card_id, card)
type storage is
record [
cards : cards;
card_patterns : card_patterns;
next_id : nat
]
type return is list (operation) * storage
type action_buy_single is
record [card_to_buy : card_pattern_id]
type action_sell_single is record [card_to_sell : card_id]
type action_transfer_single is
record [card_to_transfer : card_id; destination : address]
type parameter is
Buy_single of action_buy_single
| Sell_single of action_sell_single
| Transfer_single of action_transfer_single
function transfer_single
(const action : action_transfer_single;
const s : storage) : return is
block {
const cards : cards = s.cards;
const card : card
= case cards [action.card_to_transfer] of [
Some (card) -> card
| None ->
(failwith ("transfer_single: No card.") : card)
];
if card.card_owner =/= sender
then failwith ("This card doesn't belong to you")
else skip;
card.card_owner := action.destination;
cards [action.card_to_transfer] := card;
s.cards := cards
} with ((nil : list (operation)), s)
function sell_single
(const action : action_sell_single;
const s : storage) : return is
block {
const card : card
= case s.cards [action.card_to_sell] of [
Some (card) -> card
| None -> (failwith ("sell_single: No card.") : card)
];
if card.card_owner =/= sender
then failwith ("This card doesn't belong to you")
else skip;
const card_pattern : card_pattern
= case s.card_patterns [card.card_pattern] of [
Some (pattern) -> pattern
| None ->
(failwith ("sell_single: No card pattern.")
: card_pattern)
];
card_pattern.quantity := abs (card_pattern.quantity - 1n);
const card_patterns : card_patterns = s.card_patterns;
card_patterns [card.card_pattern] := card_pattern;
s.card_patterns := card_patterns;
const cards : cards = s.cards;
remove action.card_to_sell from map cards;
s.cards := cards;
const price : tez
= card_pattern.coefficient * card_pattern.quantity;
const receiver : contract (unit)
= case (Tezos.get_contract_opt (Tezos.sender)
: option (contract (unit)))
of [
Some (contract) -> contract
| None ->
(failwith ("sell_single: No contract.")
: contract (unit))
];
const op : operation
= Tezos.transaction (unit, price, receiver);
const operations : list (operation) = list [op]
} with (operations, s)
function buy_single
(const action : action_buy_single;
const s : storage) : return is
block {
const card_pattern : card_pattern
= case s.card_patterns [action.card_to_buy] of [
Some (pattern) -> pattern
| None ->
(failwith ("buy_single: No card pattern.")
: card_pattern)
];
const price : tez
= card_pattern.coefficient * (card_pattern.quantity + 1n);
if price > amount
then failwith ("Not enough money")
else skip;
card_pattern.quantity := card_pattern.quantity + 1n;
const card_patterns : card_patterns = s.card_patterns;
card_patterns [action.card_to_buy] := card_pattern;
s.card_patterns := card_patterns;
const cards : cards = s.cards;
cards [s.next_id] :=
record [
card_owner = sender;
card_pattern = action.card_to_buy
];
s.cards := cards;
s.next_id := s.next_id + 1n
} with ((nil : list (operation)), s)
function main (const action : parameter; const s : storage)
: return is
case action of [
Buy_single (bs) -> buy_single (bs, s)
| Sell_single (as) -> sell_single (as, s)
| Transfer_single (at) -> transfer_single (at, s)
]

28
src/test/contracts/expected/comparable.mligo.expected Normal file
View File

@ -0,0 +1,28 @@
let int_ (a : int) = a < a
let nat_ (a : nat) = a < a
let bool_ (a : bool) = a < a
let mutez_ (a : tez) = a < a
let string_ (a : string) = a < a
let bytes_ (a : bytes) = a < a
let address_ (a : address) = a < a
let timestamp_ (a : timestamp) = a < a
let key_hash_ (a : key_hash) = a < a
type comp_pair = int * int
let comp_pair (a : comp_pair) = a < a
type inner_record = (int, "one", nat, "two") michelson_pair
type comb_record =
(int, "three", inner_record, "four") michelson_pair
let comb_record (a : comb_record) = a < a

4
src/test/contracts/expected/condition-annot.mligo.expected Normal file
View File

@ -0,0 +1,4 @@
type integer = int
let main (i : int) =
if (i = 2 : bool) then (42 : int) else (0 : integer)

9
src/test/contracts/expected/condition-shadowing.mligo.expected Normal file
View File

@ -0,0 +1,9 @@
let main (i : int) =
let result = 0
in if i = 2
then
let result = 42
in result
else
let result = 0
in result

12
src/test/contracts/expected/condition-shadowing.religo.expected Normal file
View File

@ -0,0 +1,12 @@
let main = (i: int) => {
let result = 0;
if (i == 2) {
let result = 42;
result
} else {
let result = 0;
result
}
};

Some files were not shown because too many files have changed in this diff Show More