diff --git a/gitlab-pages/docs/advanced/entrypoints-contracts.md b/gitlab-pages/docs/advanced/entrypoints-contracts.md index 752e553f3..dff0a535a 100644 --- a/gitlab-pages/docs/advanced/entrypoints-contracts.md +++ b/gitlab-pages/docs/advanced/entrypoints-contracts.md @@ -220,7 +220,7 @@ In our case, we have a `counter.ligo` contract that accepts a parameter of type -```pascaligo +```pascaligo skip // counter.ligo type action is | Increment of int diff --git a/gitlab-pages/docs/language-basics/boolean-if-else.md b/gitlab-pages/docs/language-basics/boolean-if-else.md index d57e6fa99..07cb40d04 100644 --- a/gitlab-pages/docs/language-basics/boolean-if-else.md +++ b/gitlab-pages/docs/language-basics/boolean-if-else.md @@ -139,21 +139,8 @@ Conditional logic is an important part of every real world program. ```pascaligo group=e const min_age: nat = 16n; -(* - This function is really obnoxious, but it showcases - how the if statement and it's syntax can be used. - - Normally, you'd use `with (age > min_age)` instead. -*) function is_adult(const age: nat): bool is - block { - var is_adult: bool := False; - if (age > min_age) then begin - is_adult := True; - end else begin - is_adult := False; - end - } with is_adult + if (age > min_age) then True else False ``` > You can run the function above with diff --git a/gitlab-pages/docs/language-basics/math-numbers-tez.md b/gitlab-pages/docs/language-basics/math-numbers-tez.md index 1609679e8..91a4b923a 100644 --- a/gitlab-pages/docs/language-basics/math-numbers-tez.md +++ b/gitlab-pages/docs/language-basics/math-numbers-tez.md @@ -200,6 +200,18 @@ const a: int = int(1n); const b: nat = abs(1); ``` + + +## Check if a value is a `nat` + +You can check if a value is a `nat`, by using a syntax specific built-in function, which accepts an `int` and returns an `option(nat)`, more specifically `Some(nat)` if the provided integer is a natural number, and `None` otherwise: + + + +```pascaligo +const its_a_nat: option(nat) = is_nat(1) +``` + ```reasonligo group=e let a: int = int(1n); diff --git a/gitlab-pages/docs/language-basics/src/boolean-if-else/if-else.ligo b/gitlab-pages/docs/language-basics/src/boolean-if-else/if-else.ligo new file mode 100644 index 000000000..cc2b84529 --- /dev/null +++ b/gitlab-pages/docs/language-basics/src/boolean-if-else/if-else.ligo @@ -0,0 +1,4 @@ +const min_age: nat = 16n; + +function is_adult(const age: nat): bool is + if (age > min_age) then True else False \ No newline at end of file diff --git a/gitlab-pages/docs/language-basics/src/math-numbers-tez/isnat.ligo b/gitlab-pages/docs/language-basics/src/math-numbers-tez/isnat.ligo new file mode 100644 index 000000000..5a89add1a --- /dev/null +++ b/gitlab-pages/docs/language-basics/src/math-numbers-tez/isnat.ligo @@ -0,0 +1 @@ +const its_a_nat: option(nat) = is_nat(1) \ No newline at end of file diff --git a/gitlab-pages/docs/language-basics/src/types/annotation.ligo b/gitlab-pages/docs/language-basics/src/types/annotation.ligo new file mode 100644 index 000000000..9373e08ec --- /dev/null +++ b/gitlab-pages/docs/language-basics/src/types/annotation.ligo @@ -0,0 +1,4 @@ +type int_map is map(int, int); +function get_first(const int_map: int_map): option(int) is int_map[1] +// empty map needs a type annotation +const first: option(int) = get_first(((map end) : int_map )); \ No newline at end of file diff --git a/gitlab-pages/docs/language-basics/types.md b/gitlab-pages/docs/language-basics/types.md index a2d456473..b19004a2b 100644 --- a/gitlab-pages/docs/language-basics/types.md +++ b/gitlab-pages/docs/language-basics/types.md @@ -3,7 +3,7 @@ id: types title: Types --- -LIGO is strongly and statically typed. This means that the compiler checks your program at compilation time and makes sure there won't be any type related runtime errors. LIGO types are built on top of Michelson's type system. +LIGO is strongly and statically typed. This means that the compiler checks your program at compilation time and makes sure there won't be any type related runtime errors. LIGO types are built on top of Michelson's type system. ## Built-in types @@ -36,6 +36,8 @@ let dog_breed: animal_breed = "Saluki"; +> Types in LIGO are `structural`, which means that `animalBreed`/`animal_breed` and `string` are interchangable and are considered equal. + ## Simple types @@ -146,3 +148,18 @@ let ledger: account_balances = ``` + +## Annotations + +In certain cases, type of an expression cannot be properly determined. This can be circumvented by annotating an expression with it's desired type, here's an example: + + + +```pascaligo +type int_map is map(int, int); +function get_first(const int_map: int_map): option(int) is int_map[1] +// empty map needs a type annotation +const first: option(int) = get_first(((map end) : int_map )); +``` + + \ No newline at end of file diff --git a/gitlab-pages/website/package-lock.json b/gitlab-pages/website/package-lock.json index aedc47552..27e5e7983 100644 --- a/gitlab-pages/website/package-lock.json +++ b/gitlab-pages/website/package-lock.json @@ -5624,15 +5624,6 @@ "integrity": "sha512-s5kLOcnH0XqDO+FvuaLX8DDjZ18CGFk7VygH40QoKPUQhW4e2rvM0rwUq0t8IQDOwYSeLK01U90OjzBTme2QqA==", "dev": true }, - "klaw-sync": { - "version": "6.0.0", - "resolved": "https://registry.npmjs.org/klaw-sync/-/klaw-sync-6.0.0.tgz", - "integrity": "sha512-nIeuVSzdCCs6TDPTqI8w1Yre34sSq7AkZ4B3sfOBbI2CgVSB4Du4aLQijFU2+lhAFCwt9+42Hel6lQNIv6AntQ==", - "dev": true, - "requires": { - "graceful-fs": "^4.1.11" - } - }, "lazy-cache": { "version": "2.0.2", "resolved": "https://registry.npmjs.org/lazy-cache/-/lazy-cache-2.0.2.tgz", @@ -7412,15 +7403,6 @@ "integrity": "sha1-1PRWKwzjaW5BrFLQ4ALlemNdxtw=", "dev": true }, - "preprocess": { - "version": "3.1.0", - "resolved": "https://registry.npmjs.org/preprocess/-/preprocess-3.1.0.tgz", - "integrity": "sha1-pE5c3Vu7WlTwrSiaru2AmV19k4o=", - "dev": true, - "requires": { - "xregexp": "3.1.0" - } - }, "prismjs": { "version": "1.17.1", "resolved": "https://registry.npmjs.org/prismjs/-/prismjs-1.17.1.tgz", @@ -7750,6 +7732,12 @@ "picomatch": "^2.0.4" } }, + "reason-highlightjs": { + "version": "0.2.1", + "resolved": "https://registry.npmjs.org/reason-highlightjs/-/reason-highlightjs-0.2.1.tgz", + "integrity": "sha512-DWWPtfeQjwKgHj2OOieEIAB544uAVjwOAIAg2Yu09CobdUe41Yah0Z67GEvmVtpYCGG/+3CZvDRM1hMVr1zN3A==", + "dev": true + }, "rechoir": { "version": "0.6.2", "resolved": "https://registry.npmjs.org/rechoir/-/rechoir-0.6.2.tgz", @@ -9433,12 +9421,6 @@ "integrity": "sha512-Eux0i2QdDYKbdbA6AM6xE4m6ZTZr4G4xF9kahI2ukSEMCzwce2eX9WlTI5J3s+NU7hpasFsr8hWIONae7LluAQ==", "dev": true }, - "xregexp": { - "version": "3.1.0", - "resolved": "https://registry.npmjs.org/xregexp/-/xregexp-3.1.0.tgz", - "integrity": "sha1-FNhGHgvdOCJL/uUDmgiY/EL80zY=", - "dev": true - }, "xtend": { "version": "4.0.2", "resolved": "https://registry.npmjs.org/xtend/-/xtend-4.0.2.tgz", diff --git a/ligo.opam b/ligo.opam index 92b0e4051..167e004a8 100644 --- a/ligo.opam +++ b/ligo.opam @@ -4,7 +4,7 @@ maintainer: "ligolang@gmail.com" authors: [ "Galfour" ] homepage: "https://gitlab.com/ligolang/tezos" bug-reports: "https://gitlab.com/ligolang/tezos/issues" -synopsis: "A higher-level language which compiles to Michelson" +synopsis: "A high-level language which compiles to Michelson" dev-repo: "git+https://gitlab.com/ligolang/tezos.git" license: "MIT" depends: [ @@ -21,6 +21,8 @@ depends: [ "yojson" "alcotest" { with-test } "getopt" + "terminal_size" + "pprint" # work around upstream in-place update "ocaml-migrate-parsetree" { = "1.4.0" } ] diff --git a/src/bin/cli.ml b/src/bin/cli.ml index b12ce3eb1..3356401b2 100644 --- a/src/bin/cli.ml +++ b/src/bin/cli.ml @@ -19,7 +19,7 @@ let source_file n = let open Arg in let info = let docv = "SOURCE_FILE" in - let doc = "$(docv) is the path to the .ligo or .mligo file of the contract." in + let doc = "$(docv) is the path to the smart contract file." in info ~docv ~doc [] in required @@ pos n (some string) None info @@ -42,7 +42,7 @@ let syntax = let open Arg in let info = let docv = "SYNTAX" in - let doc = "$(docv) is the syntax that will be used. Currently supported syntaxes are \"pascaligo\" and \"cameligo\". By default, the syntax is guessed from the extension (.ligo and .mligo, respectively)." in + let doc = "$(docv) is the syntax that will be used. Currently supported syntaxes are \"pascaligo\", \"cameligo\" and \"reasonligo\". By default, the syntax is guessed from the extension (.ligo, .mligo, .religo respectively)." in info ~docv ~doc ["syntax" ; "s"] in value @@ opt string "auto" info @@ -50,7 +50,7 @@ let req_syntax n = let open Arg in let info = let docv = "SYNTAX" in - let doc = "$(docv) is the syntax that will be used. Currently supported syntaxes are \"pascaligo\" and \"cameligo\". By default, the syntax is guessed from the extension (.ligo and .mligo, respectively)." in + let doc = "$(docv) is the syntax that will be used. Currently supported syntaxes are \"pascaligo\", \"cameligo\" and \"reasonligo\". By default, the syntax is guessed from the extension (.ligo, .mligo, .religo respectively)." in info ~docv ~doc [] in required @@ pos n (some string) None info @@ -58,7 +58,7 @@ let init_file = let open Arg in let info = let docv = "INIT_FILE" in - let doc = "$(docv) is the path to the .ligo or .mligo file to be used for context initialization." in + let doc = "$(docv) is the path to smart contract file to be used for context initialization." in info ~docv ~doc ["init-file"] in value @@ opt (some string) None info @@ -66,7 +66,7 @@ let amount = let open Arg in let info = let docv = "AMOUNT" in - let doc = "$(docv) is the amount the michelson interpreter will use." in + let doc = "$(docv) is the amount the Michelson interpreter will use." in info ~docv ~doc ["amount"] in value @@ opt string "0" info @@ -74,7 +74,7 @@ let sender = let open Arg in let info = let docv = "SENDER" in - let doc = "$(docv) is the sender the michelson interpreter transaction will use." in + let doc = "$(docv) is the sender the Michelson interpreter transaction will use." in info ~docv ~doc ["sender"] in value @@ opt (some string) None info @@ -82,7 +82,7 @@ let source = let open Arg in let info = let docv = "SOURCE" in - let doc = "$(docv) is the source the michelson interpreter transaction will use." in + let doc = "$(docv) is the source the Michelson interpreter transaction will use." in info ~docv ~doc ["source"] in value @@ opt (some string) None info @@ -90,7 +90,7 @@ let predecessor_timestamp = let open Arg in let info = let docv = "PREDECESSOR_TIMESTAMP" in - let doc = "$(docv) is the pedecessor_timestamp (now value minus one minute) the michelson interpreter will use (e.g. '2000-01-01T10:10:10Z')" in + let doc = "$(docv) is the predecessor_timestamp (now value minus one minute) the Michelson interpreter will use (e.g. '2000-01-01T10:10:10Z')" in info ~docv ~doc ["predecessor-timestamp"] in value @@ opt (some string) None info @@ -135,58 +135,58 @@ let compile_file = let term = Term.(const f $ source_file 0 $ entry_point 1 $ syntax $ display_format $ michelson_code_format) in let cmdname = "compile-contract" in - let doc = "Subcommand: compile a contract." in + let doc = "Subcommand: Compile a contract." in (Term.ret term , Term.info ~doc cmdname) -let print_cst = +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 source_file (Syntax_name syntax) in ok @@ Format.asprintf "%s \n" (Buffer.contents pp) ) in let term = Term.(const f $ source_file 0 $ syntax $ display_format) in - let cmdname = "print-cst" in - let doc = "Subcommand: print the cst. Warning: intended for development of LIGO and can break at any time." in + let cmdname = "print-cst" in + let doc = "Subcommand: Print the CST.\nWarning: Intended for development of LIGO and can break at any time." in (Term.ret term, Term.info ~doc cmdname) -let print_ast = +let print_ast = let f source_file syntax display_format = ( toplevel ~display_format @@ let%bind simplified = Compile.Of_source.compile source_file (Syntax_name syntax) in - ok @@ Format.asprintf "%a\n" Compile.Of_simplified.pretty_print simplified + ok @@ Format.asprintf "%a\n" Compile.Of_simplified.pretty_print simplified ) in let term = Term.(const f $ source_file 0 $ syntax $ display_format) in - let cmdname = "print-ast" in - let doc = "Subcommand: print the ast. Warning: intended for development of LIGO and can break at any time." in + let cmdname = "print-ast" in + let doc = "Subcommand: Print the AST.\n Warning: Intended for development of LIGO and can break at any time." in (Term.ret term, Term.info ~doc cmdname) -let print_typed_ast = +let print_typed_ast = let f source_file syntax display_format = ( toplevel ~display_format @@ let%bind simplified = Compile.Of_source.compile source_file (Syntax_name syntax) in let%bind typed,_ = Compile.Of_simplified.compile simplified in - ok @@ Format.asprintf "%a\n" Compile.Of_typed.pretty_print typed + ok @@ Format.asprintf "%a\n" Compile.Of_typed.pretty_print typed ) in let term = Term.(const f $ source_file 0 $ syntax $ display_format) in - let cmdname = "print-typed-ast" in - let doc = "Subcommand: print the typed ast. Warning: intended for development of LIGO and can break at any time." in + let cmdname = "print-typed-ast" in + let doc = "Subcommand: Print the typed AST.\n Warning: Intended for development of LIGO and can break at any time." in (Term.ret term, Term.info ~doc cmdname) -let print_mini_c = +let print_mini_c = let f source_file syntax display_format = ( toplevel ~display_format @@ let%bind simplified = Compile.Of_source.compile source_file (Syntax_name syntax) in let%bind typed,_ = Compile.Of_simplified.compile simplified in let%bind mini_c = Compile.Of_typed.compile typed in - ok @@ Format.asprintf "%a\n" Compile.Of_mini_c.pretty_print mini_c + ok @@ Format.asprintf "%a\n" Compile.Of_mini_c.pretty_print mini_c ) in let term = Term.(const f $ source_file 0 $ syntax $ display_format) in - let cmdname = "print-mini-c" in - let doc = "Subcommand: print mini c. Warning: intended for development of LIGO and can break at any time." in + let cmdname = "print-mini-c" in + let doc = "Subcommand: Print Mini-C. Warning: Intended for development of LIGO and can break at any time." in (Term.ret term, Term.info ~doc cmdname) let measure_contract = @@ -203,7 +203,7 @@ let measure_contract = let term = Term.(const f $ source_file 0 $ entry_point 1 $ syntax $ display_format) in let cmdname = "measure-contract" in - let doc = "Subcommand: measure a contract's compiled size in bytes." in + let doc = "Subcommand: Measure a contract's compiled size in bytes." in (Term.ret term , Term.info ~doc cmdname) let compile_parameter = @@ -232,7 +232,7 @@ let compile_parameter = let term = Term.(const f $ source_file 0 $ entry_point 1 $ expression "PARAMETER" 2 $ syntax $ amount $ sender $ source $ predecessor_timestamp $ display_format $ michelson_code_format) in let cmdname = "compile-parameter" in - let doc = "Subcommand: compile parameters to a michelson expression. The resulting michelson expression can be passed as an argument in a transaction which calls a contract." in + let doc = "Subcommand: Compile parameters to a Michelson expression. The resulting Michelson expression can be passed as an argument in a transaction which calls a contract." in (Term.ret term , Term.info ~doc cmdname) let interpret = @@ -246,7 +246,7 @@ let interpret = let env = Ast_typed.program_environment typed_prg in ok (mini_c_prg,state,env) | None -> ok ([],Typer.Solver.initial_state,Ast_typed.Environment.full_empty) in - + let%bind v_syntax = Helpers.syntax_to_variant (Syntax_name syntax) init_file in let%bind simplified_exp = Compile.Of_source.compile_expression v_syntax expression in let%bind (typed_exp,_) = Compile.Of_simplified.compile_expression ~env ~state simplified_exp in @@ -265,7 +265,7 @@ let interpret = let term = Term.(const f $ expression "EXPRESSION" 0 $ init_file $ syntax $ amount $ sender $ source $ predecessor_timestamp $ display_format ) in let cmdname = "interpret" in - let doc = "Subcommand: interpret the expression in the context initialized by the provided source file." in + let doc = "Subcommand: Interpret the expression in the context initialized by the provided source file." in (Term.ret term , Term.info ~doc cmdname) @@ -295,7 +295,7 @@ let compile_storage = let term = Term.(const f $ source_file 0 $ entry_point 1 $ expression "STORAGE" 2 $ syntax $ amount $ sender $ source $ predecessor_timestamp $ display_format $ michelson_code_format) in let cmdname = "compile-storage" in - let doc = "Subcommand: compile an initial storage in ligo syntax to a michelson expression. The resulting michelson expression can be passed as an argument in a transaction which originates a contract." in + let doc = "Subcommand: Compile an initial storage in ligo syntax to a Michelson expression. The resulting Michelson expression can be passed as an argument in a transaction which originates a contract." in (Term.ret term , Term.info ~doc cmdname) let dry_run = @@ -330,7 +330,7 @@ let dry_run = let term = Term.(const f $ source_file 0 $ entry_point 1 $ expression "PARAMETER" 2 $ expression "STORAGE" 3 $ amount $ sender $ source $ predecessor_timestamp $ syntax $ display_format) in let cmdname = "dry-run" in - let doc = "Subcommand: run a smart-contract with the given storage and input." in + let doc = "Subcommand: Run a smart-contract with the given storage and input." in (Term.ret term , Term.info ~doc cmdname) let run_function = @@ -361,7 +361,7 @@ let run_function = let term = Term.(const f $ source_file 0 $ entry_point 1 $ expression "PARAMETER" 2 $ amount $ sender $ source $ predecessor_timestamp $ syntax $ display_format) in let cmdname = "run-function" in - let doc = "Subcommand: run a function with the given parameter." in + let doc = "Subcommand: Run a function with the given parameter." in (Term.ret term , Term.info ~doc cmdname) let evaluate_value = @@ -380,7 +380,7 @@ let evaluate_value = let term = Term.(const f $ source_file 0 $ entry_point 1 $ amount $ sender $ source $ predecessor_timestamp $ syntax $ display_format) in let cmdname = "evaluate-value" in - let doc = "Subcommand: evaluate a given definition." in + let doc = "Subcommand: Evaluate a given definition." in (Term.ret term , Term.info ~doc cmdname) let compile_expression = @@ -399,7 +399,7 @@ let compile_expression = let term = Term.(const f $ expression "" 1 $ req_syntax 0 $ display_format $ michelson_code_format) in let cmdname = "compile-expression" in - let doc = "Subcommand: compile to a michelson value." in + let doc = "Subcommand: Compile to a michelson value." in (Term.ret term , Term.info ~doc cmdname) let dump_changelog = @@ -420,7 +420,7 @@ let list_declarations = let term = Term.(const f $ source_file 0 $ syntax ) in let cmdname = "list-declarations" in - let doc = "Subcommand: list all the top-level decalarations." in + let doc = "Subcommand: List all the top-level declarations." in (Term.ret term , Term.info ~doc cmdname) let run ?argv () = diff --git a/src/bin/expect_tests/help_tests.ml b/src/bin/expect_tests/help_tests.ml index 716837074..06e877a32 100644 --- a/src/bin/expect_tests/help_tests.ml +++ b/src/bin/expect_tests/help_tests.ml @@ -18,56 +18,56 @@ let%expect_test _ = Dump the LIGO changelog to stdout. compile-contract - Subcommand: compile a contract. + Subcommand: Compile a contract. compile-expression - Subcommand: compile to a michelson value. + Subcommand: Compile to a michelson value. compile-parameter - Subcommand: compile parameters to a michelson expression. The - resulting michelson expression can be passed as an argument in a + Subcommand: Compile parameters to a Michelson expression. The + resulting Michelson expression can be passed as an argument in a transaction which calls a contract. compile-storage - Subcommand: compile an initial storage in ligo syntax to a - michelson expression. The resulting michelson expression can be + Subcommand: Compile an initial storage in ligo syntax to a + Michelson expression. The resulting Michelson expression can be passed as an argument in a transaction which originates a contract. dry-run - Subcommand: run a smart-contract with the given storage and input. + Subcommand: Run a smart-contract with the given storage and input. evaluate-value - Subcommand: evaluate a given definition. + Subcommand: Evaluate a given definition. interpret - Subcommand: interpret the expression in the context initialized by + Subcommand: Interpret the expression in the context initialized by the provided source file. list-declarations - Subcommand: list all the top-level decalarations. + Subcommand: List all the top-level declarations. measure-contract - Subcommand: measure a contract's compiled size in bytes. + Subcommand: Measure a contract's compiled size in bytes. print-ast - Subcommand: print the ast. Warning: intended for development of + Subcommand: Print the AST. Warning: Intended for development of LIGO and can break at any time. print-cst - Subcommand: print the cst. Warning: intended for development of + Subcommand: Print the CST. Warning: Intended for development of LIGO and can break at any time. print-mini-c - Subcommand: print mini c. Warning: intended for development of + Subcommand: Print Mini-C. Warning: Intended for development of LIGO and can break at any time. print-typed-ast - Subcommand: print the typed ast. Warning: intended for development + Subcommand: Print the typed AST. Warning: Intended for development of LIGO and can break at any time. run-function - Subcommand: run a function with the given parameter. + Subcommand: Run a function with the given parameter. OPTIONS --help[=FMT] (default=auto) @@ -94,56 +94,56 @@ let%expect_test _ = Dump the LIGO changelog to stdout. compile-contract - Subcommand: compile a contract. + Subcommand: Compile a contract. compile-expression - Subcommand: compile to a michelson value. + Subcommand: Compile to a michelson value. compile-parameter - Subcommand: compile parameters to a michelson expression. The - resulting michelson expression can be passed as an argument in a + Subcommand: Compile parameters to a Michelson expression. The + resulting Michelson expression can be passed as an argument in a transaction which calls a contract. compile-storage - Subcommand: compile an initial storage in ligo syntax to a - michelson expression. The resulting michelson expression can be + Subcommand: Compile an initial storage in ligo syntax to a + Michelson expression. The resulting Michelson expression can be passed as an argument in a transaction which originates a contract. dry-run - Subcommand: run a smart-contract with the given storage and input. + Subcommand: Run a smart-contract with the given storage and input. evaluate-value - Subcommand: evaluate a given definition. + Subcommand: Evaluate a given definition. interpret - Subcommand: interpret the expression in the context initialized by + Subcommand: Interpret the expression in the context initialized by the provided source file. list-declarations - Subcommand: list all the top-level decalarations. + Subcommand: List all the top-level declarations. measure-contract - Subcommand: measure a contract's compiled size in bytes. + Subcommand: Measure a contract's compiled size in bytes. print-ast - Subcommand: print the ast. Warning: intended for development of + Subcommand: Print the AST. Warning: Intended for development of LIGO and can break at any time. print-cst - Subcommand: print the cst. Warning: intended for development of + Subcommand: Print the CST. Warning: Intended for development of LIGO and can break at any time. print-mini-c - Subcommand: print mini c. Warning: intended for development of + Subcommand: Print Mini-C. Warning: Intended for development of LIGO and can break at any time. print-typed-ast - Subcommand: print the typed ast. Warning: intended for development + Subcommand: Print the typed AST. Warning: Intended for development of LIGO and can break at any time. run-function - Subcommand: run a function with the given parameter. + Subcommand: Run a function with the given parameter. OPTIONS --help[=FMT] (default=auto) @@ -157,7 +157,7 @@ let%expect_test _ = run_ligo_good [ "compile-contract" ; "--help" ] ; [%expect {| NAME - ligo-compile-contract - Subcommand: compile a contract. + ligo-compile-contract - Subcommand: Compile a contract. SYNOPSIS ligo compile-contract [OPTION]... SOURCE_FILE ENTRY_POINT @@ -167,8 +167,7 @@ let%expect_test _ = ENTRY_POINT is entry-point that will be compiled. SOURCE_FILE (required) - SOURCE_FILE is the path to the .ligo or .mligo file of the - contract. + SOURCE_FILE is the path to the smart contract file. OPTIONS --format=DISPLAY_FORMAT, --display-format=DISPLAY_FORMAT @@ -191,8 +190,9 @@ let%expect_test _ = -s SYNTAX, --syntax=SYNTAX (absent=auto) SYNTAX is the syntax that will be used. Currently supported - syntaxes are "pascaligo" and "cameligo". By default, the syntax is - guessed from the extension (.ligo and .mligo, respectively). + syntaxes are "pascaligo", "cameligo" and "reasonligo". By default, + the syntax is guessed from the extension (.ligo, .mligo, .religo + respectively). --version Show version information. |} ] ; @@ -200,8 +200,8 @@ let%expect_test _ = run_ligo_good [ "compile-parameter" ; "--help" ] ; [%expect {| NAME - ligo-compile-parameter - Subcommand: compile parameters to a michelson - expression. The resulting michelson expression can be passed as an + ligo-compile-parameter - Subcommand: Compile parameters to a Michelson + expression. The resulting Michelson expression can be passed as an argument in a transaction which calls a contract. SYNOPSIS @@ -216,12 +216,11 @@ let%expect_test _ = PARAMETER_EXPRESSION is the expression that will be compiled. SOURCE_FILE (required) - SOURCE_FILE is the path to the .ligo or .mligo file of the - contract. + SOURCE_FILE is the path to the smart contract file. OPTIONS --amount=AMOUNT (absent=0) - AMOUNT is the amount the michelson interpreter will use. + AMOUNT is the amount the Michelson interpreter will use. --format=DISPLAY_FORMAT, --display-format=DISPLAY_FORMAT (absent=human-readable) @@ -242,21 +241,22 @@ let%expect_test _ = are 'text' (default), 'json' and 'hex'. --predecessor-timestamp=PREDECESSOR_TIMESTAMP - PREDECESSOR_TIMESTAMP is the pedecessor_timestamp (now value minus - one minute) the michelson interpreter will use (e.g. + PREDECESSOR_TIMESTAMP is the predecessor_timestamp (now value + minus one minute) the Michelson interpreter will use (e.g. '2000-01-01T10:10:10Z') -s SYNTAX, --syntax=SYNTAX (absent=auto) SYNTAX is the syntax that will be used. Currently supported - syntaxes are "pascaligo" and "cameligo". By default, the syntax is - guessed from the extension (.ligo and .mligo, respectively). + syntaxes are "pascaligo", "cameligo" and "reasonligo". By default, + the syntax is guessed from the extension (.ligo, .mligo, .religo + respectively). --sender=SENDER - SENDER is the sender the michelson interpreter transaction will + SENDER is the sender the Michelson interpreter transaction will use. --source=SOURCE - SOURCE is the source the michelson interpreter transaction will + SOURCE is the source the Michelson interpreter transaction will use. --version @@ -265,8 +265,8 @@ let%expect_test _ = run_ligo_good [ "compile-storage" ; "--help" ] ; [%expect {| NAME - ligo-compile-storage - Subcommand: compile an initial storage in ligo - syntax to a michelson expression. The resulting michelson expression + ligo-compile-storage - Subcommand: Compile an initial storage in ligo + syntax to a Michelson expression. The resulting Michelson expression can be passed as an argument in a transaction which originates a contract. @@ -279,15 +279,14 @@ let%expect_test _ = ENTRY_POINT is entry-point that will be compiled. SOURCE_FILE (required) - SOURCE_FILE is the path to the .ligo or .mligo file of the - contract. + SOURCE_FILE is the path to the smart contract file. STORAGE_EXPRESSION (required) STORAGE_EXPRESSION is the expression that will be compiled. OPTIONS --amount=AMOUNT (absent=0) - AMOUNT is the amount the michelson interpreter will use. + AMOUNT is the amount the Michelson interpreter will use. --format=DISPLAY_FORMAT, --display-format=DISPLAY_FORMAT (absent=human-readable) @@ -308,21 +307,22 @@ let%expect_test _ = are 'text' (default), 'json' and 'hex'. --predecessor-timestamp=PREDECESSOR_TIMESTAMP - PREDECESSOR_TIMESTAMP is the pedecessor_timestamp (now value minus - one minute) the michelson interpreter will use (e.g. + PREDECESSOR_TIMESTAMP is the predecessor_timestamp (now value + minus one minute) the Michelson interpreter will use (e.g. '2000-01-01T10:10:10Z') -s SYNTAX, --syntax=SYNTAX (absent=auto) SYNTAX is the syntax that will be used. Currently supported - syntaxes are "pascaligo" and "cameligo". By default, the syntax is - guessed from the extension (.ligo and .mligo, respectively). + syntaxes are "pascaligo", "cameligo" and "reasonligo". By default, + the syntax is guessed from the extension (.ligo, .mligo, .religo + respectively). --sender=SENDER - SENDER is the sender the michelson interpreter transaction will + SENDER is the sender the Michelson interpreter transaction will use. --source=SOURCE - SOURCE is the source the michelson interpreter transaction will + SOURCE is the source the Michelson interpreter transaction will use. --version @@ -331,7 +331,7 @@ let%expect_test _ = run_ligo_good [ "dry-run" ; "--help" ] ; [%expect {| NAME - ligo-dry-run - Subcommand: run a smart-contract with the given storage + ligo-dry-run - Subcommand: Run a smart-contract with the given storage and input. SYNOPSIS @@ -346,15 +346,14 @@ let%expect_test _ = PARAMETER_EXPRESSION is the expression that will be compiled. SOURCE_FILE (required) - SOURCE_FILE is the path to the .ligo or .mligo file of the - contract. + SOURCE_FILE is the path to the smart contract file. STORAGE_EXPRESSION (required) STORAGE_EXPRESSION is the expression that will be compiled. OPTIONS --amount=AMOUNT (absent=0) - AMOUNT is the amount the michelson interpreter will use. + AMOUNT is the amount the Michelson interpreter will use. --format=DISPLAY_FORMAT, --display-format=DISPLAY_FORMAT (absent=human-readable) @@ -370,21 +369,22 @@ let%expect_test _ = `plain' whenever the TERM env var is `dumb' or undefined. --predecessor-timestamp=PREDECESSOR_TIMESTAMP - PREDECESSOR_TIMESTAMP is the pedecessor_timestamp (now value minus - one minute) the michelson interpreter will use (e.g. + PREDECESSOR_TIMESTAMP is the predecessor_timestamp (now value + minus one minute) the Michelson interpreter will use (e.g. '2000-01-01T10:10:10Z') -s SYNTAX, --syntax=SYNTAX (absent=auto) SYNTAX is the syntax that will be used. Currently supported - syntaxes are "pascaligo" and "cameligo". By default, the syntax is - guessed from the extension (.ligo and .mligo, respectively). + syntaxes are "pascaligo", "cameligo" and "reasonligo". By default, + the syntax is guessed from the extension (.ligo, .mligo, .religo + respectively). --sender=SENDER - SENDER is the sender the michelson interpreter transaction will + SENDER is the sender the Michelson interpreter transaction will use. --source=SOURCE - SOURCE is the source the michelson interpreter transaction will + SOURCE is the source the Michelson interpreter transaction will use. --version @@ -393,7 +393,7 @@ let%expect_test _ = run_ligo_good [ "run-function" ; "--help" ] ; [%expect {| NAME - ligo-run-function - Subcommand: run a function with the given + ligo-run-function - Subcommand: Run a function with the given parameter. SYNOPSIS @@ -408,12 +408,11 @@ let%expect_test _ = PARAMETER_EXPRESSION is the expression that will be compiled. SOURCE_FILE (required) - SOURCE_FILE is the path to the .ligo or .mligo file of the - contract. + SOURCE_FILE is the path to the smart contract file. OPTIONS --amount=AMOUNT (absent=0) - AMOUNT is the amount the michelson interpreter will use. + AMOUNT is the amount the Michelson interpreter will use. --format=DISPLAY_FORMAT, --display-format=DISPLAY_FORMAT (absent=human-readable) @@ -429,21 +428,22 @@ let%expect_test _ = `plain' whenever the TERM env var is `dumb' or undefined. --predecessor-timestamp=PREDECESSOR_TIMESTAMP - PREDECESSOR_TIMESTAMP is the pedecessor_timestamp (now value minus - one minute) the michelson interpreter will use (e.g. + PREDECESSOR_TIMESTAMP is the predecessor_timestamp (now value + minus one minute) the Michelson interpreter will use (e.g. '2000-01-01T10:10:10Z') -s SYNTAX, --syntax=SYNTAX (absent=auto) SYNTAX is the syntax that will be used. Currently supported - syntaxes are "pascaligo" and "cameligo". By default, the syntax is - guessed from the extension (.ligo and .mligo, respectively). + syntaxes are "pascaligo", "cameligo" and "reasonligo". By default, + the syntax is guessed from the extension (.ligo, .mligo, .religo + respectively). --sender=SENDER - SENDER is the sender the michelson interpreter transaction will + SENDER is the sender the Michelson interpreter transaction will use. --source=SOURCE - SOURCE is the source the michelson interpreter transaction will + SOURCE is the source the Michelson interpreter transaction will use. --version @@ -452,7 +452,7 @@ let%expect_test _ = run_ligo_good [ "evaluate-value" ; "--help" ] ; [%expect {| NAME - ligo-evaluate-value - Subcommand: evaluate a given definition. + ligo-evaluate-value - Subcommand: Evaluate a given definition. SYNOPSIS ligo evaluate-value [OPTION]... SOURCE_FILE ENTRY_POINT @@ -462,12 +462,11 @@ let%expect_test _ = ENTRY_POINT is entry-point that will be compiled. SOURCE_FILE (required) - SOURCE_FILE is the path to the .ligo or .mligo file of the - contract. + SOURCE_FILE is the path to the smart contract file. OPTIONS --amount=AMOUNT (absent=0) - AMOUNT is the amount the michelson interpreter will use. + AMOUNT is the amount the Michelson interpreter will use. --format=DISPLAY_FORMAT, --display-format=DISPLAY_FORMAT (absent=human-readable) @@ -483,21 +482,22 @@ let%expect_test _ = `plain' whenever the TERM env var is `dumb' or undefined. --predecessor-timestamp=PREDECESSOR_TIMESTAMP - PREDECESSOR_TIMESTAMP is the pedecessor_timestamp (now value minus - one minute) the michelson interpreter will use (e.g. + PREDECESSOR_TIMESTAMP is the predecessor_timestamp (now value + minus one minute) the Michelson interpreter will use (e.g. '2000-01-01T10:10:10Z') -s SYNTAX, --syntax=SYNTAX (absent=auto) SYNTAX is the syntax that will be used. Currently supported - syntaxes are "pascaligo" and "cameligo". By default, the syntax is - guessed from the extension (.ligo and .mligo, respectively). + syntaxes are "pascaligo", "cameligo" and "reasonligo". By default, + the syntax is guessed from the extension (.ligo, .mligo, .religo + respectively). --sender=SENDER - SENDER is the sender the michelson interpreter transaction will + SENDER is the sender the Michelson interpreter transaction will use. --source=SOURCE - SOURCE is the source the michelson interpreter transaction will + SOURCE is the source the Michelson interpreter transaction will use. --version @@ -506,7 +506,7 @@ let%expect_test _ = run_ligo_good [ "compile-expression" ; "--help" ] ; [%expect {| NAME - ligo-compile-expression - Subcommand: compile to a michelson value. + ligo-compile-expression - Subcommand: Compile to a michelson value. SYNOPSIS ligo compile-expression [OPTION]... SYNTAX _EXPRESSION @@ -517,8 +517,9 @@ let%expect_test _ = SYNTAX (required) SYNTAX is the syntax that will be used. Currently supported - syntaxes are "pascaligo" and "cameligo". By default, the syntax is - guessed from the extension (.ligo and .mligo, respectively). + syntaxes are "pascaligo", "cameligo" and "reasonligo". By default, + the syntax is guessed from the extension (.ligo, .mligo, .religo + respectively). OPTIONS --format=DISPLAY_FORMAT, --display-format=DISPLAY_FORMAT diff --git a/src/bin/expect_tests/lexer_tests.ml b/src/bin/expect_tests/lexer_tests.ml index 99c75f077..561346f5e 100644 --- a/src/bin/expect_tests/lexer_tests.ml +++ b/src/bin/expect_tests/lexer_tests.ml @@ -3,9 +3,10 @@ open Cli_expect let%expect_test _ = run_ligo_bad [ "compile-contract" ; "../../test/lexer/broken_string.ligo" ; "main" ] ; [%expect {| -ligo: lexer error: The string starting here is interrupted by a line break. +ligo: : Lexical error in file "broken_string.ligo", line 1, characters 18-19: + The string starting here is interrupted by a line break. Hint: Remove the break, close the string before or insert a backslash. - {"parser_loc":"in file \"broken_string.ligo\", line 1, characters 18-19"} + {} If you're not sure how to fix this error, you can @@ -19,9 +20,10 @@ ligo: lexer error: The string starting here is interrupted by a line break. run_ligo_bad [ "compile-contract" ; "../../test/lexer/broken_string.mligo" ; "main" ] ; [%expect {| -ligo: lexer error: The string starting here is interrupted by a line break. +ligo: : Lexical error in file "broken_string.mligo", line 1, characters 8-9: + The string starting here is interrupted by a line break. Hint: Remove the break, close the string before or insert a backslash. - {"parser_loc":"in file \"broken_string.mligo\", line 1, characters 8-9"} + {} If you're not sure how to fix this error, you can @@ -35,9 +37,10 @@ ligo: lexer error: The string starting here is interrupted by a line break. run_ligo_bad [ "compile-contract" ; "../../test/lexer/broken_string.religo" ; "main" ] ; [%expect {| -ligo: lexer error: The string starting here is interrupted by a line break. +ligo: : Lexical error in file "broken_string.religo", line 1, characters 8-9: + The string starting here is interrupted by a line break. Hint: Remove the break, close the string before or insert a backslash. - {"parser_loc":"in file \"broken_string.religo\", line 1, characters 8-9"} + {} If you're not sure how to fix this error, you can @@ -51,9 +54,10 @@ ligo: lexer error: The string starting here is interrupted by a line break. run_ligo_bad [ "compile-contract" ; "../../test/lexer/negative_byte_sequence.ligo" ; "main" ] ; [%expect {| -ligo: lexer error: Negative byte sequence. +ligo: : Lexical error in file "negative_byte_sequence.ligo", line 1, characters 18-23: + Negative byte sequence. Hint: Remove the leading minus sign. - {"parser_loc":"in file \"negative_byte_sequence.ligo\", line 1, characters 18-23"} + {} If you're not sure how to fix this error, you can @@ -67,9 +71,10 @@ ligo: lexer error: Negative byte sequence. run_ligo_bad [ "compile-contract" ; "../../test/lexer/negative_byte_sequence.mligo" ; "main" ] ; [%expect {| -ligo: lexer error: Negative byte sequence. +ligo: : Lexical error in file "negative_byte_sequence.mligo", line 1, characters 8-13: + Negative byte sequence. Hint: Remove the leading minus sign. - {"parser_loc":"in file \"negative_byte_sequence.mligo\", line 1, characters 8-13"} + {} If you're not sure how to fix this error, you can @@ -83,9 +88,10 @@ ligo: lexer error: Negative byte sequence. run_ligo_bad [ "compile-contract" ; "../../test/lexer/negative_byte_sequence.religo" ; "main" ] ; [%expect {| -ligo: lexer error: Negative byte sequence. +ligo: : Lexical error in file "negative_byte_sequence.religo", line 1, characters 8-13: + Negative byte sequence. Hint: Remove the leading minus sign. - {"parser_loc":"in file \"negative_byte_sequence.religo\", line 1, characters 8-13"} + {} If you're not sure how to fix this error, you can @@ -99,9 +105,10 @@ ligo: lexer error: Negative byte sequence. run_ligo_bad [ "compile-contract" ; "../../test/lexer/reserved_name.ligo" ; "main" ] ; [%expect {| -ligo: lexer error: Reserved name: arguments. +ligo: : Lexical error in file "reserved_name.ligo", line 1, characters 4-13: + Reserved name: arguments. Hint: Change the name. - {"parser_loc":"in file \"reserved_name.ligo\", line 1, characters 4-13"} + {} If you're not sure how to fix this error, you can @@ -115,9 +122,10 @@ ligo: lexer error: Reserved name: arguments. run_ligo_bad [ "compile-contract" ; "../../test/lexer/reserved_name.religo" ; "main" ] ; [%expect {| -ligo: lexer error: Reserved name: end. +ligo: : Lexical error in file "reserved_name.religo", line 1, characters 4-7: + Reserved name: end. Hint: Change the name. - {"parser_loc":"in file \"reserved_name.religo\", line 1, characters 4-7"} + {} If you're not sure how to fix this error, you can @@ -131,9 +139,10 @@ ligo: lexer error: Reserved name: end. run_ligo_bad [ "compile-contract" ; "../../test/lexer/reserved_name.mligo" ; "main" ] ; [%expect {| -ligo: lexer error: Reserved name: object. +ligo: : Lexical error in file "reserved_name.mligo", line 1, characters 4-10: + Reserved name: object. Hint: Change the name. - {"parser_loc":"in file \"reserved_name.mligo\", line 1, characters 4-10"} + {} If you're not sure how to fix this error, you can @@ -147,8 +156,9 @@ ligo: lexer error: Reserved name: object. run_ligo_bad [ "compile-contract" ; "../../test/lexer/unexpected_character.ligo" ; "main" ] ; [%expect {| -ligo: lexer error: Unexpected character '\239'. - {"parser_loc":"in file \"unexpected_character.ligo\", line 1, characters 18-19"} +ligo: : Lexical error in file "unexpected_character.ligo", line 1, characters 18-19: + Unexpected character '\239'. + {} If you're not sure how to fix this error, you can @@ -162,8 +172,9 @@ ligo: lexer error: Unexpected character '\239'. run_ligo_bad [ "compile-contract" ; "../../test/lexer/unexpected_character.mligo" ; "main" ] ; [%expect {| -ligo: lexer error: Unexpected character '\239'. - {"parser_loc":"in file \"unexpected_character.mligo\", line 1, characters 8-9"} +ligo: : Lexical error in file "unexpected_character.mligo", line 1, characters 8-9: + Unexpected character '\239'. + {} If you're not sure how to fix this error, you can @@ -177,8 +188,9 @@ ligo: lexer error: Unexpected character '\239'. run_ligo_bad [ "compile-contract" ; "../../test/lexer/unexpected_character.religo" ; "main" ] ; [%expect {| -ligo: lexer error: Unexpected character '\239'. - {"parser_loc":"in file \"unexpected_character.religo\", line 1, characters 8-9"} +ligo: : Lexical error in file "unexpected_character.religo", line 1, characters 8-9: + Unexpected character '\239'. + {} If you're not sure how to fix this error, you can @@ -192,9 +204,10 @@ ligo: lexer error: Unexpected character '\239'. run_ligo_bad [ "compile-contract" ; "../../test/lexer/unterminated_comment.mligo" ; "main" ] ; [%expect {| -ligo: lexer error: Unterminated comment. +ligo: : Lexical error in file "unterminated_comment.mligo", line 1, characters 0-2: + Unterminated comment. Hint: Close with "*)". - {"parser_loc":"in file \"unterminated_comment.mligo\", line 1, characters 0-2"} + {} If you're not sure how to fix this error, you can @@ -208,9 +221,10 @@ ligo: lexer error: Unterminated comment. run_ligo_bad [ "compile-contract" ; "../../test/lexer/invalid_symbol.ligo" ; "main" ] ; [%expect {| -ligo: lexer error: Invalid symbol. +ligo: : Lexical error in file "invalid_symbol.ligo", line 1, characters 17-20: + Invalid symbol. Hint: Check the LIGO syntax you use. - {"parser_loc":"in file \"invalid_symbol.ligo\", line 1, characters 17-20"} + {} If you're not sure how to fix this error, you can @@ -224,9 +238,10 @@ ligo: lexer error: Invalid symbol. run_ligo_bad [ "compile-contract" ; "../../test/lexer/invalid_symbol.mligo" ; "main" ] ; [%expect {| -ligo: lexer error: Invalid symbol. +ligo: : Lexical error in file "invalid_symbol.mligo", line 1, characters 10-13: + Invalid symbol. Hint: Check the LIGO syntax you use. - {"parser_loc":"in file \"invalid_symbol.mligo\", line 1, characters 10-13"} + {} If you're not sure how to fix this error, you can @@ -240,9 +255,10 @@ ligo: lexer error: Invalid symbol. run_ligo_bad [ "compile-contract" ; "../../test/lexer/invalid_symbol.religo" ; "main" ] ; [%expect {| -ligo: lexer error: Invalid symbol. +ligo: : Lexical error in file "invalid_symbol.religo", line 1, characters 10-11: + Invalid symbol. Hint: Check the LIGO syntax you use. - {"parser_loc":"in file \"invalid_symbol.religo\", line 1, characters 10-11"} + {} If you're not sure how to fix this error, you can @@ -256,9 +272,10 @@ ligo: lexer error: Invalid symbol. run_ligo_bad [ "compile-contract" ; "../../test/lexer/missing_break.ligo" ; "main" ] ; [%expect {| -ligo: lexer error: Missing break. +ligo: : Lexical error in file "missing_break.ligo", line 1, characters 18-18: + Missing break. Hint: Insert some space. - {"parser_loc":"in file \"missing_break.ligo\", line 1, characters 18-18"} + {} If you're not sure how to fix this error, you can @@ -272,9 +289,10 @@ ligo: lexer error: Missing break. run_ligo_bad [ "compile-contract" ; "../../test/lexer/missing_break.mligo" ; "main" ] ; [%expect {| -ligo: lexer error: Missing break. +ligo: : Lexical error in file "missing_break.mligo", line 1, characters 11-11: + Missing break. Hint: Insert some space. - {"parser_loc":"in file \"missing_break.mligo\", line 1, characters 11-11"} + {} If you're not sure how to fix this error, you can @@ -288,9 +306,10 @@ ligo: lexer error: Missing break. run_ligo_bad [ "compile-contract" ; "../../test/lexer/missing_break.religo" ; "main" ] ; [%expect {| -ligo: lexer error: Missing break. +ligo: : Lexical error in file "missing_break.religo", line 1, characters 11-11: + Missing break. Hint: Insert some space. - {"parser_loc":"in file \"missing_break.religo\", line 1, characters 11-11"} + {} If you're not sure how to fix this error, you can @@ -304,9 +323,10 @@ ligo: lexer error: Missing break. run_ligo_bad [ "compile-contract" ; "../../test/lexer/invalid_character_in_string.ligo" ; "main" ] ; [%expect {| -ligo: lexer error: Invalid character in string. +ligo: : Lexical error in file "invalid_character_in_string.ligo", line 1, characters 19-20: + Invalid character in string. Hint: Remove or replace the character. - {"parser_loc":"in file \"invalid_character_in_string.ligo\", line 1, characters 19-20"} + {} If you're not sure how to fix this error, you can @@ -320,9 +340,10 @@ ligo: lexer error: Invalid character in string. run_ligo_bad [ "compile-contract" ; "../../test/lexer/invalid_character_in_string.mligo" ; "main" ] ; [%expect {| -ligo: lexer error: Invalid character in string. +ligo: : Lexical error in file "invalid_character_in_string.mligo", line 1, characters 9-10: + Invalid character in string. Hint: Remove or replace the character. - {"parser_loc":"in file \"invalid_character_in_string.mligo\", line 1, characters 9-10"} + {} If you're not sure how to fix this error, you can @@ -336,9 +357,10 @@ ligo: lexer error: Invalid character in string. run_ligo_bad [ "compile-contract" ; "../../test/lexer/invalid_character_in_string.religo" ; "main" ] ; [%expect {| -ligo: lexer error: Invalid character in string. +ligo: : Lexical error in file "invalid_character_in_string.religo", line 1, characters 9-10: + Invalid character in string. Hint: Remove or replace the character. - {"parser_loc":"in file \"invalid_character_in_string.religo\", line 1, characters 9-10"} + {} If you're not sure how to fix this error, you can diff --git a/src/bin/expect_tests/syntax_error_tests.ml b/src/bin/expect_tests/syntax_error_tests.ml index 7082dbcf9..d3a735c3f 100644 --- a/src/bin/expect_tests/syntax_error_tests.ml +++ b/src/bin/expect_tests/syntax_error_tests.ml @@ -3,8 +3,8 @@ open Cli_expect let%expect_test _ = run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_syntax.ligo" ; "main" ] ; [%expect {| - ligo: parser error: Parse error at "-" from (1, 16) to (1, 17). In file "|../../test/contracts/negative/error_syntax.ligo" - {"parser_loc":"in file \"\", line 1, characters 16-17"} + ligo: : Parse error in file "error_syntax.ligo", line 1, characters 16-17, after "bar" and before "-". + {} If you're not sure how to fix this error, you can diff --git a/src/main/compile/helpers.ml b/src/main/compile/helpers.ml index b7daab8fe..95038a5b9 100644 --- a/src/main/compile/helpers.ml +++ b/src/main/compile/helpers.ml @@ -1,173 +1,171 @@ open Trace type s_syntax = Syntax_name of string -type v_syntax = Pascaligo | Cameligo | ReasonLIGO +type v_syntax = PascaLIGO | CameLIGO | ReasonLIGO -let syntax_to_variant : s_syntax -> string option -> v_syntax result = - fun syntax source_filename -> - let subr s n = - String.sub s (String.length s - n) n in - let endswith s suffix = - let suffixlen = String.length suffix in - ( String.length s >= suffixlen - && String.equal (subr s suffixlen) suffix) - in - let (Syntax_name syntax) = syntax in - match (syntax , source_filename) with - | "auto" , Some sf when endswith sf ".ligo" -> ok Pascaligo - | "auto" , Some sf when endswith sf ".mligo" -> ok Cameligo - | "auto" , Some sf when endswith sf ".religo" -> ok ReasonLIGO - | "auto" , _ -> simple_fail "cannot auto-detect syntax, pleas use -s name_of_syntax" - | "pascaligo" , _ -> ok Pascaligo - | "cameligo" , _ -> ok Cameligo - | "reasonligo", _ -> ok ReasonLIGO - | _ -> simple_fail "unrecognized parser" +let syntax_to_variant (Syntax_name syntax) source = + match syntax, source with + "auto", Some sf -> + (match Filename.extension sf with + ".ligo" | ".pligo" -> ok PascaLIGO + | ".mligo" -> ok CameLIGO + | ".religo" -> ok ReasonLIGO + | _ -> simple_fail "Cannot auto-detect the syntax.\n\ + Hint: Use -s \n") + | ("pascaligo" | "PascaLIGO"), _ -> ok PascaLIGO + | ("cameligo" | "CameLIGO"), _ -> ok CameLIGO + | ("reasonligo" | "ReasonLIGO"), _ -> ok ReasonLIGO + | _ -> simple_fail "Invalid syntax name.\n\ + Hint: Use \"pascaligo\", \"cameligo\" \ + or \"reasonligo\".\n" -let parsify_pascaligo = fun source -> +let parsify_pascaligo source = let%bind raw = trace (simple_error "parsing") @@ Parser.Pascaligo.parse_file source in let%bind simplified = trace (simple_error "simplifying") @@ - Simplify.Pascaligo.simpl_program raw in - ok simplified + Simplify.Pascaligo.simpl_program raw + in ok simplified -let parsify_expression_pascaligo = fun source -> +let parsify_expression_pascaligo source = let%bind raw = trace (simple_error "parsing expression") @@ Parser.Pascaligo.parse_expression source in let%bind simplified = trace (simple_error "simplifying expression") @@ - Simplify.Pascaligo.simpl_expression raw in - ok simplified + Simplify.Pascaligo.simpl_expression raw + in ok simplified -let parsify_cameligo = fun source -> +let parsify_cameligo source = let%bind raw = trace (simple_error "parsing") @@ Parser.Cameligo.parse_file source in let%bind simplified = trace (simple_error "simplifying") @@ - Simplify.Cameligo.simpl_program raw in - ok simplified + Simplify.Cameligo.simpl_program raw + in ok simplified -let parsify_expression_cameligo = fun source -> +let parsify_expression_cameligo source = let%bind raw = trace (simple_error "parsing expression") @@ Parser.Cameligo.parse_expression source in let%bind simplified = trace (simple_error "simplifying expression") @@ - Simplify.Cameligo.simpl_expression raw in - ok simplified + Simplify.Cameligo.simpl_expression raw + in ok simplified -let parsify_reasonligo = fun source -> +let parsify_reasonligo source = let%bind raw = trace (simple_error "parsing") @@ Parser.Reasonligo.parse_file source in let%bind simplified = trace (simple_error "simplifying") @@ - Simplify.Cameligo.simpl_program raw in - ok simplified + Simplify.Cameligo.simpl_program raw + in ok simplified -let parsify_expression_reasonligo = fun source -> +let parsify_expression_reasonligo source = let%bind raw = trace (simple_error "parsing expression") @@ Parser.Reasonligo.parse_expression source in let%bind simplified = trace (simple_error "simplifying expression") @@ - Simplify.Cameligo.simpl_expression raw in - ok simplified + Simplify.Cameligo.simpl_expression raw + in ok simplified -let parsify = fun (syntax : v_syntax) source_filename -> - let%bind parsify = match syntax with - | Pascaligo -> ok parsify_pascaligo - | Cameligo -> ok parsify_cameligo - | ReasonLIGO -> ok parsify_reasonligo - in - let%bind parsified = parsify source_filename in - let%bind applied = Self_ast_simplified.all_program parsified in - ok applied - -let parsify_expression = fun syntax source -> - let%bind parsify = match syntax with - | Pascaligo -> ok parsify_expression_pascaligo - | Cameligo -> ok parsify_expression_cameligo - | ReasonLIGO -> ok parsify_expression_reasonligo - in +let parsify syntax source = + let%bind parsify = + match syntax with + PascaLIGO -> ok parsify_pascaligo + | CameLIGO -> ok parsify_cameligo + | ReasonLIGO -> ok parsify_reasonligo in let%bind parsified = parsify source in - let%bind applied = Self_ast_simplified.all_expression parsified in - ok applied + let%bind applied = Self_ast_simplified.all_program parsified + in ok applied -let parsify_string_reasonligo = fun source -> +let parsify_expression syntax source = + let%bind parsify = match syntax with + PascaLIGO -> ok parsify_expression_pascaligo + | CameLIGO -> ok parsify_expression_cameligo + | ReasonLIGO -> ok parsify_expression_reasonligo in + let%bind parsified = parsify source in + let%bind applied = Self_ast_simplified.all_expression parsified + in ok applied + +let parsify_string_reasonligo source = let%bind raw = trace (simple_error "parsing") @@ Parser.Reasonligo.parse_string source in let%bind simplified = trace (simple_error "simplifying") @@ - Simplify.Cameligo.simpl_program raw in - ok simplified + Simplify.Cameligo.simpl_program raw + in ok simplified -let parsify_string_pascaligo = fun source -> +let parsify_string_pascaligo source = let%bind raw = trace (simple_error "parsing") @@ Parser.Pascaligo.parse_string source in let%bind simplified = trace (simple_error "simplifying") @@ - Simplify.Pascaligo.simpl_program raw in - ok simplified + Simplify.Pascaligo.simpl_program raw + in ok simplified -let parsify_string_cameligo = fun source -> +let parsify_string_cameligo source = let%bind raw = trace (simple_error "parsing") @@ Parser.Cameligo.parse_string source in let%bind simplified = trace (simple_error "simplifying") @@ - Simplify.Cameligo.simpl_program raw in - ok simplified + Simplify.Cameligo.simpl_program raw + in ok simplified -let parsify_string = fun (syntax : v_syntax) source_filename -> - let%bind parsify = match syntax with - | Pascaligo -> ok parsify_string_pascaligo - | Cameligo -> ok parsify_string_cameligo - | ReasonLIGO -> ok parsify_string_reasonligo - in - let%bind parsified = parsify source_filename in - let%bind applied = Self_ast_simplified.all_program parsified in - ok applied +let parsify_string syntax source = + let%bind parsify = + match syntax with + PascaLIGO -> ok parsify_string_pascaligo + | CameLIGO -> ok parsify_string_cameligo + | ReasonLIGO -> ok parsify_string_reasonligo in + let%bind parsified = parsify source in + let%bind applied = Self_ast_simplified.all_program parsified + in ok applied -let pretty_print_pascaligo = fun source -> +let pretty_print_pascaligo source = let%bind ast = Parser.Pascaligo.parse_file source in let buffer = Buffer.create 59 in - let state = Parser_pascaligo.ParserLog.mk_state - ~offsets:true - ~mode:`Byte - ~buffer in + let state = + Parser_pascaligo.ParserLog.mk_state + ~offsets:true + ~mode:`Byte + ~buffer in Parser_pascaligo.ParserLog.pp_ast state ast; ok buffer -let pretty_print_cameligo = fun source -> +let pretty_print_cameligo source = let%bind ast = Parser.Cameligo.parse_file source in let buffer = Buffer.create 59 in - let state = Parser_cameligo.ParserLog.mk_state - ~offsets:true - ~mode:`Byte - ~buffer in + let state = (* TODO: Should flow from the CLI *) + Parser_cameligo.ParserLog.mk_state + ~offsets:true + ~mode:`Point + ~buffer in Parser.Cameligo.ParserLog.pp_ast state ast; ok buffer -let pretty_print_reasonligo = fun source -> +let pretty_print_reasonligo source = let%bind ast = Parser.Reasonligo.parse_file source in let buffer = Buffer.create 59 in - let state = Parser.Reasonligo.ParserLog.mk_state - ~offsets:true - ~mode:`Byte - ~buffer in + let state = (* TODO: Should flow from the CLI *) + Parser.Reasonligo.ParserLog.mk_state + ~offsets:true + ~mode:`Point + ~buffer in Parser.Reasonligo.ParserLog.pp_ast state ast; ok buffer -let pretty_print = fun syntax source_filename -> - let%bind v_syntax = syntax_to_variant syntax (Some source_filename) in - (match v_syntax with - | Pascaligo -> pretty_print_pascaligo - | Cameligo -> pretty_print_cameligo - | ReasonLIGO -> pretty_print_reasonligo) - source_filename +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 diff --git a/src/passes/1-parser/cameligo.ml b/src/passes/1-parser/cameligo.ml index d69da91b4..2cd218370 100644 --- a/src/passes/1-parser/cameligo.ml +++ b/src/passes/1-parser/cameligo.ml @@ -1,129 +1,180 @@ -open Trace - -module Parser = Parser_cameligo.Parser -module AST = Parser_cameligo.AST -module ParserLog = Parser_cameligo.ParserLog +module AST = Parser_cameligo.AST module LexToken = Parser_cameligo.LexToken -module Lexer = Lexer.Make(LexToken) +module Lexer = Lexer.Make(LexToken) +module Scoping = Parser_cameligo.Scoping +module Region = Simple_utils.Region +module ParErr = Parser_cameligo.ParErr +module SSet = Utils.String.Set -module Errors = struct +(* Mock IOs TODO: Fill them with CLI options *) - let lexer_error (e: Lexer.error AST.reg) = - let title () = "lexer error" in - let message () = Lexer.error_to_string e.value in - let data = [ - ("parser_loc", - fun () -> Format.asprintf "%a" Location.pp_lift @@ e.region - ) - ] in - error ~data title message +module type IO = + sig + val ext : string + val options : EvalOpt.options + end - let parser_error source (start: Lexing.position) (stop: Lexing.position) lexbuf = - let title () = "parser error" in - let file = if source = "" then - "" - else - Format.sprintf "In file \"%s|%s\"" start.pos_fname source - in - let str = Format.sprintf - "Parse error at \"%s\" from (%d, %d) to (%d, %d). %s\n" - (Lexing.lexeme lexbuf) - start.pos_lnum (start.pos_cnum - start.pos_bol) - stop.pos_lnum (stop.pos_cnum - stop.pos_bol) - file - in - let message () = str in - let loc = if start.pos_cnum = -1 then - Region.make - ~start:(Pos.min ~file:source) - ~stop:(Pos.from_byte stop) - else - Region.make - ~start:(Pos.from_byte start) - ~stop:(Pos.from_byte stop) - in - let data = - [ - ("parser_loc", - fun () -> Format.asprintf "%a" Location.pp_lift @@ loc - ) - ] - in - error ~data title message +module PreIO = + struct + let ext = ".ligo" + let pre_options = + EvalOpt.make ~libs:[] + ~verbose:SSet.empty + ~offsets:true + ~mode:`Point + ~cmd:EvalOpt.Quiet + ~mono:true + end - let unrecognized_error source (start: Lexing.position) (stop: Lexing.position) lexbuf = - let title () = "unrecognized error" in - let file = if source = "" then - "" - else - Format.sprintf "In file \"%s|%s\"" start.pos_fname source - in - let str = Format.sprintf - "Parse error at \"%s\" from (%d, %d) to (%d, %d). %s\n" - (Lexing.lexeme lexbuf) - start.pos_lnum (start.pos_cnum - start.pos_bol) - stop.pos_lnum (stop.pos_cnum - stop.pos_bol) - file - in - let message () = str in - let loc = Region.make - ~start:(Pos.from_byte start) - ~stop:(Pos.from_byte stop) - in - let data = [ - ("unrecognized_loc", - fun () -> Format.asprintf "%a" Location.pp_lift @@ loc - ) - ] in - error ~data title message +module Parser = + struct + type ast = AST.t + type expr = AST.expr + include Parser_cameligo.Parser + end -end +module ParserLog = + struct + type ast = AST.t + type expr = AST.expr + include Parser_cameligo.ParserLog + end -open Errors +module PreUnit = + ParserUnit.Make (Lexer)(AST)(Parser)(ParErr)(ParserLog) -type 'a parser = (Lexing.lexbuf -> LexToken.token) -> Lexing.lexbuf -> 'a +module Errors = + struct + (* let data = + [("location", + fun () -> Format.asprintf "%a" Location.pp_lift @@ loc)] *) -let parse (parser: 'a parser) source lexbuf = - let Lexer.{read ; close ; _} = Lexer.open_token_stream None in - let result = - try - ok (parser read lexbuf) - with - | Parser.Error -> - let start = Lexing.lexeme_start_p lexbuf in - let stop = Lexing.lexeme_end_p lexbuf in - fail @@ (parser_error source start stop lexbuf) - | Lexer.Error e -> - fail @@ (lexer_error e) - | _ -> - let _ = Printexc.print_backtrace Pervasives.stdout in - let start = Lexing.lexeme_start_p lexbuf in - let stop = Lexing.lexeme_end_p lexbuf in - fail @@ (unrecognized_error source start stop lexbuf) - in - close (); - result + let generic message = + let title () = "" + and message () = message.Region.value + in Trace.error ~data:[] title message + end -let parse_file (source: string) : AST.t result = +let parse (module IO : IO) parser = + let module Unit = PreUnit (IO) in + let local_fail error = + Trace.fail + @@ Errors.generic + @@ Unit.format_error ~offsets:IO.options#offsets + IO.options#mode error in + match parser () with + Stdlib.Ok semantic_value -> Trace.ok semantic_value + + (* Lexing and parsing errors *) + + | Stdlib.Error error -> Trace.fail @@ Errors.generic error + (* Scoping errors *) + + | exception Scoping.Error (Scoping.Reserved_name name) -> + let token = + Lexer.Token.mk_ident name.Region.value name.Region.region in + (match token with + Stdlib.Error LexToken.Reserved_name -> + Trace.fail @@ Errors.generic @@ Region.wrap_ghost "Reserved name." + | Ok invalid -> + local_fail + ("Reserved name.\nHint: Change the name.\n", None, invalid)) + + | exception Scoping.Error (Scoping.Duplicate_variant name) -> + let token = + Lexer.Token.mk_constr name.Region.value name.Region.region + in local_fail + ("Duplicate constructor in this sum type declaration.\n\ + Hint: Change the constructor.\n", None, token) + + | exception Scoping.Error (Scoping.Non_linear_pattern var) -> + let token = + Lexer.Token.mk_ident var.Region.value var.Region.region in + (match token with + Stdlib.Error LexToken.Reserved_name -> + Trace.fail @@ Errors.generic @@ Region.wrap_ghost "Reserved name." + | Ok invalid -> + local_fail ("Repeated variable in this pattern.\n\ + Hint: Change the name.\n", + None, invalid)) + + | exception Scoping.Error (Scoping.Duplicate_field name) -> + let token = + Lexer.Token.mk_ident name.Region.value name.Region.region in + (match token with + Stdlib.Error LexToken.Reserved_name -> + Trace.fail @@ Errors.generic @@ Region.wrap_ghost "Reserved name." + | Ok invalid -> + local_fail + ("Duplicate field name in this record declaration.\n\ + Hint: Change the name.\n", + None, invalid)) + +let parse_file (source: string) = + let module IO = + struct + let ext = PreIO.ext + let options = + PreIO.pre_options ~input:(Some source) ~expr:false + end in + let lib_path = + match IO.options#libs with + [] -> "" + | libs -> let mk_I dir path = Printf.sprintf " -I %s%s" dir path + in List.fold_right mk_I libs "" in + let prefix = + match IO.options#input with + None | Some "-" -> "temp" + | Some file -> Filename.(remove_extension @@ basename file) in + let suffix = ".pp" ^ IO.ext in let pp_input = - let prefix = Filename.(source |> basename |> remove_extension) - and suffix = ".pp.mligo" - in prefix ^ suffix in - - let cpp_cmd = Printf.sprintf "cpp -traditional-cpp %s > %s" - source pp_input in + if SSet.mem "cpp" IO.options#verbose + then prefix ^ suffix + else let pp_input, pp_out = + Filename.open_temp_file prefix suffix + in close_out pp_out; pp_input in + let cpp_cmd = + match IO.options#input with + None | Some "-" -> + Printf.sprintf "cpp -traditional-cpp%s - > %s" + lib_path pp_input + | Some file -> + Printf.sprintf "cpp -traditional-cpp%s %s > %s" + lib_path file pp_input in + let open Trace in let%bind () = sys_command cpp_cmd in + let module Unit = PreUnit (IO) in + match Lexer.(open_token_stream @@ File pp_input) with + Ok instance -> + let thunk () = Unit.apply instance Unit.parse_contract + in parse (module IO) thunk + | Stdlib.Error (Lexer.File_opening msg) -> + Trace.fail @@ Errors.generic @@ Region.wrap_ghost msg - let%bind channel = - generic_try (simple_error "error opening file") @@ - (fun () -> open_in pp_input) in - let lexbuf = Lexing.from_channel channel in - parse (Parser.contract) source lexbuf +let parse_string (s: string) = + let module IO = + struct + let ext = PreIO.ext + let options = PreIO.pre_options ~input:None ~expr:false + end in + let module Unit = PreUnit (IO) in + match Lexer.(open_token_stream @@ String s) with + Ok instance -> + let thunk () = Unit.apply instance Unit.parse_contract + in parse (module IO) thunk + | Stdlib.Error (Lexer.File_opening msg) -> + Trace.fail @@ Errors.generic @@ Region.wrap_ghost msg -let parse_string (s:string) : AST.t result = - let lexbuf = Lexing.from_string s in - parse Parser.contract "" lexbuf - -let parse_expression (s:string) : AST.expr result = - let lexbuf = Lexing.from_string s in - parse Parser.interactive_expr "" lexbuf +let parse_expression (s: string) = + let module IO = + struct + let ext = PreIO.ext + let options = PreIO.pre_options ~input:None ~expr:true + end in + let module Unit = PreUnit (IO) in + match Lexer.(open_token_stream @@ String s) with + Ok instance -> + let thunk () = Unit.apply instance Unit.parse_expr + in parse (module IO) thunk + | Stdlib.Error (Lexer.File_opening msg) -> + Trace.fail @@ Errors.generic @@ Region.wrap_ghost msg diff --git a/src/passes/1-parser/cameligo/Parser.mly b/src/passes/1-parser/cameligo/Parser.mly index 8becc88f5..0901ab875 100644 --- a/src/passes/1-parser/cameligo/Parser.mly +++ b/src/passes/1-parser/cameligo/Parser.mly @@ -90,7 +90,7 @@ tuple(item): (* Possibly empty semicolon-separated values between brackets *) -list(item): +list__(item): "[" sep_or_term_list(item,";")? "]" { let compound = Brackets ($1,$3) and region = cover $1 $3 in @@ -182,7 +182,7 @@ sum_type: variant: "" { {$1 with value={constr=$1; arg=None}} } -| "" "of" cartesian { +| "" "of" fun_type { let region = cover $1.region (type_expr_to_region $3) and value = {constr=$1; arg = Some ($2,$3)} in {region; value} } @@ -217,6 +217,7 @@ let_declaration: let_binding: "" nseq(sub_irrefutable) type_annotation? "=" expr { + Scoping.check_reserved_name $1; let binders = Utils.nseq_cons (PVar $1) $2 in Utils.nseq_iter Scoping.check_pattern binders; {binders; lhs_type=$3; eq=$4; let_rhs=$5} @@ -293,7 +294,7 @@ core_pattern: | "false" { PFalse $1 } | "true" { PTrue $1 } | par(ptuple) { PPar $1 } -| list(tail) { PList (PListComp $1) } +| list__(tail) { PList (PListComp $1) } | constr_pattern { PConstr $1 } | record_pattern { PRecord $1 } @@ -584,7 +585,7 @@ core_expr: | unit { EUnit $1 } | "false" { ELogic (BoolExpr (False $1)) } | "true" { ELogic (BoolExpr (True $1)) } -| list(expr) { EList (EListComp $1) } +| list__(expr) { EList (EListComp $1) } | sequence { ESeq $1 } | record_expr { ERecord $1 } | update_record { EUpdate $1 } diff --git a/src/passes/1-parser/cameligo/ParserMain.ml b/src/passes/1-parser/cameligo/ParserMain.ml index 2880157db..9c481f178 100644 --- a/src/passes/1-parser/cameligo/ParserMain.ml +++ b/src/passes/1-parser/cameligo/ParserMain.ml @@ -27,12 +27,11 @@ module Unit = (* Main *) -let issue_error point = - let error = Unit.format_error ~offsets:IO.options#offsets - IO.options#mode point - in Stdlib.Error error +let issue_error error : ('a, string Region.reg) Stdlib.result = + Stdlib.Error (Unit.format_error ~offsets:IO.options#offsets + IO.options#mode error) -let parse parser : ('a,string) Stdlib.result = +let parse parser : ('a, string Region.reg) Stdlib.result = try parser () with (* Scoping errors *) @@ -81,11 +80,61 @@ let parse parser : ('a,string) Stdlib.result = None, invalid in issue_error point) +(* Preprocessing the input source with CPP *) + +module SSet = Utils.String.Set +let sprintf = Printf.sprintf + +(* Path for CPP inclusions (#include) *) + +let lib_path = + match IO.options#libs with + [] -> "" + | libs -> let mk_I dir path = sprintf " -I %s%s" dir path + in List.fold_right mk_I libs "" + +let prefix = + match IO.options#input with + None | Some "-" -> "temp" + | Some file -> Filename.(file |> basename |> remove_extension) + +let suffix = ".pp" ^ IO.ext + +let pp_input = + if SSet.mem "cpp" IO.options#verbose + then prefix ^ suffix + else let pp_input, pp_out = + Filename.open_temp_file prefix suffix + in close_out pp_out; pp_input + +let cpp_cmd = + match IO.options#input with + None | Some "-" -> + sprintf "cpp -traditional-cpp%s - > %s" + lib_path pp_input + | Some file -> + sprintf "cpp -traditional-cpp%s %s > %s" + lib_path file pp_input + let () = - if IO.options#expr - then match parse (fun () -> Unit.parse Unit.parse_expr) with - Stdlib.Ok _ -> () - | Error msg -> Printf.eprintf "\027[31m%s\027[0m%!" msg - else match parse (fun () -> Unit.parse Unit.parse_contract) with - Stdlib.Ok _ -> () - | Error msg -> Printf.eprintf "\027[31m%s\027[0m%!" msg + if Sys.command cpp_cmd <> 0 then + Printf.eprintf "External error: \"%s\" failed." cpp_cmd + +(* Instantiating the lexer and calling the parser *) + +let lexer_inst = + match Lexer.open_token_stream (Lexer.File pp_input) with + Ok instance -> + if IO.options#expr + then + match parse (fun () -> Unit.apply instance Unit.parse_expr) with + Stdlib.Ok _ -> () + | Error Region.{value; _} -> + Printf.eprintf "\027[31m%s\027[0m%!" value + else + (match parse (fun () -> Unit.apply instance Unit.parse_contract) with + Stdlib.Ok _ -> () + | Error Region.{value; _} -> + Printf.eprintf "\027[31m%s\027[0m%!" value) + | Stdlib.Error (Lexer.File_opening msg) -> + Printf.eprintf "\027[31m%s\027[0m%!" msg diff --git a/src/passes/1-parser/cameligo/Scoping.ml b/src/passes/1-parser/cameligo/Scoping.ml index 5f45c643b..483262deb 100644 --- a/src/passes/1-parser/cameligo/Scoping.ml +++ b/src/passes/1-parser/cameligo/Scoping.ml @@ -31,19 +31,30 @@ module VarSet = Set.Make (Ord) let reserved = let open SSet in empty + |> add "abs" + |> add "address" + |> add "amount" |> add "assert" |> add "balance" - |> add "time" - |> add "amount" - |> add "gas" - |> add "sender" - |> add "source" - |> add "failwith" + |> add "black2b" + |> add "check" |> add "continue" - |> add "stop" + |> add "failwith" + |> add "gas" + |> add "hash" + |> add "hash_key" + |> add "implicit_account" |> add "int" - |> add "abs" + |> add "pack" + |> add "self_address" + |> add "sender" + |> add "sha256" + |> add "sha512" + |> add "source" + |> add "stop" + |> add "time" |> add "unit" + |> add "unpack" let check_reserved_names vars = let is_reserved elt = SSet.mem elt.value reserved in diff --git a/src/passes/1-parser/cameligo/dune b/src/passes/1-parser/cameligo/dune index 57806ff56..a9139a2ec 100644 --- a/src/passes/1-parser/cameligo/dune +++ b/src/passes/1-parser/cameligo/dune @@ -15,17 +15,16 @@ (name parser_cameligo) (public_name ligo.parser.cameligo) (modules - Scoping AST cameligo Parser ParserLog LexToken) + Scoping AST cameligo Parser ParserLog LexToken ParErr) (libraries menhirLib parser_shared str simple-utils - tezos-utils - getopt) + tezos-utils) (preprocess (pps bisect_ppx --conditional)) - (flags (:standard -open Simple_utils -open Parser_shared))) + (flags (:standard -open Parser_shared -open Simple_utils))) ;; Build of the unlexer (for covering the ;; error states of the LR automaton) @@ -52,8 +51,7 @@ (executable (name ParserMain) (libraries parser_cameligo) - (modules - ParErr ParserMain) + (modules ParserMain) (preprocess (pps bisect_ppx --conditional)) (flags (:standard -open Simple_utils -open Parser_shared -open Parser_cameligo))) @@ -70,4 +68,4 @@ (rule (targets all.mligo) (deps (:script_cover ../../../../vendors/ligo-utils/simple-utils/cover.sh) Parser.mly LexToken.mli ParToken.mly Parser.msg Unlexer.exe) - (action (run %{script_cover} --lex-tokens=LexToken.mli --par-tokens=ParToken.mly --ext=mligo --unlexer=./Unlexer.exe --messages=Parser.msg --dir=. --concatenate Parser.mly ))) \ No newline at end of file + (action (run %{script_cover} --lex-tokens=LexToken.mli --par-tokens=ParToken.mly --ext=mligo --unlexer=./Unlexer.exe --messages=Parser.msg --dir=. --concatenate Parser.mly ))) diff --git a/src/passes/1-parser/pascaligo.ml b/src/passes/1-parser/pascaligo.ml index 59a7089d5..f3b63975c 100644 --- a/src/passes/1-parser/pascaligo.ml +++ b/src/passes/1-parser/pascaligo.ml @@ -1,154 +1,191 @@ -open Trace - -module AST = Parser_pascaligo.AST +module AST = Parser_pascaligo.AST module LexToken = Parser_pascaligo.LexToken -module Lexer = Lexer.Make(LexToken) -module Scoping = Parser_pascaligo.Scoping -module Parser = Parser_pascaligo.Parser +module Lexer = Lexer.Make(LexToken) +module Scoping = Parser_pascaligo.Scoping +module Region = Simple_utils.Region +module ParErr = Parser_pascaligo.ParErr +module SSet = Utils.String.Set + +(* Mock IOs TODO: Fill them with CLI options *) + +module type IO = + sig + val ext : string + val options : EvalOpt.options + end + +module PreIO = + struct + let ext = ".ligo" + let pre_options = + EvalOpt.make ~libs:[] + ~verbose:SSet.empty + ~offsets:true + ~mode:`Point + ~cmd:EvalOpt.Quiet + ~mono:true + end + +module Parser = + struct + type ast = AST.t + type expr = AST.expr + include Parser_pascaligo.Parser + end + +module ParserLog = + struct + type ast = AST.t + type expr = AST.expr + include Parser_pascaligo.ParserLog + end + +module PreUnit = + ParserUnit.Make (Lexer)(AST)(Parser)(ParErr)(ParserLog) module Errors = struct - let reserved_name Region.{value; region} = - let title () = Printf.sprintf "reserved name \"%s\"" value in - let message () = "" in - let data = [ - ("location", - fun () -> Format.asprintf "%a" Location.pp_lift @@ region)] - in error ~data title message + (* let data = + [("location", + fun () -> Format.asprintf "%a" Location.pp_lift @@ loc)] *) - let non_linear_pattern Region.{value; region} = - let title () = - Printf.sprintf "repeated variable \"%s\" in this pattern" value in - let message () = "" in - let data = [ - ("location", - fun () -> Format.asprintf "%a" Location.pp_lift @@ region)] - in error ~data title message + let generic message = + let title () = "" + and message () = message.Region.value + in Trace.error ~data:[] title message + end - let duplicate_parameter Region.{value; region} = - let title () = - Printf.sprintf "duplicate parameter \"%s\"" value in - let message () = "" in - let data = [ - ("location", - fun () -> Format.asprintf "%a" Location.pp_lift @@ region)] - in error ~data title message +let parse (module IO : IO) parser = + let module Unit = PreUnit (IO) in + let local_fail error = + Trace.fail + @@ Errors.generic + @@ Unit.format_error ~offsets:IO.options#offsets + IO.options#mode error in + match parser () with + Stdlib.Ok semantic_value -> Trace.ok semantic_value - let duplicate_variant Region.{value; region} = - let title () = - Printf.sprintf "duplicate variant \"%s\" in this\ - type declaration" value in - let message () = "" in - let data = [ - ("location", - fun () -> Format.asprintf "%a" Location.pp_lift @@ region)] - in error ~data title message + (* Lexing and parsing errors *) - let unrecognized_error source (start: Lexing.position) - (stop: Lexing.position) lexbuf = - let title () = "unrecognized error" in - let file = - if source = "" then "" - else - Format.sprintf "In file \"%s|%s\"" start.pos_fname source in - let message () = - Format.sprintf - "Parse error at \"%s\" from (%d, %d) to (%d, %d). %s\n" - (Lexing.lexeme lexbuf) - start.pos_lnum (start.pos_cnum - start.pos_bol) - stop.pos_lnum (stop.pos_cnum - stop.pos_bol) - file in - let loc = Region.make ~start:(Pos.from_byte start) - ~stop:(Pos.from_byte stop) in - let data = [ - ("unrecognized_loc", - fun () -> Format.asprintf "%a" Location.pp_lift @@ loc)] - in error ~data title message + | Stdlib.Error error -> Trace.fail @@ Errors.generic error + (* Scoping errors *) - let parser_error source (start: Lexing.position) - (stop: Lexing.position) lexbuf = - let title () = "parser error" in - let file = - if source = "" then "" - else - Format.sprintf "In file \"%s|%s\"" start.pos_fname source in - let message () = - Format.sprintf - "Parse error at \"%s\" from (%d, %d) to (%d, %d). %s\n" - (Lexing.lexeme lexbuf) - start.pos_lnum (start.pos_cnum - start.pos_bol) - stop.pos_lnum (stop.pos_cnum - stop.pos_bol) - file in - let loc = - if start.pos_cnum = -1 then - Region.make - ~start:(Pos.min ~file:source) ~stop:(Pos.from_byte stop) - else - Region.make ~start:(Pos.from_byte start) - ~stop:(Pos.from_byte stop) in - let data = - [("parser_loc", - fun () -> Format.asprintf "%a" Location.pp_lift @@ loc)] in - error ~data title message + | exception Scoping.Error (Scoping.Reserved_name name) -> + let token = + Lexer.Token.mk_ident name.Region.value name.Region.region in + (match token with + Stdlib.Error LexToken.Reserved_name -> + Trace.fail @@ Errors.generic @@ Region.wrap_ghost "Reserved name." + | Ok invalid -> + local_fail + ("Reserved name.\nHint: Change the name.\n", None, invalid)) - let lexer_error (e: Lexer.error AST.reg) = - let title () = "lexer error" in - let message () = Lexer.error_to_string e.value in - let data = [ - ("parser_loc", - fun () -> Format.asprintf "%a" Location.pp_lift @@ e.region)] - in error ~data title message -end + | exception Scoping.Error (Scoping.Duplicate_parameter name) -> + let token = + Lexer.Token.mk_ident name.Region.value name.Region.region in + (match token with + Stdlib.Error LexToken.Reserved_name -> + Trace.fail @@ Errors.generic @@ Region.wrap_ghost "Reserved name." + | Ok invalid -> + local_fail + ("Duplicate parameter.\nHint: Change the name.\n", + None, invalid)) -open Errors + | exception Scoping.Error (Scoping.Duplicate_variant name) -> + let token = + Lexer.Token.mk_constr name.Region.value name.Region.region + in local_fail + ("Duplicate constructor in this sum type declaration.\n\ + Hint: Change the constructor.\n", None, token) -type 'a parser = (Lexing.lexbuf -> LexToken.token) -> Lexing.lexbuf -> 'a + | exception Scoping.Error (Scoping.Non_linear_pattern var) -> + let token = + Lexer.Token.mk_ident var.Region.value var.Region.region in + (match token with + Stdlib.Error LexToken.Reserved_name -> + Trace.fail @@ Errors.generic @@ Region.wrap_ghost "Reserved name." + | Ok invalid -> + local_fail ("Repeated variable in this pattern.\n\ + Hint: Change the name.\n", + None, invalid)) -let parse (parser: 'a parser) source lexbuf = - let Lexer.{read; close; _} = Lexer.open_token_stream None in - let result = - try ok (parser read lexbuf) with - Lexer.Error e -> - fail @@ lexer_error e - | Parser.Error -> - let start = Lexing.lexeme_start_p lexbuf in - let stop = Lexing.lexeme_end_p lexbuf in - fail @@ parser_error source start stop lexbuf - | Scoping.Error (Scoping.Non_linear_pattern var) -> - fail @@ non_linear_pattern var - | Scoping.Error (Duplicate_parameter name) -> - fail @@ duplicate_parameter name - | Scoping.Error (Duplicate_variant name) -> - fail @@ duplicate_variant name - | Scoping.Error (Reserved_name name) -> - fail @@ reserved_name name - | _ -> - let () = Printexc.print_backtrace Pervasives.stdout in - let start = Lexing.lexeme_start_p lexbuf in - let stop = Lexing.lexeme_end_p lexbuf in - fail @@ unrecognized_error source start stop lexbuf - in close (); result + | exception Scoping.Error (Scoping.Duplicate_field name) -> + let token = + Lexer.Token.mk_ident name.Region.value name.Region.region in + (match token with + Stdlib.Error LexToken.Reserved_name -> + Trace.fail @@ Errors.generic @@ Region.wrap_ghost "Reserved name." + | Ok invalid -> + local_fail + ("Duplicate field name in this record declaration.\n\ + Hint: Change the name.\n", + None, invalid)) -let parse_file (source: string) : AST.t result = +let parse_file source = + let module IO = + struct + let ext = PreIO.ext + let options = + PreIO.pre_options ~input:(Some source) ~expr:false + end in + let module Unit = PreUnit (IO) in + let lib_path = + match IO.options#libs with + [] -> "" + | libs -> let mk_I dir path = Printf.sprintf " -I %s%s" dir path + in List.fold_right mk_I libs "" in + let prefix = + match IO.options#input with + None | Some "-" -> "temp" + | Some file -> Filename.(remove_extension @@ basename file) in + let suffix = ".pp" ^ IO.ext in let pp_input = - let prefix = Filename.(source |> basename |> remove_extension) - and suffix = ".pp.ligo" - in prefix ^ suffix in - - let cpp_cmd = Printf.sprintf "cpp -traditional-cpp %s > %s" - source pp_input in + if SSet.mem "cpp" IO.options#verbose + then prefix ^ suffix + else let pp_input, pp_out = + Filename.open_temp_file prefix suffix + in close_out pp_out; pp_input in + let cpp_cmd = + match IO.options#input with + None | Some "-" -> + Printf.sprintf "cpp -traditional-cpp%s - > %s" + lib_path pp_input + | Some file -> + Printf.sprintf "cpp -traditional-cpp%s %s > %s" + lib_path file pp_input in + let open Trace in let%bind () = sys_command cpp_cmd in + match Lexer.(open_token_stream @@ File pp_input) with + Ok instance -> + let thunk () = Unit.apply instance Unit.parse_contract + in parse (module IO) thunk + | Stdlib.Error (Lexer.File_opening msg) -> + Trace.fail @@ Errors.generic @@ Region.wrap_ghost msg - let%bind channel = - generic_try (simple_error "error opening file") @@ - (fun () -> open_in pp_input) in - let lexbuf = Lexing.from_channel channel in - parse (Parser.contract) source lexbuf +let parse_string (s: string) = + let module IO = + struct + let ext = PreIO.ext + let options = PreIO.pre_options ~input:None ~expr:false + end in + let module Unit = PreUnit (IO) in + match Lexer.(open_token_stream @@ String s) with + Ok instance -> + let thunk () = Unit.apply instance Unit.parse_contract + in parse (module IO) thunk + | Stdlib.Error (Lexer.File_opening msg) -> + Trace.fail @@ Errors.generic @@ Region.wrap_ghost msg -let parse_string (s:string) : AST.t result = - let lexbuf = Lexing.from_string s in - parse (Parser.contract) "" lexbuf - -let parse_expression (s:string) : AST.expr result = - let lexbuf = Lexing.from_string s in - parse (Parser.interactive_expr) "" lexbuf +let parse_expression (s: string) = + let module IO = + struct + let ext = PreIO.ext + let options = PreIO.pre_options ~input:None ~expr:true + end in + let module Unit = PreUnit (IO) in + match Lexer.(open_token_stream @@ String s) with + Ok instance -> + let thunk () = Unit.apply instance Unit.parse_expr + in parse (module IO) thunk + | Stdlib.Error (Lexer.File_opening msg) -> + Trace.fail @@ Errors.generic @@ Region.wrap_ghost msg diff --git a/src/passes/1-parser/pascaligo/.links b/src/passes/1-parser/pascaligo/.links index 6cc2d4c32..831099d9e 100644 --- a/src/passes/1-parser/pascaligo/.links +++ b/src/passes/1-parser/pascaligo/.links @@ -17,6 +17,7 @@ $HOME/git/ligo/vendors/ligo-utils/simple-utils/region.ml ../shared/Utils.ml ../shared/ParserAPI.mli ../shared/ParserAPI.ml +../shared/LexerUnit.mli ../shared/LexerUnit.ml ../shared/ParserUnit.mli ../shared/ParserUnit.ml diff --git a/src/passes/1-parser/pascaligo/LexerMain.ml b/src/passes/1-parser/pascaligo/LexerMain.ml index ba2925172..f02b06642 100644 --- a/src/passes/1-parser/pascaligo/LexerMain.ml +++ b/src/passes/1-parser/pascaligo/LexerMain.ml @@ -1,4 +1,6 @@ -(** Driver for the PascaLIGO lexer *) +(* Driver for the PascaLIGO lexer *) + +module Region = Simple_utils.Region module IO = struct diff --git a/src/passes/1-parser/pascaligo/Parser.mly b/src/passes/1-parser/pascaligo/Parser.mly index 55ac2262e..e5afdc3b5 100644 --- a/src/passes/1-parser/pascaligo/Parser.mly +++ b/src/passes/1-parser/pascaligo/Parser.mly @@ -141,23 +141,23 @@ type_decl: in {region; value} } type_expr: - sum_type | record_type | cartesian { $1 } + fun_type | sum_type | record_type { $1 } -cartesian: - function_type { $1 } -| function_type "*" nsepseq(function_type,"*") { - let value = Utils.nsepseq_cons $1 $2 $3 in - let region = nsepseq_to_region type_expr_to_region value - in TProd {region; value} } - -function_type: - core_type { $1 } -| core_type "->" function_type { +fun_type: + cartesian { $1 } +| cartesian "->" fun_type { let start = type_expr_to_region $1 and stop = type_expr_to_region $3 in let region = cover start stop in TFun {region; value = $1,$2,$3} } +cartesian: + core_type { $1 } +| core_type "*" nsepseq(core_type,"*") { + let value = Utils.nsepseq_cons $1 $2 $3 in + let region = nsepseq_to_region type_expr_to_region value + in TProd {region; value} } + core_type: type_name { TVar $1 } | par(type_expr) { TPar $1 } @@ -201,7 +201,7 @@ sum_type: variant: "" { {$1 with value = {constr=$1; arg=None}} } -| "" "of" cartesian { +| "" "of" fun_type { let region = cover $1.region (type_expr_to_region $3) and value = {constr=$1; arg = Some ($2,$3)} in {region; value} } @@ -315,7 +315,7 @@ param_decl: in ParamConst {region; value} } param_type: - cartesian { $1 } + fun_type { $1 } block: "begin" sep_or_term_list(statement,";") "end" { diff --git a/src/passes/1-parser/pascaligo/ParserMain.ml b/src/passes/1-parser/pascaligo/ParserMain.ml index 9b2cc2f28..464094f85 100644 --- a/src/passes/1-parser/pascaligo/ParserMain.ml +++ b/src/passes/1-parser/pascaligo/ParserMain.ml @@ -1,4 +1,4 @@ -(** Driver for the PascaLIGO parser *) +(* Driver for the PascaLIGO parser *) module IO = struct @@ -27,12 +27,11 @@ module Unit = (* Main *) -let issue_error point = - let error = Unit.format_error ~offsets:IO.options#offsets - IO.options#mode point - in Stdlib.Error error +let issue_error error : ('a, string Region.reg) Stdlib.result = + Stdlib.Error (Unit.format_error ~offsets:IO.options#offsets + IO.options#mode error) -let parse parser : ('a,string) Stdlib.result = +let parse parser : ('a, string Region.reg) Stdlib.result = try parser () with (* Scoping errors *) @@ -87,16 +86,67 @@ let parse parser : ('a,string) Stdlib.result = reserved name for the lexer. *) Stdlib.Error _ -> assert false | Ok invalid -> - let point = "Duplicate field name in this record declaration.\n\ - Hint: Change the name.\n", - None, invalid - in issue_error point) + let point = + "Duplicate field name in this record declaration.\n\ + Hint: Change the name.\n", + None, invalid + in issue_error point) + +(* Preprocessing the input source with CPP *) + +module SSet = Utils.String.Set +let sprintf = Printf.sprintf + +(* Path for CPP inclusions (#include) *) + +let lib_path = + match IO.options#libs with + [] -> "" + | libs -> let mk_I dir path = sprintf " -I %s%s" dir path + in List.fold_right mk_I libs "" + +let prefix = + match IO.options#input with + None | Some "-" -> "temp" + | Some file -> Filename.(file |> basename |> remove_extension) + +let suffix = ".pp" ^ IO.ext + +let pp_input = + if SSet.mem "cpp" IO.options#verbose + then prefix ^ suffix + else let pp_input, pp_out = + Filename.open_temp_file prefix suffix + in close_out pp_out; pp_input + +let cpp_cmd = + match IO.options#input with + None | Some "-" -> + sprintf "cpp -traditional-cpp%s - > %s" + lib_path pp_input + | Some file -> + sprintf "cpp -traditional-cpp%s %s > %s" + lib_path file pp_input let () = - if IO.options#expr - then match parse (fun () -> Unit.parse Unit.parse_expr) with - Stdlib.Ok _ -> () - | Error msg -> Printf.eprintf "\027[31m%s\027[0m%!" msg - else match parse (fun () -> Unit.parse Unit.parse_contract) with - Stdlib.Ok _ -> () - | Error msg -> Printf.eprintf "\027[31m%s\027[0m%!" msg + if Sys.command cpp_cmd <> 0 then + Printf.eprintf "External error: \"%s\" failed." cpp_cmd + +(* Instantiating the lexer and calling the parser *) + +let lexer_inst = + match Lexer.open_token_stream (Lexer.File pp_input) with + Ok instance -> + if IO.options#expr + then + match parse (fun () -> Unit.apply instance Unit.parse_expr) with + Stdlib.Ok _ -> () + | Error Region.{value; _} -> + Printf.eprintf "\027[31m%s\027[0m%!" value + else + (match parse (fun () -> Unit.apply instance Unit.parse_contract) with + Stdlib.Ok _ -> () + | Error Region.{value; _} -> + Printf.eprintf "\027[31m%s\027[0m%!" value) + | Stdlib.Error (Lexer.File_opening msg) -> + Printf.eprintf "\027[31m%s\027[0m%!" msg diff --git a/src/passes/1-parser/pascaligo/dune b/src/passes/1-parser/pascaligo/dune index 8ab2030cc..cbda30618 100644 --- a/src/passes/1-parser/pascaligo/dune +++ b/src/passes/1-parser/pascaligo/dune @@ -7,7 +7,7 @@ (menhir (merge_into Parser) (modules ParToken Parser) - (flags -la 1 --table --strict --external-tokens LexToken)) + (flags -la 1 --table --strict --explain --external-tokens LexToken)) ;; Build of the parser as a library @@ -20,8 +20,7 @@ menhirLib parser_shared hex - simple-utils - tezos-utils) + simple-utils) (preprocess (pps bisect_ppx --conditional)) (flags (:standard -open Parser_shared -open Simple_utils))) @@ -52,8 +51,7 @@ (executable (name ParserMain) (libraries parser_pascaligo) - (modules - ParserMain) + (modules ParserMain) (preprocess (pps bisect_ppx --conditional)) (flags (:standard -open Simple_utils -open Parser_shared -open Parser_pascaligo))) diff --git a/src/passes/1-parser/reasonligo.ml b/src/passes/1-parser/reasonligo.ml index c60a3367c..753750fc4 100644 --- a/src/passes/1-parser/reasonligo.ml +++ b/src/passes/1-parser/reasonligo.ml @@ -1,131 +1,191 @@ open Trace -module Parser = Parser_reasonligo.Parser -module AST = Parser_cameligo.AST -module ParserLog = Parser_cameligo.ParserLog -module LexToken = Parser_reasonligo.LexToken -module Lexer = Lexer.Make(LexToken) +module AST = Parser_cameligo.AST +module LexToken = Parser_reasonligo.LexToken +module Lexer = Lexer.Make(LexToken) +module Scoping = Parser_cameligo.Scoping +module Region = Simple_utils.Region +module ParErr = Parser_reasonligo.ParErr module SyntaxError = Parser_reasonligo.SyntaxError -module Scoping = Parser_cameligo.Scoping +module SSet = Utils.String.Set + +(* Mock IOs TODO: Fill them with CLI options *) + +module type IO = + sig + val ext : string + val options : EvalOpt.options + end + +module PreIO = + struct + let ext = ".ligo" + let pre_options = + EvalOpt.make ~libs:[] + ~verbose:SSet.empty + ~offsets:true + ~mode:`Point + ~cmd:EvalOpt.Quiet + ~mono:true + end + +module Parser = + struct + type ast = AST.t + type expr = AST.expr + include Parser_reasonligo.Parser + end + +module ParserLog = + struct + type ast = AST.t + type expr = AST.expr + include Parser_cameligo.ParserLog + end + +module PreUnit = + ParserUnit.Make (Lexer)(AST)(Parser)(ParErr)(ParserLog) module Errors = struct - let lexer_error (e: Lexer.error AST.reg) = - let title () = "lexer error" in - let message () = Lexer.error_to_string e.value in - let data = [ - ("parser_loc", - fun () -> Format.asprintf "%a" Location.pp_lift @@ e.region)] - in error ~data title message + let generic message = + let title () = "" + and message () = message.Region.value + in Trace.error ~data:[] title message - let wrong_function_arguments expr = - let title () = "wrong function arguments" in - let message () = "" in + let wrong_function_arguments (expr: AST.expr) = + let title () = "" in + let message () = "Wrong function arguments.\n" in let expression_loc = AST.expr_to_region expr in let data = [ - ("location", - fun () -> Format.asprintf "%a" Location.pp_lift @@ expression_loc)] + ("location", + fun () -> Format.asprintf "%a" Location.pp_lift @@ expression_loc)] in error ~data title message + end - let parser_error source (start: Lexing.position) - (end_: Lexing.position) lexbuf = - let title () = "parser error" in - let file = - if source = "" then "" - else - Format.sprintf "In file \"%s|%s\"" start.pos_fname source in - let str = - Format.sprintf - "Parse error at \"%s\" from (%d, %d) to (%d, %d). %s\n" - (Lexing.lexeme lexbuf) - start.pos_lnum (start.pos_cnum - start.pos_bol) - end_.pos_lnum (end_.pos_cnum - end_.pos_bol) - file in - let message () = str in - let loc = - if start.pos_cnum = -1 - then Region.make - ~start:(Pos.min ~file:source) - ~stop:(Pos.from_byte end_) - else Region.make - ~start:(Pos.from_byte start) - ~stop:(Pos.from_byte end_) in - let data = - [("parser_loc", - fun () -> Format.asprintf "%a" Location.pp_lift @@ loc)] - in error ~data title message +let parse (module IO : IO) parser = + let module Unit = PreUnit (IO) in + let local_fail error = + Trace.fail + @@ Errors.generic + @@ Unit.format_error ~offsets:IO.options#offsets + IO.options#mode error in + match parser () with + Stdlib.Ok semantic_value -> Trace.ok semantic_value - let unrecognized_error source (start: Lexing.position) (end_: Lexing.position) lexbuf = - let title () = "unrecognized error" in - let file = - if source = "" then "" - else - Format.sprintf "In file \"%s|%s\"" start.pos_fname source in - let str = - Format.sprintf - "Parse error at \"%s\" from (%d, %d) to (%d, %d). %s\n" - (Lexing.lexeme lexbuf) - start.pos_lnum (start.pos_cnum - start.pos_bol) - end_.pos_lnum (end_.pos_cnum - end_.pos_bol) - file in - let message () = str in - let loc = Region.make - ~start:(Pos.from_byte start) - ~stop:(Pos.from_byte end_) in - let data = [ - ("location", - fun () -> Format.asprintf "%a" Location.pp_lift @@ loc)] - in error ~data title message + (* Lexing and parsing errors *) -end + | Stdlib.Error error -> Trace.fail @@ Errors.generic error + (* Scoping errors *) -open Errors + | exception Scoping.Error (Scoping.Reserved_name name) -> + let token = + Lexer.Token.mk_ident name.Region.value name.Region.region in + (match token with + Stdlib.Error LexToken.Reserved_name -> + Trace.fail @@ Errors.generic @@ Region.wrap_ghost "Reserved name." + | Ok invalid -> + local_fail + ("Reserved name.\nHint: Change the name.\n", None, invalid)) -type 'a parser = (Lexing.lexbuf -> LexToken.token) -> Lexing.lexbuf -> 'a + | exception Scoping.Error (Scoping.Duplicate_variant name) -> + let token = + Lexer.Token.mk_constr name.Region.value name.Region.region + in local_fail + ("Duplicate constructor in this sum type declaration.\n\ + Hint: Change the constructor.\n", None, token) -let parse (parser: 'a parser) source lexbuf = - let Lexer.{read ; close ; _} = Lexer.open_token_stream None in - let result = - try - ok (parser read lexbuf) - with - | SyntaxError.Error (WrongFunctionArguments e) -> - fail @@ (wrong_function_arguments e) - | Parser.Error -> - let start = Lexing.lexeme_start_p lexbuf in - let end_ = Lexing.lexeme_end_p lexbuf in - fail @@ (parser_error source start end_ lexbuf) - | Lexer.Error e -> - fail @@ (lexer_error e) - | _ -> - let _ = Printexc.print_backtrace Pervasives.stdout in - let start = Lexing.lexeme_start_p lexbuf in - let end_ = Lexing.lexeme_end_p lexbuf in - fail @@ (unrecognized_error source start end_ lexbuf) - in - close (); - result + | exception Scoping.Error (Scoping.Non_linear_pattern var) -> + let token = + Lexer.Token.mk_ident var.Region.value var.Region.region in + (match token with + Stdlib.Error LexToken.Reserved_name -> + Trace.fail @@ Errors.generic @@ Region.wrap_ghost "Reserved name." + | Ok invalid -> + local_fail ("Repeated variable in this pattern.\n\ + Hint: Change the name.\n", + None, invalid)) -let parse_file (source: string) : AST.t result = + | exception Scoping.Error (Scoping.Duplicate_field name) -> + let token = + Lexer.Token.mk_ident name.Region.value name.Region.region in + (match token with + Stdlib.Error LexToken.Reserved_name -> + Trace.fail @@ Errors.generic @@ Region.wrap_ghost "Reserved name." + | Ok invalid -> + local_fail + ("Duplicate field name in this record declaration.\n\ + Hint: Change the name.\n", + None, invalid)) + + | exception SyntaxError.Error (SyntaxError.WrongFunctionArguments expr) -> + Trace.fail @@ Errors.wrong_function_arguments expr + +let parse_file (source: string) = + let module IO = + struct + let ext = PreIO.ext + let options = + PreIO.pre_options ~input:(Some source) ~expr:false + end in + let lib_path = + match IO.options#libs with + [] -> "" + | libs -> let mk_I dir path = Printf.sprintf " -I %s%s" dir path + in List.fold_right mk_I libs "" in + let prefix = + match IO.options#input with + None | Some "-" -> "temp" + | Some file -> Filename.(remove_extension @@ basename file) in + let suffix = ".pp" ^ IO.ext in let pp_input = - let prefix = Filename.(source |> basename |> remove_extension) - and suffix = ".pp.religo" - in prefix ^ suffix in - - let cpp_cmd = Printf.sprintf "cpp -traditional-cpp %s > %s" - source pp_input in + if SSet.mem "cpp" IO.options#verbose + then prefix ^ suffix + else let pp_input, pp_out = + Filename.open_temp_file prefix suffix + in close_out pp_out; pp_input in + let cpp_cmd = + match IO.options#input with + None | Some "-" -> + Printf.sprintf "cpp -traditional-cpp%s - > %s" + lib_path pp_input + | Some file -> + Printf.sprintf "cpp -traditional-cpp%s %s > %s" + lib_path file pp_input in + let open Trace in let%bind () = sys_command cpp_cmd in + let module Unit = PreUnit (IO) in + match Lexer.(open_token_stream @@ File pp_input) with + Ok instance -> + let thunk () = Unit.apply instance Unit.parse_contract + in parse (module IO) thunk + | Stdlib.Error (Lexer.File_opening msg) -> + Trace.fail @@ Errors.generic @@ Region.wrap_ghost msg - let%bind channel = - generic_try (simple_error "error opening file") @@ - (fun () -> open_in pp_input) in - let lexbuf = Lexing.from_channel channel in - parse (Parser.contract) source lexbuf +let parse_string (s: string) = + let module IO = + struct + let ext = PreIO.ext + let options = PreIO.pre_options ~input:None ~expr:false + end in + let module Unit = PreUnit (IO) in + match Lexer.(open_token_stream @@ String s) with + Ok instance -> + let thunk () = Unit.apply instance Unit.parse_contract + in parse (module IO) thunk + | Stdlib.Error (Lexer.File_opening msg) -> + Trace.fail @@ Errors.generic @@ Region.wrap_ghost msg -let parse_string (s:string) : AST.t result = - let lexbuf = Lexing.from_string s in - parse (Parser.contract) "" lexbuf - -let parse_expression (s:string) : AST.expr result = - let lexbuf = Lexing.from_string s in - parse (Parser.interactive_expr) "" lexbuf +let parse_expression (s: string) = + let module IO = + struct + let ext = PreIO.ext + let options = PreIO.pre_options ~input:None ~expr:true + end in + let module Unit = PreUnit (IO) in + match Lexer.(open_token_stream @@ String s) with + Ok instance -> + let thunk () = Unit.apply instance Unit.parse_expr + in parse (module IO) thunk + | Stdlib.Error (Lexer.File_opening msg) -> + Trace.fail @@ Errors.generic @@ Region.wrap_ghost msg diff --git a/src/passes/1-parser/reasonligo/Parser.mly b/src/passes/1-parser/reasonligo/Parser.mly index 142a29313..8c7fb65a6 100644 --- a/src/passes/1-parser/reasonligo/Parser.mly +++ b/src/passes/1-parser/reasonligo/Parser.mly @@ -24,6 +24,24 @@ type 'a sequence_or_record = let (<@) f g x = f (g x) +(** + Covert nsepseq to a chain of TFun's. + + Necessary to handle cases like: + `type foo = (int, int) => int;` +*) +let rec nsepseq_to_curry hd rest = + match hd, rest with + | hd, (sep, item) :: rest -> + let start = type_expr_to_region hd in + let stop = nsepseq_to_region type_expr_to_region (hd, rest) in + let region = cover start stop in + TFun { + value = hd, sep, (nsepseq_to_curry item rest); + region + } + | hd, [] -> hd + (* END HEADER *) %} @@ -119,7 +137,7 @@ tuple(item): (* Possibly empty semicolon-separated values between brackets *) -list(item): +list__(item): "[" sep_or_term_list(item,";")? "]" { let compound = Brackets ($1,$3) and region = cover $1 $3 in @@ -159,24 +177,40 @@ type_decl: type_expr: cartesian | sum_type | record_type { $1 } -cartesian: - fun_type { $1 } -| fun_type "," nsepseq(fun_type,",") { - let value = Utils.nsepseq_cons $1 $2 $3 in - let region = nsepseq_to_region type_expr_to_region value - in TProd {region; value} } +type_expr_func: + "=>" cartesian { + $1, $2 + } -fun_type: +cartesian: core_type { $1 } -| core_type "=>" fun_type { - let start = type_expr_to_region $1 - and stop = type_expr_to_region $3 in - let region = cover start stop in - TFun {region; value=$1,$2,$3} } +| type_name type_expr_func { + let (arrow, c) = $2 in + let value = TVar $1, arrow, c in + let region = cover $1.region (type_expr_to_region c) in + TFun { region; value } +} +| "(" cartesian ")" type_expr_func { + let (arrow, c) = $4 in + let value = $2, arrow, c in + let region = cover $1 (type_expr_to_region c) in + TFun { region; value } +} +| "(" cartesian "," nsepseq(cartesian,",") ")" type_expr_func? { + match $6 with + | Some (arrow, c) -> + let (hd, rest) = Utils.nsepseq_cons $2 $3 $4 in + let rest = rest @ [(arrow, c)] in + nsepseq_to_curry hd rest + | None -> + let value = Utils.nsepseq_cons $2 $3 $4 in + let region = cover $1 $5 in + TProd {region; value} + } core_type: type_name { TVar $1 } -| par(type_expr) { TPar $1 } +| par(cartesian) { TPar $1 } | module_name "." type_name { let module_name = $1.value in let type_name = $3.value in @@ -230,13 +264,13 @@ field_decl: (* Top-level non-recursive definitions *) let_declaration: - seq(Attr) "let" let_binding { + seq(Attr) "let" let_binding { let attributes = $1 in - let kwd_let = $2 in - let binding = $3 in - let value = kwd_let, binding, attributes in - let stop = expr_to_region binding.let_rhs in - let region = cover $2 stop + let kwd_let = $2 in + let binding = $3 in + let value = kwd_let, binding, attributes in + let stop = expr_to_region binding.let_rhs in + let region = cover $2 stop in {region; value} } es6_func: @@ -335,7 +369,7 @@ core_pattern: | "false" { PFalse $1 } | "" { PString $1 } | par(ptuple) { PPar $1 } -| list(sub_pattern) { PList (PListComp $1) } +| list__(sub_pattern) { PList (PListComp $1) } | constr_pattern { PConstr $1 } | record_pattern { PRecord $1 } @@ -439,23 +473,21 @@ fun_expr: {p.value with inside = arg_to_pattern p.value.inside} in PPar {p with value} | EUnit u -> PUnit u - | ETuple { value; region } -> + | ETuple { value; region } -> PTuple { value = Utils.nsepseq_map arg_to_pattern value; region} - | EAnnot {region; value = {inside = t, colon, typ; _}} -> + | EAnnot {region; value = {inside = t, colon, typ; _}} -> let value = { pattern = arg_to_pattern t; colon; type_expr = typ} in PPar { value = { lpar = Region.ghost; - rpar = Region.ghost; + rpar = Region.ghost; inside = PTyped {region; value} }; region } - | e -> ( - let open! SyntaxError in - raise (Error (WrongFunctionArguments e)) - ) - in + | e -> + let open! SyntaxError in + raise (Error (WrongFunctionArguments e)) in let fun_args_to_pattern = function EAnnot { value = { @@ -473,17 +505,55 @@ fun_expr: _} -> (* ((foo:x, bar) : type) *) (arg_to_pattern fun_arg, []) - | EPar {value = {inside = fun_arg; _ }; _} -> + | EPar {value = {inside = EFun { + value = { + binders = PTyped { value = { pattern; colon; type_expr }; region = fun_region }, []; + arrow; + body; + _ + }; + _ + }; _ }; region} -> + + let expr_to_type = function + | EVar v -> TVar v + | e -> let open! SyntaxError + in raise (Error (WrongFunctionArguments e)) + in + let type_expr = ( + match type_expr with + | TProd {value; _} -> + let (hd, rest) = value in + let rest = rest @ [(arrow, expr_to_type body)] in + nsepseq_to_curry hd rest + | e -> + TFun { + value = e, arrow, expr_to_type body; + region = fun_region + } + ) + in + PTyped { + value = { + pattern; + colon; + type_expr + }; + region; + }, [] + | EPar {value = {inside = fun_arg; _ }; _} -> arg_to_pattern fun_arg, [] - | EAnnot e -> - arg_to_pattern (EAnnot e), [] + | EAnnot _ as e -> + arg_to_pattern e, [] | ETuple {value = fun_args; _} -> let bindings = List.map (arg_to_pattern <@ snd) (snd fun_args) in List.iter Scoping.check_pattern bindings; arg_to_pattern (fst fun_args), bindings - | EUnit e -> - arg_to_pattern (EUnit e), [] + | EUnit _ as e -> + arg_to_pattern e, [] + | EVar _ as e -> + arg_to_pattern e, [] | e -> let open! SyntaxError in raise (Error (WrongFunctionArguments e)) in @@ -576,8 +646,8 @@ case_clause(right_expr): let_expr(right_expr): seq(Attr) "let" let_binding ";" right_expr { - let attributes = $1 in - let kwd_let = $2 in + let attributes = $1 in + let kwd_let = $2 in let binding = $3 in let kwd_in = $4 in let body = $5 in @@ -727,8 +797,8 @@ common_expr: | "true" { ELogic (BoolExpr (True $1)) } core_expr_2: - common_expr { $1 } -| list(expr) { EList (EListComp $1) } + common_expr { $1 } +| list__(expr) { EList (EListComp $1) } list_or_spread: "[" expr "," sep_or_term_list(expr, ",") "]" { @@ -807,11 +877,11 @@ projection: field_path = snd $4} in {region; value} } -path : - "" {Name $1} -| projection { Path $1} +path: + "" { Name $1 } +| projection { Path $1 } -update_record : +update_record: "{""..."path "," sep_or_term_list(field_path_assignment,",") "}" { let region = cover $1 $6 in let ne_elements, terminator = $5 in diff --git a/src/passes/1-parser/reasonligo/ParserMain.ml b/src/passes/1-parser/reasonligo/ParserMain.ml index c2df027e2..6d27665a2 100644 --- a/src/passes/1-parser/reasonligo/ParserMain.ml +++ b/src/passes/1-parser/reasonligo/ParserMain.ml @@ -27,12 +27,11 @@ module Unit = (* Main *) -let issue_error point = - let error = Unit.format_error ~offsets:IO.options#offsets - IO.options#mode point - in Stdlib.Error error +let issue_error error : ('a, string Region.reg) Stdlib.result = + Stdlib.Error (Unit.format_error ~offsets:IO.options#offsets + IO.options#mode error) -let parse parser : ('a,string) Stdlib.result = +let parse parser : ('a, string Region.reg) Stdlib.result = try parser () with (* Ad hoc errors from the parser *) @@ -43,10 +42,10 @@ let parse parser : ('a,string) Stdlib.result = Examples of valid functions:\n\ let x = (a: string, b: int) : int => 3;\n\ let x = (a: string) : string => \"Hello, \" ++ a;\n" - and reg = AST.expr_to_region expr in - let error = Unit.short_error ~offsets:IO.options#offsets - IO.options#mode msg reg - in Stdlib.Error error + and region = AST.expr_to_region expr in + let error = Unit.short_error ~offsets:IO.options#offsets + IO.options#mode msg region + in Stdlib.Error Region.{value=error; region} (* Scoping errors *) @@ -96,11 +95,61 @@ let parse parser : ('a,string) Stdlib.result = None, invalid in issue_error point) +(* Preprocessing the input source with CPP *) + +module SSet = Utils.String.Set +let sprintf = Printf.sprintf + +(* Path for CPP inclusions (#include) *) + +let lib_path = + match IO.options#libs with + [] -> "" + | libs -> let mk_I dir path = sprintf " -I %s%s" dir path + in List.fold_right mk_I libs "" + +let prefix = + match IO.options#input with + None | Some "-" -> "temp" + | Some file -> Filename.(file |> basename |> remove_extension) + +let suffix = ".pp" ^ IO.ext + +let pp_input = + if SSet.mem "cpp" IO.options#verbose + then prefix ^ suffix + else let pp_input, pp_out = + Filename.open_temp_file prefix suffix + in close_out pp_out; pp_input + +let cpp_cmd = + match IO.options#input with + None | Some "-" -> + sprintf "cpp -traditional-cpp%s - > %s" + lib_path pp_input + | Some file -> + sprintf "cpp -traditional-cpp%s %s > %s" + lib_path file pp_input + let () = - if IO.options#expr - then match parse (fun () -> Unit.parse Unit.parse_expr) with - Stdlib.Ok _ -> () - | Error msg -> Printf.eprintf "\027[31m%s\027[0m%!" msg - else match parse (fun () -> Unit.parse Unit.parse_contract) with - Stdlib.Ok _ -> () - | Error msg -> Printf.eprintf "\027[31m%s\027[0m%!" msg + if Sys.command cpp_cmd <> 0 then + Printf.eprintf "External error: \"%s\" failed." cpp_cmd + +(* Instantiating the lexer and calling the parser *) + +let lexer_inst = + match Lexer.open_token_stream (Lexer.File pp_input) with + Ok instance -> + if IO.options#expr + then + match parse (fun () -> Unit.apply instance Unit.parse_expr) with + Stdlib.Ok _ -> () + | Error Region.{value; _} -> + Printf.eprintf "\027[31m%s\027[0m%!" value + else + (match parse (fun () -> Unit.apply instance Unit.parse_contract) with + Stdlib.Ok _ -> () + | Error Region.{value; _} -> + Printf.eprintf "\027[31m%s\027[0m%!" value) + | Stdlib.Error (Lexer.File_opening msg) -> + Printf.eprintf "\027[31m%s\027[0m%!" msg diff --git a/src/passes/1-parser/reasonligo/dune b/src/passes/1-parser/reasonligo/dune index 5f6970ee0..266196733 100644 --- a/src/passes/1-parser/reasonligo/dune +++ b/src/passes/1-parser/reasonligo/dune @@ -7,7 +7,7 @@ (menhir (merge_into Parser) (modules ParToken Parser) - (flags -la 1 --table --explain --strict --external-tokens LexToken)) + (flags -la 1 --table --strict --explain --external-tokens LexToken)) ;; Build of the parser as a library @@ -15,18 +15,16 @@ (name parser_reasonligo) (public_name ligo.parser.reasonligo) (modules - SyntaxError reasonligo LexToken Parser) + SyntaxError reasonligo LexToken ParErr Parser) (libraries menhirLib parser_shared parser_cameligo str - simple-utils - tezos-utils - getopt) + simple-utils) (preprocess (pps bisect_ppx --conditional)) - (flags (:standard -open Simple_utils -open Parser_shared -open Parser_cameligo))) + (flags (:standard -open Parser_shared -open Simple_utils -open Parser_cameligo))) ;; Build of the unlexer (for covering the ;; error states of the LR automaton) @@ -55,8 +53,7 @@ (libraries parser_reasonligo parser_cameligo) - (modules - ParErr ParserMain) + (modules ParserMain) (preprocess (pps bisect_ppx --conditional)) (flags (:standard -open Simple_utils -open Parser_cameligo -open Parser_shared -open Parser_reasonligo))) diff --git a/src/passes/1-parser/shared/Lexer.mli b/src/passes/1-parser/shared/Lexer.mli index 034f8b252..1d6180104 100644 --- a/src/passes/1-parser/shared/Lexer.mli +++ b/src/passes/1-parser/shared/Lexer.mli @@ -145,7 +145,16 @@ module type S = close : unit -> unit } - val open_token_stream : file_path option -> instance + type input = + File of file_path (* "-" means stdin *) + | Stdin + | String of string + | Channel of in_channel + | Buffer of Lexing.lexbuf + + type open_err = File_opening of string + + val open_token_stream : input -> (instance, open_err) Stdlib.result (* Error reporting *) @@ -157,7 +166,7 @@ module type S = val format_error : ?offsets:bool -> [`Byte | `Point] -> - error Region.reg -> file:bool -> string + error Region.reg -> file:bool -> string Region.reg end diff --git a/src/passes/1-parser/shared/Lexer.mll b/src/passes/1-parser/shared/Lexer.mll index 97d864d52..ca85a124e 100644 --- a/src/passes/1-parser/shared/Lexer.mll +++ b/src/passes/1-parser/shared/Lexer.mll @@ -165,9 +165,18 @@ module type S = get_last : unit -> Region.t; get_file : unit -> file_path; close : unit -> unit - } + } - val open_token_stream : file_path option -> instance + type input = + File of file_path (* "-" means stdin *) + | Stdin + | String of string + | Channel of in_channel + | Buffer of Lexing.lexbuf + + type open_err = File_opening of string + + val open_token_stream : input -> (instance, open_err) Stdlib.result (* Error reporting *) @@ -179,7 +188,7 @@ module type S = val format_error : ?offsets:bool -> [`Byte | `Point] -> - error Region.reg -> file:bool -> string + error Region.reg -> file:bool -> string Region.reg end (* The functorised interface @@ -444,8 +453,9 @@ module Make (Token: TOKEN) : (S with module Token = Token) = let format_error ?(offsets=true) mode Region.{region; value} ~file = let msg = error_to_string value - and reg = region#to_string ~file ~offsets mode - in sprintf "Lexical error %s:\n%s" reg msg + and reg = region#to_string ~file ~offsets mode in + let value = sprintf "Lexical error %s:\n%s" reg msg + in Region.{value; region} let fail region value = raise (Error Region.{region; value}) @@ -516,15 +526,12 @@ module Make (Token: TOKEN) : (S with module Token = Token) = let region, lexeme, state = sync state buffer in let lexeme = Str.string_before lexeme (String.index lexeme 't') in match format_tz lexeme with - | Some tz -> ( - match Token.mk_mutez (Z.to_string tz ^ "mutez") region with - Ok token -> - token, state + None -> assert false + | Some tz -> + match Token.mk_mutez (Z.to_string tz ^ "mutez") region with + Ok token -> token, state | Error Token.Non_canonical_zero -> fail region Non_canonical_zero - ) - | None -> assert false - let mk_ident state buffer = let region, lexeme, state = sync state buffer in @@ -554,7 +561,6 @@ module Make (Token: TOKEN) : (S with module Token = Token) = let region, _, state = sync state buffer in Token.eof region, state - (* END HEADER *) } @@ -580,8 +586,9 @@ let byte_seq = byte | byte (byte | '_')* byte let bytes = "0x" (byte_seq? as seq) let esc = "\\n" | "\\\"" | "\\\\" | "\\b" | "\\r" | "\\t" | "\\x" byte -let pascaligo_sym = "=/=" | '#' | ":=" -let cameligo_sym = "<>" | "::" | "||" | "&&" + +let pascaligo_sym = "=/=" | '#' | ":=" +let cameligo_sym = "<>" | "::" | "||" | "&&" let reasonligo_sym = '!' | "=>" | "!=" | "==" | "++" | "..." | "||" | "&&" let symbol = @@ -680,7 +687,7 @@ and scan state = parse Some special errors are recognised in the semantic actions of the following regular expressions. The first error is a minus sign - separated from the integer it applies by some markup (space or + separated from the integer it applies to by some markup (space or tabs). The second is a minus sign immediately followed by anything else than a natural number (matched above) or markup and a number (previous error). The third is the strange occurrence of @@ -865,10 +872,20 @@ type instance = { close : unit -> unit } -let open_token_stream file_path_opt = - let file_path = match file_path_opt with - None | Some "-" -> "" - | Some file_path -> file_path in +type input = + File of file_path (* "-" means stdin *) +| Stdin +| String of string +| Channel of in_channel +| Buffer of Lexing.lexbuf + +type open_err = File_opening of string + +let open_token_stream input = + let file_path = match input with + File file_path -> + if file_path = "-" then "" else file_path + | _ -> "" in let pos = Pos.min ~file:file_path in let buf_reg = ref (pos#byte, pos#byte) and first_call = ref true @@ -939,7 +956,7 @@ let open_token_stream file_path_opt = match FQueue.deq !state.units with None -> scan buffer; - read_token ~log buffer + read ~log buffer | Some (units, (left_mark, token)) -> log left_mark token; state := {!state with units; @@ -949,15 +966,33 @@ let open_token_stream file_path_opt = patch_buffer (Token.to_region token)#byte_pos buffer; token in - let cin = match file_path_opt with - None | Some "-" -> stdin - | Some file_path -> open_in file_path in - let buffer = Lexing.from_channel cin in - let () = match file_path_opt with - None | Some "-" -> () - | Some file_path -> reset ~file:file_path buffer - and close () = close_in cin in - {read = read_token; buffer; get_win; get_pos; get_last; get_file; close} + let buf_close_res = + match input with + File "" | File "-" | Stdin -> + Ok (Lexing.from_channel stdin, fun () -> close_in stdin) + | File path -> + (try + let chan = open_in path in + let close () = close_in chan in + Ok (Lexing.from_channel chan, close) + with + Sys_error msg -> Stdlib.Error (File_opening msg)) + | String s -> + Ok (Lexing.from_string s, fun () -> ()) + | Channel chan -> + let close () = close_in chan in + Ok (Lexing.from_channel chan, close) + | Buffer b -> Ok (b, fun () -> ()) in + match buf_close_res with + Ok (buffer, close) -> + let () = + match input with + File path when path <> "" -> reset ~file:path buffer + | _ -> () in + let instance = { + read; buffer; get_win; get_pos; get_last; get_file; close} + in Ok instance + | Error _ as e -> e end (* of functor [Make] in HEADER *) (* END TRAILER *) diff --git a/src/passes/1-parser/shared/LexerLog.ml b/src/passes/1-parser/shared/LexerLog.ml index 3497f80fc..bf0cf6dde 100644 --- a/src/passes/1-parser/shared/LexerLog.ml +++ b/src/passes/1-parser/shared/LexerLog.ml @@ -1,4 +1,6 @@ -(** Embedding the LIGO lexer in a debug module *) +(* Embedding the LIGO lexer in a debug module *) + +module Region = Simple_utils.Region module type S = sig @@ -14,7 +16,7 @@ module type S = val trace : ?offsets:bool -> [`Byte | `Point] -> file_path option -> EvalOpt.command -> - (unit, string) Stdlib.result + (unit, string Region.reg) Stdlib.result end module Make (Lexer: Lexer.S) : (S with module Lexer = Lexer) = @@ -48,28 +50,31 @@ module Make (Lexer: Lexer.S) : (S with module Lexer = Lexer) = type file_path = string let trace ?(offsets=true) mode file_path_opt command : - (unit, string) Stdlib.result = - try - let Lexer.{read; buffer; close; _} = - Lexer.open_token_stream file_path_opt in - let log = output_token ~offsets mode command stdout - and close_all () = close (); close_out stdout in - let rec iter () = - match read ~log buffer with - token -> - if Token.is_eof token - then Stdlib.Ok () - else iter () - | exception Lexer.Error error -> - let file = - match file_path_opt with - None | Some "-" -> false - | Some _ -> true in - let msg = - Lexer.format_error ~offsets mode ~file error - in Stdlib.Error msg in - let result = iter () - in (close_all (); result) - with Sys_error msg -> Stdlib.Error msg - + (unit, string Region.reg) Stdlib.result = + let input = + match file_path_opt with + Some file_path -> Lexer.File file_path + | None -> Lexer.Stdin in + match Lexer.open_token_stream input with + Ok Lexer.{read; buffer; close; _} -> + let log = output_token ~offsets mode command stdout + and close_all () = close (); close_out stdout in + let rec iter () = + match read ~log buffer with + token -> + if Token.is_eof token + then Stdlib.Ok () + else iter () + | exception Lexer.Error error -> + let file = + match file_path_opt with + None | Some "-" -> false + | Some _ -> true in + let msg = + Lexer.format_error ~offsets mode ~file error + in Stdlib.Error msg in + let result = iter () + in close_all (); result + | Stdlib.Error (Lexer.File_opening msg) -> + close_out stdout; Stdlib.Error (Region.wrap_ghost msg) end diff --git a/src/passes/1-parser/shared/LexerLog.mli b/src/passes/1-parser/shared/LexerLog.mli index 611e22cfa..3e4776889 100644 --- a/src/passes/1-parser/shared/LexerLog.mli +++ b/src/passes/1-parser/shared/LexerLog.mli @@ -1,3 +1,5 @@ +module Region = Simple_utils.Region + module type S = sig module Lexer : Lexer.S @@ -12,7 +14,7 @@ module type S = val trace : ?offsets:bool -> [`Byte | `Point] -> file_path option -> EvalOpt.command -> - (unit, string) Stdlib.result + (unit, string Region.reg) Stdlib.result end module Make (Lexer: Lexer.S) : S with module Lexer = Lexer diff --git a/src/passes/1-parser/shared/LexerUnit.ml b/src/passes/1-parser/shared/LexerUnit.ml index 70aadaf5f..6088ceb27 100644 --- a/src/passes/1-parser/shared/LexerUnit.ml +++ b/src/passes/1-parser/shared/LexerUnit.ml @@ -1,5 +1,7 @@ (* Functor to build a standalone LIGO lexer *) +module Region = Simple_utils.Region + module type IO = sig val ext : string (* LIGO file extension *) @@ -49,7 +51,7 @@ module Make (IO: IO) (Lexer: Lexer.S) = (* Running the lexer on the input file *) - let scan () : (Lexer.token list, string) Stdlib.result = + let scan () : (Lexer.token list, string Region.reg) Stdlib.result = (* Preprocessing the input *) if SSet.mem "cpp" IO.options#verbose @@ -59,36 +61,36 @@ module Make (IO: IO) (Lexer: Lexer.S) = if Sys.command cpp_cmd <> 0 then let msg = sprintf "External error: the command \"%s\" failed." cpp_cmd - in Stdlib.Error msg + in Stdlib.Error (Region.wrap_ghost msg) else - try - let Lexer.{read; buffer; close; _} = - Lexer.open_token_stream (Some pp_input) in - let close_all () = close (); close_out stdout in - let rec read_tokens tokens = - match read ~log:(fun _ _ -> ()) buffer with - token -> - if Lexer.Token.is_eof token - then Stdlib.Ok (List.rev tokens) - else read_tokens (token::tokens) - | exception Lexer.Error error -> - let file = - match IO.options#input with - None | Some "-" -> false - | Some _ -> true in - let msg = - Lexer.format_error ~offsets:IO.options#offsets - IO.options#mode ~file error - in Stdlib.Error msg in - let result = read_tokens [] - in close_all (); result - with Sys_error msg -> close_out stdout; Stdlib.Error msg + match Lexer.open_token_stream (Lexer.File pp_input) with + Ok Lexer.{read; buffer; close; _} -> + let close_all () = close (); close_out stdout in + let rec read_tokens tokens = + match read ~log:(fun _ _ -> ()) buffer with + token -> + if Lexer.Token.is_eof token + then Stdlib.Ok (List.rev tokens) + else read_tokens (token::tokens) + | exception Lexer.Error error -> + let file = + match IO.options#input with + None | Some "-" -> false + | Some _ -> true in + let msg = + Lexer.format_error ~offsets:IO.options#offsets + IO.options#mode ~file error + in Stdlib.Error msg in + let result = read_tokens [] + in close_all (); result + | Stdlib.Error (Lexer.File_opening msg) -> + close_out stdout; Stdlib.Error (Region.wrap_ghost msg) (* Tracing the lexing (effectful) *) module Log = LexerLog.Make (Lexer) - let trace () : (unit, string) Stdlib.result = + let trace () : (unit, string Region.reg) Stdlib.result = (* Preprocessing the input *) if SSet.mem "cpp" IO.options#verbose @@ -98,7 +100,7 @@ module Make (IO: IO) (Lexer: Lexer.S) = if Sys.command cpp_cmd <> 0 then let msg = sprintf "External error: the command \"%s\" failed." cpp_cmd - in Stdlib.Error msg + in Stdlib.Error (Region.wrap_ghost msg) else Log.trace ~offsets:IO.options#offsets IO.options#mode diff --git a/src/passes/1-parser/shared/LexerUnit.mli b/src/passes/1-parser/shared/LexerUnit.mli index 11dff93ee..988785e45 100644 --- a/src/passes/1-parser/shared/LexerUnit.mli +++ b/src/passes/1-parser/shared/LexerUnit.mli @@ -1,5 +1,7 @@ (* Functor to build a standalone LIGO lexer *) +module Region = Simple_utils.Region + module type IO = sig val ext : string (* LIGO file extension *) @@ -8,6 +10,6 @@ module type IO = module Make (IO: IO) (Lexer: Lexer.S) : sig - val scan : unit -> (Lexer.token list, string) Stdlib.result - val trace : unit -> (unit, string) Stdlib.result + val scan : unit -> (Lexer.token list, string Region.reg) Stdlib.result + val trace : unit -> (unit, string Region.reg) Stdlib.result end diff --git a/src/passes/1-parser/shared/ParserAPI.ml b/src/passes/1-parser/shared/ParserAPI.ml index 2f0ed7598..06bd80a5a 100644 --- a/src/passes/1-parser/shared/ParserAPI.ml +++ b/src/passes/1-parser/shared/ParserAPI.ml @@ -24,6 +24,7 @@ module type PARSER = val interactive_expr : (Lexing.lexbuf -> token) -> Lexing.lexbuf -> expr + val contract : (Lexing.lexbuf -> token) -> Lexing.lexbuf -> ast @@ -41,6 +42,7 @@ module type PARSER = sig val interactive_expr : Lexing.position -> expr MenhirInterpreter.checkpoint + val contract : Lexing.position -> ast MenhirInterpreter.checkpoint end @@ -102,7 +104,9 @@ module Make (IO : IO) let invalid_lexeme = Lexer.Token.to_lexeme invalid in Printf.sprintf "%s and before \"%s\"" s invalid_lexeme in let header = header ^ trailer in - header ^ (if msg = "" then ".\n" else ":\n" ^ msg) + let msg = + header ^ (if msg = "" then ".\n" else ":\n" ^ msg) + in Region.{value=msg; region=invalid_region} let failure get_win checkpoint = let message = ParErr.message (state checkpoint) in diff --git a/src/passes/1-parser/shared/ParserAPI.mli b/src/passes/1-parser/shared/ParserAPI.mli index 6fce46381..d4a3791ee 100644 --- a/src/passes/1-parser/shared/ParserAPI.mli +++ b/src/passes/1-parser/shared/ParserAPI.mli @@ -54,6 +54,8 @@ module Make (IO: IO) (Parser: PARSER with type token = Lexer.Token.token) (ParErr: sig val message : int -> string end) : sig + (* WARNING: The following parsers may all raise [Lexer.Error] *) + (* The monolithic API of Menhir *) val mono_contract : @@ -74,5 +76,6 @@ module Make (IO: IO) val incr_contract : Lexer.instance -> Parser.ast val incr_expr : Lexer.instance -> Parser.expr - val format_error : ?offsets:bool -> [`Point | `Byte] -> error -> string + val format_error : + ?offsets:bool -> [`Point | `Byte] -> error -> string Region.reg end diff --git a/src/passes/1-parser/shared/ParserUnit.ml b/src/passes/1-parser/shared/ParserUnit.ml index eb4eb61d1..a0aced070 100644 --- a/src/passes/1-parser/shared/ParserUnit.ml +++ b/src/passes/1-parser/shared/ParserUnit.ml @@ -37,42 +37,13 @@ module Make (Lexer: Lexer.S) open Printf module SSet = Utils.String.Set - (* Error printing and exception tracing *) + (* Log of the lexer *) - let () = Printexc.record_backtrace true + module Log = LexerLog.Make (Lexer) - (* Preprocessing the input source and opening the input channels *) - - (* Path for CPP inclusions (#include) *) - - let lib_path = - match IO.options#libs with - [] -> "" - | libs -> let mk_I dir path = sprintf " -I %s%s" dir path - in List.fold_right mk_I libs "" - - let prefix = - match IO.options#input with - None | Some "-" -> "temp" - | Some file -> Filename.(file |> basename |> remove_extension) - - let suffix = ".pp" ^ IO.ext - - let pp_input = - if SSet.mem "cpp" IO.options#verbose - then prefix ^ suffix - else let pp_input, pp_out = - Filename.open_temp_file prefix suffix - in close_out pp_out; pp_input - - let cpp_cmd = - match IO.options#input with - None | Some "-" -> - sprintf "cpp -traditional-cpp%s - > %s" - lib_path pp_input - | Some file -> - sprintf "cpp -traditional-cpp%s %s > %s" - lib_path file pp_input + let log = + Log.output_token ~offsets:IO.options#offsets + IO.options#mode IO.options#cmd stdout (* Error handling (reexported from [ParserAPI]) *) @@ -81,8 +52,6 @@ module Make (Lexer: Lexer.S) type invalid = Parser.token type error = message * valid option * invalid - exception Point of error - (* Instantiating the parser *) module Front = ParserAPI.Make (IO)(Lexer)(Parser)(ParErr) @@ -94,18 +63,23 @@ module Make (Lexer: Lexer.S) (* Parsing an expression *) - let parse_expr lexer_inst tokeniser output state : - (AST.expr, string) Stdlib.result = - let close_all () = - lexer_inst.Lexer.close (); close_out stdout in - let lexbuf = lexer_inst.Lexer.buffer in + let parse_expr lexer_inst : + (AST.expr, message Region.reg) Stdlib.result = + let output = Buffer.create 131 in + let state = + ParserLog.mk_state ~offsets:IO.options#offsets + ~mode:IO.options#mode + ~buffer:output in + let close () = lexer_inst.Lexer.close () in let expr = try if IO.options#mono then - Front.mono_expr tokeniser lexbuf + let tokeniser = lexer_inst.Lexer.read ~log + and lexbuf = lexer_inst.Lexer.buffer + in Front.mono_expr tokeniser lexbuf else Front.incr_expr lexer_inst - with exn -> close_all (); raise exn in + with exn -> close (); raise exn in let () = if SSet.mem "ast-tokens" IO.options#verbose then begin @@ -120,22 +94,27 @@ module Make (Lexer: Lexer.S) ParserLog.pp_expr state expr; Buffer.output_buffer stdout output end - in close_all (); Ok expr + in close (); Ok expr (* Parsing a contract *) - let parse_contract lexer_inst tokeniser output state - : (AST.t, string) Stdlib.result = - let close_all () = - lexer_inst.Lexer.close (); close_out stdout in - let lexbuf = lexer_inst.Lexer.buffer in + let parse_contract lexer_inst : + (AST.t, message Region.reg) Stdlib.result = + let output = Buffer.create 131 in + let state = + ParserLog.mk_state ~offsets:IO.options#offsets + ~mode:IO.options#mode + ~buffer:output in + let close () = lexer_inst.Lexer.close () in let ast = try if IO.options#mono then - Front.mono_contract tokeniser lexbuf + let tokeniser = lexer_inst.Lexer.read ~log + and lexbuf = lexer_inst.Lexer.buffer + in Front.mono_contract tokeniser lexbuf else Front.incr_contract lexer_inst - with exn -> close_all (); raise exn in + with exn -> close (); raise exn in let () = if SSet.mem "ast-tokens" IO.options#verbose then begin @@ -150,74 +129,45 @@ module Make (Lexer: Lexer.S) ParserLog.pp_ast state ast; Buffer.output_buffer stdout output end - in close_all (); Ok ast + in close (); Ok ast (* Wrapper for the parsers above *) - let parse parser = - (* Preprocessing the input *) + type 'a parser = Lexer.instance -> ('a, message Region.reg) result - if SSet.mem "cpp" IO.options#verbose - then eprintf "%s\n%!" cpp_cmd - else (); + let apply lexer_inst parser = + (* Calling the parser and filtering errors *) - if Sys.command cpp_cmd <> 0 then - let msg = - sprintf "External error: \"%s\" failed." cpp_cmd - in Stdlib.Error msg - else - (* Instantiating the lexer *) + match parser lexer_inst with + Stdlib.Error _ as error -> error + | Stdlib.Ok _ as node -> node - let lexer_inst = Lexer.open_token_stream (Some pp_input) in + (* Lexing errors *) - (* Making the tokeniser *) + | exception Lexer.Error err -> + let file = + match IO.options#input with + None | Some "-" -> false + | Some _ -> true in + let error = + Lexer.format_error ~offsets:IO.options#offsets + IO.options#mode err ~file + in Stdlib.Error error - let module Log = LexerLog.Make (Lexer) in + (* Incremental API of Menhir *) - let log = - Log.output_token ~offsets:IO.options#offsets - IO.options#mode IO.options#cmd stdout in + | exception Front.Point point -> + let error = + Front.format_error ~offsets:IO.options#offsets + IO.options#mode point + in Stdlib.Error error - let tokeniser = lexer_inst.Lexer.read ~log in + (* Monolithic API of Menhir *) - let output = Buffer.create 131 in - let state = ParserLog.mk_state - ~offsets:IO.options#offsets - ~mode:IO.options#mode - ~buffer:output in - - (* Calling the specific parser (that is, the parameter) *) - - match parser lexer_inst tokeniser output state with - Stdlib.Error _ as error -> error - | Stdlib.Ok _ as node -> node - - (* Lexing errors *) - - | exception Lexer.Error err -> - let file = - match IO.options#input with - None | Some "-" -> false - | Some _ -> true in - let error = - Lexer.format_error ~offsets:IO.options#offsets - IO.options#mode err ~file - in Stdlib.Error error - - (* Incremental API of Menhir *) - - | exception Front.Point point -> - let error = - Front.format_error ~offsets:IO.options#offsets - IO.options#mode point - in Stdlib.Error error - - (* Monolithic API of Menhir *) - - | exception Parser.Error -> - let invalid, valid_opt = - match lexer_inst.Lexer.get_win () with - Lexer.Nil -> + | exception Parser.Error -> + let invalid, valid_opt = + match lexer_inst.Lexer.get_win () with + Lexer.Nil -> assert false (* Safe: There is always at least EOF. *) | Lexer.One invalid -> invalid, None | Lexer.Two (invalid, valid) -> invalid, Some valid in @@ -227,8 +177,8 @@ module Make (Lexer: Lexer.S) IO.options#mode point in Stdlib.Error error - (* I/O errors *) - - | exception Sys_error error -> Stdlib.Error error + (* I/O errors *) + | exception Sys_error error -> + Stdlib.Error (Region.wrap_ghost error) end diff --git a/src/passes/1-parser/shared/ParserUnit.mli b/src/passes/1-parser/shared/ParserUnit.mli index 9c04d4885..645808757 100644 --- a/src/passes/1-parser/shared/ParserUnit.mli +++ b/src/passes/1-parser/shared/ParserUnit.mli @@ -23,49 +23,37 @@ module type Pretty = val print_expr : state -> expr -> unit end -module Make (Lexer: Lexer.S) - (AST: sig type t type expr end) - (Parser: ParserAPI.PARSER - with type ast = AST.t - and type expr = AST.expr - and type token = Lexer.token) - (ParErr: sig val message : int -> string end) - (ParserLog: Pretty with type ast = AST.t - and type expr = AST.expr) +module Make (Lexer : Lexer.S) + (AST : sig type t type expr end) + (Parser : ParserAPI.PARSER + with type ast = AST.t + and type expr = AST.expr + and type token = Lexer.token) + (ParErr : sig val message : int -> string end) + (ParserLog : Pretty with type ast = AST.t + and type expr = AST.expr) (IO: IO) : sig - (* Error handling (reexported from [ParserAPI]) *) + (* Error handling reexported from [ParserAPI] without the + exception [Point] *) type message = string type valid = Parser.token type invalid = Parser.token type error = message * valid option * invalid - exception Point of error - val format_error : - ?offsets:bool -> [`Byte | `Point] -> error -> string + ?offsets:bool -> [`Byte | `Point] -> error -> string Region.reg val short_error : - ?offsets:bool -> [`Point | `Byte] -> string -> Region.t -> string + ?offsets:bool -> [`Point | `Byte] -> message -> Region.t -> string (* Parsers *) - val parse : - (Lexer.instance -> - (Lexing.lexbuf -> Lexer.token) -> - Buffer.t -> ParserLog.state -> ('a, string) result) -> - ('a, string) result + type 'a parser = Lexer.instance -> ('a, message Region.reg) result - val parse_contract : - Lexer.instance -> - (Lexing.lexbuf -> Lexer.token) -> - Buffer.t -> ParserLog.state -> - (AST.t, string) Stdlib.result - - val parse_expr : - Lexer.instance -> - (Lexing.lexbuf -> Lexer.token) -> - Buffer.t -> ParserLog.state -> (AST.expr, string) Stdlib.result + val apply : Lexer.instance -> 'a parser -> ('a, message Region.reg) result + val parse_contract : AST.t parser + val parse_expr : AST.expr parser end diff --git a/src/passes/2-simplify/cameligo.ml b/src/passes/2-simplify/cameligo.ml index dcbf94693..40c238ca8 100644 --- a/src/passes/2-simplify/cameligo.ml +++ b/src/passes/2-simplify/cameligo.ml @@ -32,46 +32,48 @@ module Errors = struct in let data = [ ("expected", fun () -> expected_name); - ("location" , fun () -> Format.asprintf "%a" Location.pp_lift @@ Raw.pattern_to_region actual) - ] in - error ~data title message + ("location", + fun () -> Format.asprintf "%a" Location.pp_lift @@ + Raw.pattern_to_region actual)] + in error ~data title message let unsupported_let_in_function (patterns : Raw.pattern list) = - let title () = "unsupported 'let ... in' function" in - let message () = "defining functions via 'let ... in' is not supported yet" in + let title () = "" in + let message () = "\nDefining functions with \"let ... in\" \ + is not supported yet.\n" in let patterns_loc = List.fold_left (fun a p -> Region.cover a (Raw.pattern_to_region p)) Region.ghost patterns in let data = [ - ("location", fun () -> Format.asprintf "%a" Location.pp_lift @@ patterns_loc) - ] in - error ~data title message + ("location", + fun () -> Format.asprintf "%a" Location.pp_lift @@ patterns_loc)] + in error ~data title message let unknown_predefined_type name = - let title () = "type constants" in + let title () = "Type constants" in let message () = - Format.asprintf "unknown predefined type \"%s\"" name.Region.value in + Format.asprintf "Unknown predefined type \"%s\".\n" + name.Region.value in let data = [ ("location", - fun () -> Format.asprintf "%a" Location.pp_lift @@ name.Region.region) - ] in - error ~data title message + fun () -> Format.asprintf "%a" Location.pp_lift @@ name.Region.region)] + in error ~data title message let untyped_fun_param var = - let title () = "function parameter" in + let title () = "" in let message () = - Format.asprintf "untyped function parameters are not supported yet" in + Format.asprintf "\nUntyped function parameters \ + are not supported yet.\n" in let param_loc = var.Region.region in let data = [ ("location", - fun () -> Format.asprintf "%a" Location.pp_lift @@ param_loc) - ] in - error ~data title message + fun () -> Format.asprintf "%a" Location.pp_lift @@ param_loc)] + in error ~data title message let unsupported_tuple_pattern p = - let title () = "tuple pattern" in + let title () = "" in let message () = - Format.asprintf "tuple patterns are not supported yet" in + Format.asprintf "\nTuple patterns are not supported yet.\n" in let pattern_loc = Raw.pattern_to_region p in let data = [ ("location", @@ -80,21 +82,20 @@ module Errors = struct error ~data title message let unsupported_cst_constr p = - let title () = "constant constructor" in + let title () = "" in let message () = - Format.asprintf "constant constructors are not supported yet" in + Format.asprintf "\nConstant constructors are not supported yet.\n" in let pattern_loc = Raw.pattern_to_region p in let data = [ ("location", - fun () -> Format.asprintf "%a" Location.pp_lift @@ pattern_loc) - ] in - error ~data title message - + fun () -> Format.asprintf "%a" Location.pp_lift @@ pattern_loc)] + in error ~data title message + let unsupported_non_var_pattern p = - let title () = "pattern is not a variable" in + let title () = "" in let message () = - Format.asprintf "non-variable patterns in constructors \ - are not supported yet" in + Format.asprintf "\nNon-variable patterns in constructors \ + are not supported yet.\n" in let pattern_loc = Raw.pattern_to_region p in let data = [ ("location", @@ -103,20 +104,20 @@ module Errors = struct error ~data title message let simplifying_expr t = - let title () = "simplifying expression" in + let title () = "Simplifying expression" in let message () = "" in let data = [ ("expression" , (** TODO: The labelled arguments should be flowing from the CLI. *) thunk @@ Parser.Cameligo.ParserLog.expr_to_string - ~offsets:true ~mode:`Point t) - ] in - error ~data title message + ~offsets:true ~mode:`Point t)] + in error ~data title message let only_constructors p = - let title () = "constructors in patterns" in + let title () = "" in let message () = - Format.asprintf "currently, only constructors are supported in patterns" in + Format.asprintf "\nCurrently, only constructors are \ + supported in patterns.\n" in let pattern_loc = Raw.pattern_to_region p in let data = [ ("location", @@ -125,18 +126,18 @@ module Errors = struct error ~data title message let unsupported_sugared_lists region = - let title () = "lists in patterns" in + let title () = "" in let message () = - Format.asprintf "currently, only empty lists and constructors (::) \ - are supported in patterns" in + Format.asprintf "\nCurrently, only empty lists and \ + constructors (::) \ + are supported in patterns.\n" in let data = [ ("location", - fun () -> Format.asprintf "%a" Location.pp_lift @@ region) - ] in - error ~data title message + fun () -> Format.asprintf "%a" Location.pp_lift @@ region)] + in error ~data title message let corner_case description = - let title () = "corner case" in + let title () = "Corner case" in let message () = description in error title message @@ -286,9 +287,9 @@ let rec simpl_expression : let simpl_update = fun (u:Raw.update Region.reg) -> let (u, loc) = r_split u in let (name, path) = simpl_path u.record in - let record = match path with + let record = match path with | [] -> e_variable (Var.of_name name) - | _ -> e_accessor (e_variable (Var.of_name name)) path in + | _ -> 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) = @@ -296,7 +297,7 @@ let rec simpl_expression : let%bind expr = simpl_expression f.field_expr in ok ( List.map (fun (x: _ Raw.reg) -> x.value) (npseq_to_list f.field_path), expr) in - bind_map_list aux @@ npseq_to_list updates + bind_map_list aux @@ npseq_to_list updates in let aux ur (path, expr) = let rec aux record = function @@ -356,7 +357,7 @@ let rec simpl_expression : | hd :: tl -> e_let_in hd inline - (e_accessor rhs_b_expr [Access_tuple ((List.length prep_vars) - (List.length tl) - 1)]) + (e_accessor rhs_b_expr [Access_tuple ((List.length prep_vars) - (List.length tl) - 1)]) (chain_let_in tl body) | [] -> body (* Precluded by corner case assertion above *) in @@ -733,7 +734,7 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap list result match v_type with | Some v_type -> ok (to_option (simpl_type_expression v_type)) | None -> ok None - in + in let%bind simpl_rhs_expr = simpl_expression rhs_expr in ok @@ loc x @@ Declaration_constant (Var.of_name v.value, v_type_expression, inline, simpl_rhs_expr) ) in let%bind variables = ok @@ npseq_to_list pt.value @@ -834,9 +835,9 @@ and simpl_cases : type a . (Raw.pattern * a) list -> (a, unit) matching result = | PConstr v -> let const, pat_opt = match v with - PConstrApp {value; _} -> + PConstrApp {value; _} -> (match value with - | constr, None -> + | constr, None -> constr, Some (PVar {value = "unit"; region = Region.ghost}) | _ -> value) | PSomeApp {value=region,pat; _} -> diff --git a/src/passes/2-simplify/pascaligo.ml b/src/passes/2-simplify/pascaligo.ml index e8c72ce9a..80e184042 100644 --- a/src/passes/2-simplify/pascaligo.ml +++ b/src/passes/2-simplify/pascaligo.ml @@ -68,9 +68,9 @@ let detect_free_variables (for_body : expression) (local_decl_names : expression module Errors = struct let unsupported_cst_constr p = - let title () = "constant constructor" in + let title () = "" in let message () = - Format.asprintf "constant constructors are not supported yet" in + Format.asprintf "\nConstant constructors are not supported yet.\n" in let pattern_loc = Raw.pattern_to_region p in let data = [ ("location", @@ -79,11 +79,11 @@ module Errors = struct error ~data title message let corner_case ~loc message = - let title () = "corner case" in - let content () = "We don't have a good error message for this case. \ + let title () = "\nCorner case" in + let content () = "We do not have a good error message for this case. \ We are striving find ways to better report them and \ find the use-cases that generate them. \ - Please report this to the developers." in + Please report this to the developers.\n" in let data = [ ("location" , fun () -> loc) ; ("message" , fun () -> message) ; @@ -91,9 +91,9 @@ module Errors = struct error ~data title content let unknown_predefined_type name = - let title () = "type constants" in + let title () = "\nType constants" in let message () = - Format.asprintf "unknown predefined type \"%s\"" name.Region.value in + Format.asprintf "Unknown predefined type \"%s\".\n" name.Region.value in let data = [ ("location", fun () -> Format.asprintf "%a" Location.pp_lift @@ name.Region.region) @@ -101,10 +101,10 @@ module Errors = struct error ~data title message let unsupported_non_var_pattern p = - let title () = "pattern is not a variable" in + let title () = "" in let message () = - Format.asprintf "non-variable patterns in constructors \ - are not supported yet" in + Format.asprintf "\nNon-variable patterns in constructors \ + are not supported yet.\n" in let pattern_loc = Raw.pattern_to_region p in let data = [ ("location", @@ -113,9 +113,10 @@ module Errors = struct error ~data title message let only_constructors p = - let title () = "constructors in patterns" in + let title () = "" in let message () = - Format.asprintf "currently, only constructors are supported in patterns" in + Format.asprintf "\nCurrently, only constructors \ + are supported in patterns.\n" in let pattern_loc = Raw.pattern_to_region p in let data = [ ("location", @@ -124,9 +125,9 @@ module Errors = struct error ~data title message let unsupported_tuple_pattern p = - let title () = "tuple pattern" in + let title () = "" in let message () = - Format.asprintf "tuple patterns are not supported yet" in + Format.asprintf "\nTuple patterns are not supported yet.\n" in let pattern_loc = Raw.pattern_to_region p in let data = [ ("location", @@ -139,10 +140,10 @@ module Errors = struct error ~data title message let unsupported_deep_Some_patterns pattern = - let title () = "option patterns" in + let title () = "" in let message () = - Format.asprintf "currently, only variables in Some constructors \ - in patterns are supported" in + Format.asprintf "\nCurrently, only variables in constructors \ + \"Some\" in patterns are supported.\n" in let pattern_loc = Raw.pattern_to_region pattern in let data = [ ("location", @@ -151,10 +152,10 @@ module Errors = struct error ~data title message let unsupported_deep_list_patterns cons = - let title () = "lists in patterns" in + let title () = "" in let message () = - Format.asprintf "currently, only empty lists and x::y \ - are supported in patterns" in + Format.asprintf "\nCurrently, only empty lists and x::y \ + are supported in patterns.\n" in let data = [ ("location", fun () -> Format.asprintf "%a" Location.pp_lift @@ cons.Region.region) @@ -164,7 +165,7 @@ module Errors = struct (* Logging *) let simplifying_instruction t = - let title () = "simplifiying instruction" in + let title () = "\nSimplifiying instruction" in let message () = "" in (** TODO: The labelled arguments should be flowing from the CLI. *) let data = [ @@ -1185,7 +1186,7 @@ and simpl_for_int : Raw.for_int -> (_ -> expression result) result = fun fi -> - references to the iterated value ==> variable `#COMPILER#elt_X` Note: In the case of an inner loop capturing variable from an outer loop the free variable name can be `#COMPILER#acc.Y` and because we do not - capture the accumulator record in the inner loop, we don't want to + capture the accumulator record in the inner loop, we do not want to generate `#COMPILER#acc.#COMPILER#acc.Y` but `#COMPILER#acc.Y` 5) Append the return value to the body @@ -1321,12 +1322,9 @@ and simpl_for_collect : Raw.for_collect -> (_ -> expression result) result = fun | None -> e_skip () | Some seq -> e_let_in (Var.of_name "#COMPILER#folded_record", None) false fold seq in (* TODO fresh *) return_statement @@ final_sequence -(* -and simpl_declaration : Raw.declaration -> declaration Location.wrap result = - *) and simpl_declaration_list declarations : - Ast_simplified.declaration Location.wrap list result = + Ast_simplified.declaration Location.wrap list result = let open Raw in let rec hook acc = function [] -> acc @@ -1387,8 +1385,7 @@ and simpl_declaration_list declarations : Declaration_constant (name, ty_opt, inline, expr) in let res = Location.wrap ~loc new_decl in hook (bind_list_cons res acc) declarations - in - hook (ok @@ []) (List.rev declarations) + in hook (ok @@ []) (List.rev declarations) let simpl_program : Raw.ast -> program result = fun t -> simpl_declaration_list @@ nseq_to_list t.decl diff --git a/src/stages/ast_simplified/types.ml b/src/stages/ast_simplified/types.ml index 69f564740..94b64044f 100644 --- a/src/stages/ast_simplified/types.ml +++ b/src/stages/ast_simplified/types.ml @@ -11,8 +11,13 @@ and type_expression = { } and declaration = | Declaration_type of (type_variable * type_expression) + + (* A Declaration_constant is described by + * a name + * an optional type annotation + * a boolean indicating whether it should be inlined + * an expression *) | Declaration_constant of (expression_variable * type_expression option * inline * expression) - (* | Macro_declaration of macro_declaration *) and expr = expression diff --git a/src/stages/ast_typed/types.ml b/src/stages/ast_typed/types.ml index cf4957613..4e3355ce4 100644 --- a/src/stages/ast_typed/types.ml +++ b/src/stages/ast_typed/types.ml @@ -8,8 +8,12 @@ type program = declaration Location.wrap list and inline = bool and declaration = + (* A Declaration_constant is described by + * a name + a type-annotated expression + * a boolean indicating whether it should be inlined + * the environment before the declaration (the original environment) + * the environment after the declaration (i.e. with that new declaration added to the original environment). *) | Declaration_constant of (named_expression * inline * (full_environment * full_environment)) - (* | Macro_declaration of macro_declaration *) and environment_element_definition = | ED_binder diff --git a/src/test/contracts/high-order.ligo b/src/test/contracts/high-order.ligo index 5540d6f99..20162400d 100644 --- a/src/test/contracts/high-order.ligo +++ b/src/test/contracts/high-order.ligo @@ -1,52 +1,45 @@ // Test a PascaLIGO function which takes another PascaLIGO function as an argument function foobar (const i : int) : int is - block { - function foo (const i : int) : int is - i ; - function bar (const f : int -> int) : int is - f ( i ) ; - } with bar (foo) ; + begin + function foo (const i : int) : int is i; + function bar (const f : int -> int) : int is f (i); + end with bar (foo); // higher order function with more than one argument -function higher2(const i: int; const f: int -> int): int is - block { - const ii: int = f(i) - } with ii +function higher2(const i : int; const f : int -> int): int is + begin + const ii: int = f (i) + end with ii function foobar2 (const i : int) : int is - block { - function foo2 (const i : int) : int is - i; - } with higher2(i,foo2) + begin + function foo2 (const i : int) : int is i + end with higher2 (i,foo2) const a : int = 0; + function foobar3 (const i : int) : int is - block { - function foo2 (const i : int) : int is - (a+i); - } with higher2(i,foo2) + begin + function foo2 (const i : int) : int is a+i + end with higher2 (i,foo2) -function f (const i : int) : int is - i +function f (const i : int) : int is i -function g (const i : int) : int is - f(i) +function g (const i : int) : int is f (i) -function foobar4 (const i : int) : int is - g(g(i)) +function foobar4 (const i : int) : int is g (g (i)) -function higher3(const i: int; const f: int -> int; const g: int -> int): int is - block { - const ii: int = f(g(i)); - } with ii +function higher3(const i : int; const f : int -> int; const g : int -> int) +: int is + begin + const ii : int = f(g(i)) + end with ii function foobar5 (const i : int) : int is - block { + begin const a : int = 0; - function foo (const i : int) : int is - (a+i); - function goo (const i : int) : int is - foo(i); - } with higher3(i,foo,goo) + function foo (const i : int) : int is a+i; + function goo (const i : int) : int is foo (i) + end with higher3(i,foo,goo) -function foobar6 (const i : int) : (int->int) is f \ No newline at end of file +function foobar6 (const i : int) : int -> int is f diff --git a/src/test/contracts/tuple_type.mligo b/src/test/contracts/tuple_type.mligo new file mode 100644 index 000000000..d9cdb62b5 --- /dev/null +++ b/src/test/contracts/tuple_type.mligo @@ -0,0 +1,14 @@ +let g (b: int) = b + 3 + +let f (b: int * int) : int -> int = g + +let a (b: int * int -> int -> int) : int = (b (5,3)) 5 + +let test1 (_: int) = + a f + +let n (a, b: int * int): int = a + b + +let o (p: int * int -> int): int = p((3, 9)) + +let test2 (ignore: int) = o(n) diff --git a/src/test/contracts/tuple_type.religo b/src/test/contracts/tuple_type.religo new file mode 100644 index 000000000..6148840c0 --- /dev/null +++ b/src/test/contracts/tuple_type.religo @@ -0,0 +1,49 @@ +/* + The difference between tuples and arguments is subtle in ReasonLIGO. + + `f(a, b);` + f is called with two arguments + + `f((a, b));` + f is called with a tuple. + +*/ + +type fun_type = (int, int) => int; + +let arguments = (b: int, c: int) => { + b + c; +}; + +let arguments_type_def = (b: fun_type) => b(5, 3); + +let arguments_test = (ignore: int) => arguments_type_def(arguments); + +type tuple_type = ((int, int)) => int; + +let tuple = ((a, b): (int, int)) => { + a + b; +}; + +let tuple_type_def = (b: tuple_type) => b((5, 3)); + +let tuple_test = (ignore: int) => tuple_type_def(tuple); + + +/* inline */ + +let arguments_inline = (b: int, c: int) => { + b + c; +}; + +let arguments_type_def_inline = (b: (int, int) => int) => b(5, 3); + +let arguments_test_inline = (ignore: int) => arguments_type_def_inline(arguments_inline); + +let tuple_inline = ((a, b): (int, int)) => { + a + b; +}; + +let tuple_type_def_inline = (b: ((int, int)) => int) => b((5, 3)); + +let tuple_test_inline = (ignore: int) => tuple_type_def_inline(tuple_inline); diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index 789f2a6c4..2449e085e 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -2098,6 +2098,44 @@ let empty_case_religo () : unit result = in ok () +let tuple_type_mligo () : unit result = + let%bind program = mtype_file "./contracts/tuple_type.mligo" in + let%bind () = + let input _ = e_int 0 in + let expected _ = e_int 8 in + expect_eq_n program "test1" input expected + in + let%bind () = + let input _ = e_int 0 in + let expected _ = e_int 12 in + expect_eq_n program "test2" input expected + in + ok () + +let tuple_type_religo () : unit result = + let%bind program = retype_file "./contracts/tuple_type.religo" in + let%bind () = + let input _ = e_int 0 in + let expected _ = e_int 8 in + expect_eq_n program "arguments_test" input expected + in + let%bind () = + let input _ = e_int 0 in + let expected _ = e_int 8 in + expect_eq_n program "tuple_test" input expected + in + let%bind () = + let input _ = e_int 0 in + let expected _ = e_int 8 in + expect_eq_n program "arguments_test_inline" input expected + in + let%bind () = + let input _ = e_int 0 in + let expected _ = e_int 8 in + expect_eq_n program "tuple_test_inline" input expected + in + ok () + let main = test_suite "Integration (End to End)" [ test "bytes unpack" bytes_unpack ; test "bytes unpack (mligo)" bytes_unpack_mligo ; @@ -2258,4 +2296,6 @@ let main = test_suite "Integration (End to End)" [ test "empty case" empty_case ; test "empty case (mligo)" empty_case_mligo ; test "empty case (religo)" empty_case_religo ; + test "tuple type (mligo)" tuple_type_mligo ; + test "tuple type (religo)" tuple_type_religo ; ] diff --git a/vendors/Preproc/.EMain.tag b/vendors/Preproc/.EMain.tag new file mode 100644 index 000000000..e69de29bb diff --git a/vendors/Preproc/.Eparser.mly.tag b/vendors/Preproc/.Eparser.mly.tag new file mode 100644 index 000000000..e69de29bb diff --git a/vendors/Preproc/.ProcMain.tag b/vendors/Preproc/.ProcMain.tag new file mode 100644 index 000000000..e69de29bb diff --git a/vendors/Preproc/.links b/vendors/Preproc/.links new file mode 100644 index 000000000..71ff816cb --- /dev/null +++ b/vendors/Preproc/.links @@ -0,0 +1 @@ +$HOME/git/OCaml-build/Makefile diff --git a/vendors/Preproc/EMain.ml b/vendors/Preproc/EMain.ml new file mode 100644 index 000000000..7108f35ca --- /dev/null +++ b/vendors/Preproc/EMain.ml @@ -0,0 +1,33 @@ +(* This module is only used for testing modules [Escan] and [Eparser] + as units *) + +module Lexer = struct + let run () = + match Array.length Sys.argv with + 2 -> Escan.trace Sys.argv.(1) + | _ -> prerr_endline ("Usage: " ^ Sys.argv.(0) ^ " [file]") +end + +module Parser = struct + let run () = + if Array.length Sys.argv = 2 + then + match open_in Sys.argv.(1) with + exception Sys_error msg -> prerr_endline msg + | cin -> + let buffer = Lexing.from_channel cin in + let open Error in + let () = + try + let tree = Eparser.pp_expression Escan.token buffer in + let value = Preproc.(eval Env.empty tree) + in (print_string (string_of_bool value); + print_newline ()) + with Lexer diag -> print "Lexical" diag + | Parser diag -> print "Syntactical" diag + | Eparser.Error -> print "" ("Parse", mk_seg buffer, 1) + in close_in cin + else prerr_endline ("Usage: " ^ Sys.argv.(0) ^ " [file]") +end + +let _ = Parser.run() diff --git a/vendors/Preproc/Eparser.mly b/vendors/Preproc/Eparser.mly new file mode 100644 index 000000000..19462a8da --- /dev/null +++ b/vendors/Preproc/Eparser.mly @@ -0,0 +1,50 @@ +%{ +(* Grammar for boolean expressions in preprocessing directives of C# *) +%} + +%token True False +%token Ident +%token OR AND EQ NEQ NOT EOL LPAR RPAR + +(* Entries *) + +%start pp_expression +%type pp_expression + +%% + +(* Grammar *) + +pp_expression: + e=pp_or_expression EOL { e } + +pp_or_expression: + e=pp_and_expression { e } +| e1=pp_or_expression OR e2=pp_and_expression { + Etree.Or (e1,e2) + } + +pp_and_expression: + e=pp_equality_expression { e } +| e1=pp_and_expression AND e2=pp_unary_expression { + Etree.And (e1,e2) + } + +pp_equality_expression: + e=pp_unary_expression { e } +| e1=pp_equality_expression EQ e2=pp_unary_expression { + Etree.Eq (e1,e2) + } +| e1=pp_equality_expression NEQ e2=pp_unary_expression { + Etree.Neq (e1,e2) + } + +pp_unary_expression: + e=pp_primary_expression { e } +| NOT e=pp_unary_expression { Etree.Not e } + +pp_primary_expression: + True { Etree.True } +| False { Etree.False } +| id=Ident { Etree.Ident id } +| LPAR e=pp_or_expression RPAR { e } diff --git a/vendors/Preproc/Error.ml b/vendors/Preproc/Error.ml new file mode 100644 index 000000000..cf7f342f9 --- /dev/null +++ b/vendors/Preproc/Error.ml @@ -0,0 +1,31 @@ +(* This module provides support for managing and printing errors when + preprocessing C# source files. *) + +type message = string +type start = Lexing.position +type stop = Lexing.position +type seg = start * stop + +let mk_seg buffer = + Lexing.(lexeme_start_p buffer, lexeme_end_p buffer) + +type vline = int + +exception Lexer of (message * seg * vline) +exception Parser of (message * seg * vline) + +let print (kind: string) (msg, (start, stop), vend) = + let open Lexing in + let delta = vend - stop.pos_lnum in + let vstart = start.pos_lnum + delta +in assert (msg <> ""); + prerr_endline + ((if kind = "" then msg else kind) ^ " error at line " + ^ string_of_int vstart ^ ", char " + ^ string_of_int (start.pos_cnum - start.pos_bol) + ^ (if stop.pos_lnum = start.pos_lnum + then "--" ^ string_of_int (stop.pos_cnum - stop.pos_bol) + else " to line " ^ string_of_int vend + ^ ", char " + ^ string_of_int (stop.pos_cnum - stop.pos_bol)) + ^ (if kind = "" then "." else ":\n" ^ msg)) diff --git a/vendors/Preproc/Escan.mll b/vendors/Preproc/Escan.mll new file mode 100644 index 000000000..23becbf76 --- /dev/null +++ b/vendors/Preproc/Escan.mll @@ -0,0 +1,95 @@ +{ +(* Auxiliary scanner for boolean expressions of the C# preprocessor *) + +(* Concrete syntax of tokens. See module [Eparser]. *) + +let string_of_token = + let open Eparser +in function True -> "true" + | False -> "false" + | Ident id -> id + | OR -> "||" + | AND -> "&&" + | EQ -> "==" + | NEQ -> "!=" + | NOT -> "!" + | LPAR -> "(" + | RPAR -> ")" + | EOL -> "EOL" + +} + +(* Regular expressions for literals *) + +(* White space *) + +let newline = '\n' | '\r' | "\r\n" +let blank = ' ' | '\t' + +(* Unicode escape sequences *) + +let digit = ['0'-'9'] +let hexdigit = digit | ['A'-'F' 'a'-'f'] +let four_hex = hexdigit hexdigit hexdigit hexdigit +let uni_esc = "\\u" four_hex | "\\U" four_hex four_hex + +(* Identifiers *) + +let lowercase = ['a'-'z'] +let uppercase = ['A'-'Z'] +let letter = lowercase | uppercase | uni_esc +let start = '_' | letter +let alphanum = letter | digit | '_' +let ident = start alphanum* + +(* Rules *) + +rule token = parse + blank+ { token lexbuf } +| newline { Lexing.new_line lexbuf; Eparser.EOL } +| eof { Eparser.EOL } +| "true" { Eparser.True } +| "false" { Eparser.False } +| ident as id { Eparser.Ident id } +| '(' { Eparser.LPAR } +| ')' { Eparser.RPAR } +| "||" { Eparser.OR } +| "&&" { Eparser.AND } +| "==" { Eparser.EQ } +| "!=" { Eparser.NEQ } +| "!" { Eparser.NOT } +| "//" { inline_com lexbuf } +| _ as c { let code = Char.code c in + let msg = "Invalid character " ^ String.make 1 c + ^ " (" ^ string_of_int code ^ ")." + in raise Error.(Lexer (msg, mk_seg lexbuf, 1)) + } + +and inline_com = parse + newline { Lexing.new_line lexbuf; Eparser.EOL } +| eof { Eparser.EOL } +| _ { inline_com lexbuf } + +{ +(* Standalone lexer for debugging purposes. See module [Topexp]. *) + +type filename = string + +let trace (name: filename) = + match open_in name with + cin -> + let buffer = Lexing.from_channel cin + and cout = stdout in + let rec iter () = + match token buffer with + Eparser.EOL -> close_in cin; close_out cout + | t -> begin + output_string cout (string_of_token t); + output_string cout "\n"; + flush cout; + iter () + end + | exception Error.Lexer diag -> Error.print "Lexical" diag + in iter () + | exception Sys_error msg -> prerr_endline msg +} diff --git a/vendors/Preproc/Etree.ml b/vendors/Preproc/Etree.ml new file mode 100644 index 000000000..6fcec7bd7 --- /dev/null +++ b/vendors/Preproc/Etree.ml @@ -0,0 +1,28 @@ +(* This module defines and exports the type [t] of conditional + expressions of C# directives. + + To avoid over-engineering, we moved the definition of the function + [eval] below into the module [Preproc] itself. +*) + +type t = + Or of t * t +| And of t * t +| Eq of t * t +| Neq of t * t +| Not of t +| True +| False +| Ident of string + +(* +let rec eval env = function + Or (e1,e2) -> eval env e1 || eval env e2 +| And (e1,e2) -> eval env e1 && eval env e2 +| Eq (e1,e2) -> eval env e1 = eval env e2 +| Neq (e1,e2) -> eval env e1 != eval env e2 +| Not e -> not (eval env e) +| True -> true +| False -> false +| Ident id -> Preproc.Env.mem id env +*) diff --git a/vendors/Preproc/LICENSE b/vendors/Preproc/LICENSE new file mode 100644 index 000000000..33a225af0 --- /dev/null +++ b/vendors/Preproc/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2018 Christian Rinderknecht + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/vendors/Preproc/Makefile.cfg b/vendors/Preproc/Makefile.cfg new file mode 100644 index 000000000..13c016eb6 --- /dev/null +++ b/vendors/Preproc/Makefile.cfg @@ -0,0 +1,4 @@ +SHELL := dash +BFLAGS := -strict-sequence -w +A-48-4 +#OCAMLC := ocamlcp +#OCAMLOPT := ocamloptp diff --git a/vendors/Preproc/Preproc.mll b/vendors/Preproc/Preproc.mll new file mode 100644 index 000000000..bc3fc912a --- /dev/null +++ b/vendors/Preproc/Preproc.mll @@ -0,0 +1,585 @@ +(* Preprocessor for C#, to be processed by [ocamllex]. *) + +{ +(* STRING PROCESSING *) + +(* The value of [mk_str len p] ("make string") is a string of length + [len] containing the [len] characters in the list [p], in reverse + order. For instance, [mk_str 3 ['c';'b';'a'] = "abc"]. *) + + let mk_str (len: int) (p: char list) : string = + let () = assert (len = List.length p) in + let bytes = Bytes.make len ' ' in + let rec fill i = function + [] -> bytes + | char::l -> Bytes.set bytes i char; fill (i-1) l + in fill (len-1) p |> Bytes.to_string + +(* The call [explode s a] is the list made by pushing the characters + in the string [s] on top of [a], in reverse order. For example, + [explode "ba" ['c';'d'] = ['a'; 'b'; 'c'; 'd']]. *) + +let explode s acc = + let rec push = function + 0 -> acc + | i -> s.[i-1] :: push (i-1) +in push (String.length s) + +(* ERROR HANDLING *) + +let stop msg seg = raise (Error.Lexer (msg, seg,1)) +let fail msg buffer = stop msg (Error.mk_seg buffer) + +exception Local_err of Error.message + +let handle_err scan buffer = + try scan buffer with Local_err msg -> fail msg buffer + +(* LEXING ENGINE *) + +(* Copying the current lexeme to [stdout] *) + +let copy buffer = print_string (Lexing.lexeme buffer) + +(* End of lines *) + +let handle_nl buffer = Lexing.new_line buffer; copy buffer + + +(* C# PREPROCESSOR DIRECTIVES *) + +(* The type [mode] defines the two scanning modes of the preprocessor: + either we copy the current characters or we skip them. *) + +type mode = Copy | Skip + +(* Trace of directives + + We keep track of directives #if, #elif, #else, #region and #endregion. +*) + +type cond = If of mode | Elif of mode | Else | Region +type trace = cond list + +(* The function [reduce_cond] is called when a #endif directive is + found, and the trace (see type [trace] above) needs updating. *) + +let rec reduce_cond seg = function + [] -> stop "Dangling #endif." seg +| If mode::trace -> trace, mode +| Region::_ -> stop "Invalid scoping of #region" seg +| _::trace -> reduce_cond seg trace + +(* The function [reduce_reg] is called when a #endregion directive is + read, and the trace needs updating. *) + +let reduce_reg seg = function + [] -> stop "Dangling #endregion." seg +| Region::trace -> trace +| _ -> stop "Invalid scoping of #endregion" seg + +(* The function [extend] is called when encountering conditional + directives #if, #else and #elif. As its name suggests, it extends + the current trace with the current conditional directive, whilst + performing some validity checks. *) + +let extend seg cond trace = + match cond, trace with + If _, Elif _::_ -> + stop "Directive #if cannot follow #elif." seg + | Else, Else::_ -> + stop "Directive #else cannot follow #else." seg + | Else, [] -> + stop "Dangling #else." seg + | Elif _, Else::_ -> + stop "Directive #elif cannot follow #else." seg + | Elif _, [] -> + stop "Dangling #elif." seg + | _ -> cond::trace + +(* The function [last_mode] seeks the last mode as recorded in the + trace (see type [trace] above). *) + +let rec last_mode = function + [] -> assert false +| (If mode | Elif mode)::_ -> mode +| _::trace -> last_mode trace + +(* Line offsets + + The value [Inline] of type [offset] means that the current location + cannot be reached from the start of the line with only white + space. The same holds for the special value [Prefix 0]. Values of + the form [Prefix n] mean that the current location can be reached + from the start of the line with [n] white spaces (padding). These + distinctions are needed because preprocessor directives cannot + occur inside lines. +*) + +type offset = Prefix of int | Inline + +let expand = function + Prefix 0 | Inline -> () +| Prefix n -> print_string (String.make n ' ') + +(* Directives *) + +let directives = [ + "if"; "else"; "elif"; "endif"; "define"; "undef"; + "error"; "warning"; "line"; "region"; "endregion"; + "include"] + +(* Environments and preprocessor expressions + + The evaluation of conditional directives may involve symbols whose + value may be defined using #define directives, or undefined by + means of #undef. Therefore, we need to evaluate conditional + expressions in an environment made of a set of defined symbols. + + Note that we rely on an external lexer and parser for the + conditional expressions. See modules [Escan] and [Eparser]. +*) + +module Env = Set.Make(String) + +let rec eval env = + let open Etree +in function + Or (e1,e2) -> eval env e1 || eval env e2 +| And (e1,e2) -> eval env e1 && eval env e2 +| Eq (e1,e2) -> eval env e1 = eval env e2 +| Neq (e1,e2) -> eval env e1 != eval env e2 +| Not e -> not (eval env e) +| True -> true +| False -> false +| Ident id -> Env.mem id env + +let expr env buffer = + let tree = Eparser.pp_expression Escan.token buffer +in if eval env tree then Copy else Skip + +(* END OF HEADER *) +} + +(* REGULAR EXPRESSIONS *) + +(* White space *) + +let nl = '\n' | '\r' | "\r\n" +let blank = ' ' | '\t' + +(* Integers *) + +let int_suf = 'U' | 'u' | 'L' | 'l' | "UL" | "Ul" | "uL" + | "ul" | "LU" | "Lu" | "lU" | "lu" +let digit = ['0'-'9'] +let dec = digit+ int_suf? +let hexdigit = digit | ['A'-'F' 'a'-'f'] +let hex_pre = "0x" | "0X" +let hexa = hex_pre hexdigit+ int_suf? +let integer = dec | hexa + +(* Unicode escape sequences *) + +let four_hex = hexdigit hexdigit hexdigit hexdigit +let uni_esc = "\\u" four_hex | "\\U" four_hex four_hex + +(* Identifiers *) + +let lowercase = ['a'-'z'] +let uppercase = ['A'-'Z'] +let letter = lowercase | uppercase | uni_esc +let start = '_' | letter +let alphanum = letter | digit | '_' +let ident = start alphanum* + +(* Real *) + +let decimal = digit+ +let exponent = ['e' 'E'] ['+' '-']? decimal +let real_suf = ['F' 'f' 'D' 'd' 'M' 'm'] +let real = (decimal? '.')? decimal exponent? real_suf? + +(* Characters *) + +let single = [^ '\n' '\r'] +let esc = "\\'" | "\\\"" | "\\\\" | "\\0" | "\\a" | "\\b" | "\\f" + | "\\n" | "\\r" | "\\t" | "\\v" +let hex_esc = "\\x" hexdigit hexdigit? hexdigit? hexdigit? +let character = single | esc | hex_esc | uni_esc +let char = "'" character "'" + +(* Directives *) + +let directive = '#' (blank* as space) (ident as id) + +(* Rules *) + +(* The rule [scan] scans the input buffer for directives, strings, + comments, blanks, new lines and end of file characters. As a + result, either the matched input is copied to [stdout] or not, + depending on the compilation directives. If not copied, new line + characters are output. + + Scanning is triggered by the function call [scan env mode offset + trace lexbuf], where [env] is the set of defined symbols + (introduced by `#define'), [mode] specifies whether we are copying + or skipping the input, [offset] informs about the location in the + line (either there is a prefix of blanks, or at least a non-blank + character has been read), and [trace] is the stack of conditional + directives read so far. + + The first call is [scan Env.empty Copy (Prefix 0) []], meaning that + we start with an empty environment, that copying the input is + enabled by default, and that we are at the start of a line and no + previous conditional directives have been read yet. + + When an "#if" is matched, the trace is extended by the call [extend + lexbuf (If mode) trace], during the evaluation of which the + syntactic validity of having encountered an "#if" is checked (for + example, it would be invalid had an "#elif" been last read). Note + that the current mode is stored in the trace with the current + directive -- that mode may be later restored (see below for some + examples). Moreover, the directive would be deemed invalid if its + current position in the line (that is, its offset) were not + preceeded by blanks or nothing, otherwise the rule [expr] is called + to scan the boolean expression associated with the "#if": if it + evaluates to [true], the result is [Copy], meaning that we may copy + what follows, otherwise skip it -- the actual decision depending on + the current mode. That new mode is used if we were in copy mode, + and the offset is reset to the start of a new line (as we read a + new line in [expr]); otherwise we were in skipping mode and the + value of the conditional expression must be ignored (but not its + syntax), and we continue skipping the input. + + When an "#else" is matched, the trace is extended with [Else], + then, if the directive is not at a wrong offset, the rest of the + line is scanned with [pp_newline]. If we were in copy mode, the new + mode toggles to skipping mode; otherwise, the trace is searched for + the last encountered "#if" of "#elif" and the associated mode is + restored. + + The case "#elif" is the result of the fusion (in the technical + sense) of the code for dealing with an "#else" followed by an + "#if". + + When an "#endif" is matched, the trace is reduced, that is, all + conditional directives are popped until an [If mode'] is found and + [mode'] is restored as the current mode. + + Consider the following four cases, where the modes (Copy/Skip) are + located between the lines: + + Copy ----+ Copy ----+ + #if true | #if true | + Copy | Copy | + #else | #else | + +-- Skip --+ | +-- Skip --+ | + #if true | | | #if false | | | + | Skip | | | Skip | | + #else | | | #else | | | + +-> Skip | | +-> Skip | | + #endif | | #endif | | + Skip <-+ | Skip <-+ | + #endif | #endif | + Copy <---+ Copy <---+ + + + +-- Copy ----+ Copy --+-+ + #if false | | #if false | | + | Skip | Skip | | + #else | | #else | | + +-> Copy --+ | +-+-- Copy <-+ | + #if true | | #if false | | | + Copy | | | | Skip | + #else | | #else | | | + Skip | | | +-> Copy | + #endif | | #endif | | + Copy <-+ | +---> Copy | + #endif | #endif | + Copy <---+ Copy <---+ + + The following four cases feature #elif. Note that we put between + brackets the mode saved for the #elif, which is sometimes restored + later. + + Copy --+ Copy --+ + #if true | #if true | + Copy | Copy | + #elif true +--[Skip] | #elif false +--[Skip] | + | Skip | | Skip | + #else | | #else | | + +-> Skip | +-> Skip | + #endif | #endif | + Copy <-+ Copy <-+ + + + +-- Copy --+-+ +-- Copy ----+ + #if false | | | #if false | | + | Skip | | | Skip | + #elif true +->[Copy] | | #elif false +->[Copy]--+ | + Copy <-+ | Skip | | + #else | #else | | + Skip | Copy <-+ | + #endif | #endif | + Copy <---+ Copy <---+ + + Note how "#elif" indeed behaves like an "#else" followed by an + "#if", and the mode stored with the data constructor [Elif] + corresponds to the mode before the virtual "#if". + + Important note: Comments and strings are recognised as such only in + copy mode, which is a different behaviour from the preprocessor of + GNU GCC, which always does. +*) + +rule scan env mode offset trace = parse + nl { handle_nl lexbuf; + scan env mode (Prefix 0) trace lexbuf } +| blank { match offset with + Prefix n -> scan env mode (Prefix (n+1)) trace lexbuf + | Inline -> copy lexbuf; + scan env mode Inline trace lexbuf } +| directive { + if not (List.mem id directives) + then fail "Invalid preprocessing directive." lexbuf + else if offset = Inline + then fail "Directive invalid inside line." lexbuf + else let seg = Error.mk_seg lexbuf in + match id with + "include" -> + let curr_line = Lexing.(lexbuf.lex_curr_p.pos_lnum) + and curr_file = Lexing.(lexbuf.lex_curr_p.pos_fname) + |> Filename.basename + and incl_file = scan_inclusion lexbuf in + let incl_buffer = + open_in incl_file |> Lexing.from_channel in + Printf.printf "# 1 \"%s\" 1\n" incl_file; + cat incl_buffer; + Printf.printf "# %i \"%s\" 2\n" (curr_line+1) curr_file; + scan env mode offset trace lexbuf + | "if" -> + let mode' = expr env lexbuf in + let new_mode = if mode = Copy then mode' else Skip in + let trace' = extend seg (If mode) trace + in scan env new_mode (Prefix 0) trace' lexbuf + | "else" -> + let () = pp_newline lexbuf in + let new_mode = + if mode = Copy then Skip else last_mode trace in + let trace' = extend seg Else trace + in scan env new_mode (Prefix 0) trace' lexbuf + | "elif" -> + let mode' = expr env lexbuf in + let trace', new_mode = + match mode with + Copy -> extend seg (Elif Skip) trace, Skip + | Skip -> let old_mode = last_mode trace + in extend seg (Elif old_mode) trace, + if old_mode = Copy then mode' else Skip + in scan env new_mode (Prefix 0) trace' lexbuf + | "endif" -> + let () = pp_newline lexbuf in + let trace', new_mode = reduce_cond seg trace + in scan env new_mode (Prefix 0) trace' lexbuf + | "define" -> + let id, seg = ident env lexbuf + in if id="true" || id="false" + then let msg = "Symbol \"" ^ id ^ "\" cannot be defined." + in stop msg seg + else if Env.mem id env + then let msg = "Symbol \"" ^ id + ^ "\" was already defined." + in stop msg seg + else scan (Env.add id env) mode (Prefix 0) trace lexbuf + | "undef" -> + let id, _ = ident env lexbuf + in scan (Env.remove id env) mode (Prefix 0) trace lexbuf + | "error" -> + stop (message [] lexbuf) seg + | "warning" -> + let start_p, end_p = seg in + let msg = message [] lexbuf in + let open Lexing + in prerr_endline + ("Warning at line " ^ string_of_int start_p.pos_lnum + ^ ", char " + ^ string_of_int (start_p.pos_cnum - start_p.pos_bol) + ^ "--" ^ string_of_int (end_p.pos_cnum - end_p.pos_bol) + ^ ":\n" ^ msg); + scan env mode (Prefix 0) trace lexbuf + | "region" -> + let msg = message [] lexbuf + in expand offset; + print_endline ("#" ^ space ^ "region" ^ msg); + scan env mode (Prefix 0) (Region::trace) lexbuf + | "endregion" -> + let msg = message [] lexbuf + in expand offset; + print_endline ("#" ^ space ^ "endregion" ^ msg); + scan env mode (Prefix 0) (reduce_reg seg trace) lexbuf + | "line" -> + expand offset; + print_string ("#" ^ space ^ "line"); + line_ind lexbuf; + scan env mode (Prefix 0) trace lexbuf + | _ -> assert false + } +| eof { match trace with + [] -> expand offset; flush stdout; (env, trace) + | _ -> fail "Missing #endif." lexbuf } +| '"' { if mode = Copy then begin + expand offset; copy lexbuf; + handle_err in_norm_str lexbuf + end; + scan env mode Inline trace lexbuf } +| "@\"" { if mode = Copy then begin + expand offset; copy lexbuf; + handle_err in_verb_str lexbuf + end; + scan env mode Inline trace lexbuf } +| "//" { if mode = Copy then begin + expand offset; copy lexbuf; + in_line_com mode lexbuf + end; + scan env mode Inline trace lexbuf } +| "/*" { if mode = Copy then begin + expand offset; copy lexbuf; + handle_err in_block_com lexbuf + end; + scan env mode Inline trace lexbuf } +| _ { if mode = Copy then (expand offset; copy lexbuf); + scan env mode Inline trace lexbuf } + +(* Support for #define and #undef *) + +and ident env = parse + blank* { let r = __ident env lexbuf + in pp_newline lexbuf; r } + +and __ident env = parse + ident as id { id, Error.mk_seg lexbuf } + +(* Line indicator (#line) *) + +and line_ind = parse + blank* as space { print_string space; line_indicator lexbuf } + +and line_indicator = parse + decimal as ind { + print_string ind; + end_indicator lexbuf + } +| ident as id { + match id with + "default" | "hidden" -> + print_endline (id ^ message [] lexbuf) + | _ -> fail "Invalid line indicator." lexbuf + } +| nl | eof { fail "Line indicator expected." lexbuf } + +and end_indicator = parse + blank* nl { copy lexbuf; handle_nl lexbuf } +| blank* eof { copy lexbuf } +| blank* "//" { copy lexbuf; print_endline (message [] lexbuf) } +| blank+ '"' { copy lexbuf; + handle_err in_norm_str lexbuf; + opt_line_com lexbuf } +| _ { fail "Line comment or blank expected." lexbuf } + +and opt_line_com = parse + nl { handle_nl lexbuf } +| eof { copy lexbuf } +| blank+ { copy lexbuf; opt_line_com lexbuf } +| "//" { print_endline ("//" ^ message [] lexbuf) } + +(* New lines and verbatim sequence of characters *) + +and pp_newline = parse + nl { handle_nl lexbuf } +| blank+ { pp_newline lexbuf } +| "//" { in_line_com Skip lexbuf } +| _ { fail "Only a single-line comment allowed." lexbuf } + +and message acc = parse + nl { Lexing.new_line lexbuf; + mk_str (List.length acc) acc } +| eof { mk_str (List.length acc) acc } +| _ as c { message (c::acc) lexbuf } + +(* Comments *) + +and in_line_com mode = parse + nl { handle_nl lexbuf } +| eof { flush stdout } +| _ { if mode = Copy then copy lexbuf; in_line_com mode lexbuf } + +and in_block_com = parse + nl { handle_nl lexbuf; in_block_com lexbuf } +| "*/" { copy lexbuf } +| eof { raise (Local_err "Unterminated comment.") } +| _ { copy lexbuf; in_block_com lexbuf } + +(* Include a file *) + +and cat = parse + eof { () } +| _ { copy lexbuf; cat lexbuf } + +(* Included filename *) + +and scan_inclusion = parse + blank+ { scan_inclusion lexbuf } +| '"' { handle_err (in_inclusion [] 0) lexbuf } + +and in_inclusion acc len = parse + '"' { mk_str len acc } +| nl { fail "Newline invalid in string." lexbuf } +| eof { raise (Local_err "Unterminated string.") } +| _ as c { in_inclusion (c::acc) (len+1) lexbuf } + +(* Strings *) + +and in_norm_str = parse + "\\\"" { copy lexbuf; in_norm_str lexbuf } +| '"' { copy lexbuf } +| nl { fail "Newline invalid in string." lexbuf } +| eof { raise (Local_err "Unterminated string.") } +| _ { copy lexbuf; in_norm_str lexbuf } + +and in_verb_str = parse + "\"\"" { copy lexbuf; in_verb_str lexbuf } +| '"' { copy lexbuf } +| nl { handle_nl lexbuf; in_verb_str lexbuf } +| eof { raise (Local_err "Unterminated string.") } +| _ { copy lexbuf; in_verb_str lexbuf } + +{ +(* The function [lex] is a wrapper of [scan], which also checks that + the trace is empty at the end. Note that we discard the + environment at the end. *) + +let lex buffer = + let _env, trace = scan Env.empty Copy (Prefix 0) [] buffer +in assert (trace = []) + +(* Exported definitions *) + +type filename = string + +let trace (name: filename) : unit = + match open_in name with + cin -> + let open Lexing in + let buffer = from_channel cin in + let pos_fname = Filename.basename name in + let () = buffer.lex_curr_p <- {buffer.lex_curr_p with pos_fname} in + let open Error + in (try lex buffer with + Lexer diag -> print "Lexical" diag + | Parser diag -> print "Syntactical" diag + | Eparser.Error -> print "" ("Parse", mk_seg buffer, 1)); + close_in cin; flush stdout + | exception Sys_error msg -> prerr_endline msg + +} diff --git a/vendors/Preproc/ProcMain.ml b/vendors/Preproc/ProcMain.ml new file mode 100644 index 000000000..db05cc9b0 --- /dev/null +++ b/vendors/Preproc/ProcMain.ml @@ -0,0 +1,5 @@ +(* This is the entry point of the C# preprocessor. See [Makefile.cfg]. *) + +match Array.length Sys.argv with + 2 -> Preproc.trace Sys.argv.(1) +| _ -> prerr_endline ("Usage: " ^ Sys.argv.(0) ^ " [file]") diff --git a/vendors/Preproc/README.md b/vendors/Preproc/README.md new file mode 100644 index 000000000..b15c65fef --- /dev/null +++ b/vendors/Preproc/README.md @@ -0,0 +1 @@ +# A C# preprocessor in OCaml diff --git a/vendors/Preproc/build.sh b/vendors/Preproc/build.sh new file mode 100755 index 000000000..e9d6546be --- /dev/null +++ b/vendors/Preproc/build.sh @@ -0,0 +1,23 @@ +#!/bin/sh +set -x +ocamllex.opt Escan.mll +ocamllex.opt Preproc.mll +menhir -la 1 Eparser.mly +ocamlfind ocamlopt -strict-sequence -w +A-48-4 -c Etree.ml +ocamlfind ocamlopt -strict-sequence -w +A-48-4 -c Error.ml +ocamlfind ocamlopt -strict-sequence -w +A-48-4 -c Etree.ml +ocamlfind ocamlopt -strict-sequence -w +A-48-4 -c Error.ml +ocamlfind ocamlc -strict-sequence -w +A-48-4 -c Eparser.mli +camlcmd="ocamlfind ocamlc -I _i686 -strict-sequence -w +A-48-4 " +menhir --infer --ocamlc="$camlcmd" Eparser.mly +ocamlfind ocamlopt -strict-sequence -w +A-48-4 -c Escan.ml +ocamlfind ocamlopt -strict-sequence -w +A-48-4 -c Eparser.ml +ocamlfind ocamlopt -strict-sequence -w +A-48-4 -c Preproc.ml +ocamlfind ocamlopt -strict-sequence -w +A-48-4 -c Escan.ml +ocamlfind ocamlopt -strict-sequence -w +A-48-4 -c Preproc.ml +ocamlfind ocamlopt -strict-sequence -w +A-48-4 -c EMain.ml +ocamlfind ocamlopt -strict-sequence -w +A-48-4 -c EMain.ml +ocamlfind ocamlopt -o EMain.opt Etree.cmx Eparser.cmx Error.cmx Escan.cmx Preproc.cmx EMain.cmx +ocamlfind ocamlopt -strict-sequence -w +A-48-4 -c ProcMain.ml +ocamlfind ocamlopt -strict-sequence -w +A-48-4 -c ProcMain.ml +ocamlfind ocamlopt -o ProcMain.opt Etree.cmx Eparser.cmx Error.cmx Escan.cmx Preproc.cmx ProcMain.cmx diff --git a/vendors/Preproc/clean.sh b/vendors/Preproc/clean.sh new file mode 100755 index 000000000..6373ab745 --- /dev/null +++ b/vendors/Preproc/clean.sh @@ -0,0 +1,3 @@ +#!/bin/sh + +\rm -f *.cm* *.o *.byte *.opt diff --git a/vendors/Preproc/dune b/vendors/Preproc/dune new file mode 100644 index 000000000..22003d39e --- /dev/null +++ b/vendors/Preproc/dune @@ -0,0 +1,20 @@ +(ocamllex Escan Preproc) + +(menhir + (modules Eparser)) + +(library + (name PreProc) +; (public_name ligo.preproc) + (wrapped false) + (modules Eparser Error Escan Etree Preproc)) + +(test + (modules ProcMain) + (libraries PreProc) + (name ProcMain)) + +(test + (modules EMain) + (libraries PreProc) + (name EMain)) diff --git a/vendors/ligo-utils/simple-utils/trace.ml b/vendors/ligo-utils/simple-utils/trace.ml index b496e661f..3ff26b4aa 100644 --- a/vendors/ligo-utils/simple-utils/trace.ml +++ b/vendors/ligo-utils/simple-utils/trace.ml @@ -539,8 +539,8 @@ let bind_smap (s:_ X_map.String.t) = let aux k v prev = prev >>? fun prev' -> v >>? fun v' -> - ok @@ add k v' prev' in - fold aux s (ok empty) + ok @@ add k v' prev' + in fold aux s (ok empty) let bind_fold_smap f init (smap : _ X_map.String.t) = let aux k v prev = @@ -558,11 +558,11 @@ let bind_map_list f lst = bind_list (List.map f lst) let rec bind_map_list_seq f lst = match lst with | [] -> ok [] - | hd :: tl -> ( + | hd :: tl -> let%bind hd' = f hd in let%bind tl' = bind_map_list_seq f tl in ok (hd' :: tl') - ) + let bind_map_ne_list : _ -> 'a X_list.Ne.t -> 'b X_list.Ne.t result = fun f lst -> bind_ne_list (X_list.Ne.map f lst) let bind_iter_list : (_ -> unit result) -> _ list -> unit result = @@ -575,11 +575,8 @@ let bind_location (x:_ Location.wrap) = let bind_map_location f x = bind_location (Location.map f x) let bind_fold_list f init lst = - let aux x y = - x >>? fun x -> - f x y - in - List.fold_left aux (ok init) lst + let aux x y = x >>? fun x -> f x y + in List.fold_left aux (ok init) lst module TMap(X : Map.OrderedType) = struct module MX = Map.Make(X) @@ -587,8 +584,7 @@ module TMap(X : Map.OrderedType) = struct let aux k v x = x >>? fun x -> f ~x ~k ~v - in - MX.fold aux map (ok init) + in MX.fold aux map (ok init) let bind_map_Map f map = let aux k v map' = @@ -596,33 +592,26 @@ module TMap(X : Map.OrderedType) = struct f ~k ~v >>? fun v' -> ok @@ MX.update k (function | None -> Some v' - | Some _ -> failwith "key collision, shouldn't happen in bind_map_Map") + | Some _ -> + failwith "Key collision: Should not happen in bind_map_Map") map' - in - MX.fold aux map (ok MX.empty) + in MX.fold aux map (ok MX.empty) end let bind_fold_pair f init (a,b) = - let aux x y = - x >>? fun x -> - f x y - in - List.fold_left aux (ok init) [a;b] + let aux x y = x >>? fun x -> f x y + in List.fold_left aux (ok init) [a;b] let bind_fold_triple f init (a,b,c) = - let aux x y = - x >>? fun x -> - f x y - in - List.fold_left aux (ok init) [a;b;c] + let aux x y = x >>? fun x -> f x y + in List.fold_left aux (ok init) [a;b;c] -let bind_fold_map_list = fun f acc lst -> - let rec aux (acc , prev) f = function - | [] -> ok (acc , prev) +let bind_fold_map_list f acc lst = + let rec aux (acc, prev) f = function + | [] -> ok (acc, prev) | hd :: tl -> f acc hd >>? fun (acc' , hd') -> - aux (acc' , hd' :: prev) f tl - in + aux (acc', hd'::prev) f tl in aux (acc , []) f lst >>? fun (acc' , lst') -> ok @@ (acc' , List.rev lst') @@ -637,23 +626,18 @@ let bind_fold_map_right_list = fun f acc lst -> ok lst' let bind_fold_right_list f init lst = - let aux x y = - x >>? fun x -> - f x y - in - X_list.fold_right' aux (ok init) lst + let aux x y = x >>? fun x -> f x y + in X_list.fold_right' aux (ok init) lst let bind_find_map_list error f lst = let rec aux lst = match lst with | [] -> fail error - | hd :: tl -> ( + | hd :: tl -> match f hd with | Error _ -> aux tl | o -> o - ) - in - aux lst + in aux lst let bind_list_iter f lst = let aux () y = f y in @@ -663,28 +647,29 @@ let bind_or (a, b) = match a with | Ok _ as o -> o | _ -> b -let bind_map_or (fa , fb) c = - bind_or (fa c , fb c) -let bind_lr (type a b) ((a : a result), (b:b result)) : [`Left of a | `Right of b] result = +let bind_map_or (fa, fb) c = bind_or (fa c, fb c) + +let bind_lr (type a b) ((a : a result), (b:b result)) + : [`Left of a | `Right of b] result = match (a, b) with | (Ok _ as o), _ -> map (fun x -> `Left x) o | _, (Ok _ as o) -> map (fun x -> `Right x) o | _, Error b -> Error b -let bind_lr_lazy (type a b) ((a : a result), (b:unit -> b result)) : [`Left of a | `Right of b] result = +let bind_lr_lazy (type a b) ((a : a result), (b:unit -> b result)) + : [`Left of a | `Right of b] result = match a with | Ok _ as o -> map (fun x -> `Left x) o - | _ -> ( - match b() with - | Ok _ as o -> map (fun x -> `Right x) o - | Error b -> Error b - ) + | _ -> match b() with + | Ok _ as o -> map (fun x -> `Right x) o + | Error b -> Error b let bind_and (a, b) = a >>? fun a -> b >>? fun b -> ok (a, b) + let bind_and3 (a, b, c) = a >>? fun a -> b >>? fun b -> @@ -692,18 +677,18 @@ let bind_and3 (a, b, c) = ok (a, b, c) let bind_pair = bind_and + let bind_map_pair f (a, b) = bind_pair (f a, f b) -let bind_fold_map_pair f acc (a, b) = - f acc a >>? fun (acc' , a') -> - f acc' b >>? fun (acc'' , b') -> - ok (acc'' , (a' , b')) -let bind_map_triple f (a, b, c) = - bind_and3 (f a, f b, f c) -let bind_list_cons v lst = - lst >>? fun lst -> - ok (v::lst) +let bind_fold_map_pair f acc (a, b) = + f acc a >>? fun (acc', a') -> + f acc' b >>? fun (acc'', b') -> + ok (acc'', (a', b')) + +let bind_map_triple f (a, b, c) = bind_and3 (f a, f b, f c) + +let bind_list_cons v lst = lst >>? fun lst -> ok (v::lst) let rec bind_chain : ('a -> 'a result) list -> 'a -> 'a result = fun fs x -> match fs with @@ -716,29 +701,23 @@ let rec bind_chain : ('a -> 'a result) list -> 'a -> 'a result = fun fs x -> (** Wraps a call that might trigger an exception in a result. *) -let generic_try err f = - try ( - ok @@ f () - ) with _ -> fail err +let generic_try err f = try ok @@ f () with _ -> fail err (** Same, but with a handler that generates an error based on the exception, rather than a fixed error. *) let specific_try handler f = - try ( - ok @@ f () - ) with exn -> fail (handler exn) + try ok @@ f () with exn -> fail (handler exn) (** Same, but tailored to `Sys_error`s, found in `Sys` from `Pervasives`. *) let sys_try f = let handler = function - | Sys_error str -> error (thunk "Sys_error") (fun () -> str) - | exn -> raise exn - in - specific_try handler f + Sys_error str -> error (thunk "Sys_error") (fun () -> str) + | exn -> raise exn + in specific_try handler f (** Same, but for a given command. @@ -746,53 +725,60 @@ let sys_try f = let sys_command command = sys_try (fun () -> Sys.command command) >>? function | 0 -> ok () - | n -> fail (fun () -> error (thunk "Nonzero return code") (fun () -> (string_of_int n)) ()) + | n -> fail (fun () -> error (thunk "Nonzero return code.") + (fun () -> (string_of_int n)) ()) (** Assertion module. Would make sense to move it outside Trace. *) module Assert = struct - let assert_fail ?(msg="didn't fail") = function - | Ok _ -> simple_fail msg - | _ -> ok () + let assert_fail ?(msg="Did not fail.") = function + Ok _ -> simple_fail msg + | _ -> ok () - let assert_true ?(msg="not true") = function - | true -> ok () - | false -> simple_fail msg + let assert_true ?(msg="Not true.") = function + true -> ok () + | false -> simple_fail msg let assert_equal ?msg expected actual = assert_true ?msg (expected = actual) let assert_equal_string ?msg expected actual = let msg = - let default = Format.asprintf "Not equal string : expected \"%s\", got \"%s\"" expected actual in - X_option.unopt ~default msg in - assert_equal ~msg expected actual + let default = + Format.asprintf "Not equal string: Expected \"%s\", got \"%s\"" + expected actual + in X_option.unopt ~default msg + in assert_equal ~msg expected actual let assert_equal_int ?msg expected actual = let msg = - let default = Format.asprintf "Not equal int : expected %d, got %d" expected actual in - X_option.unopt ~default msg in - assert_equal ~msg expected actual + let default = + Format.asprintf "Not equal int : expected %d, got %d" + expected actual + in X_option.unopt ~default msg + in assert_equal ~msg expected actual let assert_equal_bool ?msg expected actual = let msg = - let default = Format.asprintf "Not equal bool : expected %b, got %b" expected actual in + let default = + Format.asprintf "Not equal bool: expected %b, got %b" + expected actual in X_option.unopt ~default msg in assert_equal ~msg expected actual - let assert_none ?(msg="not a none") opt = match opt with + let assert_none ?(msg="Not a None value.") opt = match opt with | None -> ok () | _ -> simple_fail msg - let assert_list_size ?(msg="lst doesn't have the right size") lst n = + let assert_list_size ?(msg="Wrong list size.") lst n = assert_true ~msg List.(length lst = n) - let assert_list_empty ?(msg="lst isn't empty") lst = + let assert_list_empty ?(msg="Non-empty list.") lst = assert_true ~msg List.(length lst = 0) - let assert_list_same_size ?(msg="lists don't have same size") a b = + let assert_list_same_size ?(msg="Lists with different lengths.") a b = assert_true ~msg List.(length a = length b) let assert_list_size_2 ~msg = function