diff --git a/docker/distribution/debian/package.Dockerfile b/docker/distribution/debian/package.Dockerfile index 6debfad84..4b83667f0 100644 --- a/docker/distribution/debian/package.Dockerfile +++ b/docker/distribution/debian/package.Dockerfile @@ -12,14 +12,14 @@ RUN mkdir /package && mkdir /package/bin && mkdir /package/DEBIAN && mkdir /pack RUN cp /home/opam/.opam/4.07/bin/ligo /package/bin/ligo # @TODO: inherit version (and other details) from the ligo opam package definition -# In our case we're using the version field to name our package accordingly, +# In our case we're using the version field to name our package accordingly, # however this is most likely not ideal # Also, the architecture field should not be 'all' but rather specific instead. RUN echo "Package: ligo\n\ Version: $version\n\ Architecture: all\n\ Maintainer: info@ligolang.org\n\ -Depends: libev4, libgmp10, libgmpxx4ldbl, cpp\n\ +Depends: libev4, libgmp10, libgmpxx4ldbl\n\ Homepage: http://ligolang.org\n\ Description: LIGO is a statically typed high-level smart-contract language that compiles down to Michelson." >> /package/DEBIAN/control diff --git a/gitlab-pages/docs/advanced/entrypoints-contracts.md b/gitlab-pages/docs/advanced/entrypoints-contracts.md index 4073cc1f7..98d29ea51 100644 --- a/gitlab-pages/docs/advanced/entrypoints-contracts.md +++ b/gitlab-pages/docs/advanced/entrypoints-contracts.md @@ -466,8 +466,8 @@ let proxy = ((action, store): (parameter, storage)) : return => { | Some (contract) => contract; | None => (failwith ("Contract not found.") : contract (parameter)); }; - (* Reuse the parameter in the subsequent - transaction or use another one, `mock_param`. *) + /* Reuse the parameter in the subsequent + transaction or use another one, `mock_param`. */ let mock_param : parameter = Increment (5n); let op : operation = Tezos.transaction (action, 0tez, counter); ([op], store) diff --git a/ligo.opam b/ligo.opam index 167e004a8..f3815edc8 100644 --- a/ligo.opam +++ b/ligo.opam @@ -1,6 +1,6 @@ name: "ligo" opam-version: "2.0" -maintainer: "ligolang@gmail.com" +maintainer: "Galfour " authors: [ "Galfour" ] homepage: "https://gitlab.com/ligolang/tezos" bug-reports: "https://gitlab.com/ligolang/tezos/issues" diff --git a/src/bin/cli.ml b/src/bin/cli.ml index 246524f1c..dec0ac0bf 100644 --- a/src/bin/cli.ml +++ b/src/bin/cli.ml @@ -152,6 +152,18 @@ let compile_file = let doc = "Subcommand: Compile a contract." in (Term.ret term , Term.info ~doc cmdname) +let preprocess = + let f source_file syntax display_format = ( + toplevel ~display_format @@ + let%bind pp = + Compile.Of_source.preprocess 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 = "preprocess" in + let doc = "Subcommand: Preprocess the source file.\nWarning: Intended for development of LIGO and can break at any time." in + (Term.ret term, Term.info ~doc cmdname) + let print_cst = let f source_file syntax display_format = ( toplevel ~display_format @@ @@ -470,4 +482,5 @@ let run ?argv () = print_ast_typed ; print_mini_c ; list_declarations ; + preprocess ] diff --git a/src/bin/expect_tests/error_messages_tests.ml b/src/bin/expect_tests/error_messages_tests.ml index 284b21e89..a28a145b5 100644 --- a/src/bin/expect_tests/error_messages_tests.ml +++ b/src/bin/expect_tests/error_messages_tests.ml @@ -3,7 +3,7 @@ open Cli_expect let%expect_test _ = run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/gitlab_111.religo" ; "main" ] ; [%expect {| - ligo: : Parse error in file "gitlab_111.religo", line 2, characters 0-3, after "=" and before "let": + ligo: : Parse error in file "gitlab_111.religo", line 2, characters 0-3 at "let", after "=": This is an incorrect let binding. - Examples of correct let bindings: @@ -23,7 +23,7 @@ let%expect_test _ = run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/missing_rpar.religo" ; "main" ] ; [%expect {| - ligo: : Parse error in file "missing_rpar.religo", line 5, characters 0-3, after "m" and before "let": + ligo: : Parse error in file "missing_rpar.religo", line 5, characters 0-3 at "let", after "m": Missing `)`. {} diff --git a/src/bin/expect_tests/help_tests.ml b/src/bin/expect_tests/help_tests.ml index f960cc6b9..d30f67155 100644 --- a/src/bin/expect_tests/help_tests.ml +++ b/src/bin/expect_tests/help_tests.ml @@ -53,6 +53,10 @@ let%expect_test _ = measure-contract Subcommand: Measure a contract's compiled size in bytes. + preprocess + Subcommand: Preprocess the source file. Warning: Intended for + development of LIGO and can break at any time. + print-ast Subcommand: Print the AST. Warning: Intended for development of LIGO and can break at any time. @@ -140,6 +144,10 @@ let%expect_test _ = measure-contract Subcommand: Measure a contract's compiled size in bytes. + preprocess + Subcommand: Preprocess the source file. Warning: Intended for + development of LIGO and can break at any time. + print-ast Subcommand: Print the AST. Warning: Intended for development of LIGO and can break at any time. diff --git a/src/bin/expect_tests/syntax_error_tests.ml b/src/bin/expect_tests/syntax_error_tests.ml index 8969c68a7..7a092f443 100644 --- a/src/bin/expect_tests/syntax_error_tests.ml +++ b/src/bin/expect_tests/syntax_error_tests.ml @@ -3,7 +3,7 @@ open Cli_expect let%expect_test _ = run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_syntax.ligo" ; "main" ] ; [%expect {| - ligo: : Parse error in file "error_syntax.ligo", line 1, characters 16-17, after "bar" and before "-": + ligo: : Parse error in file "error_syntax.ligo", line 1, characters 16-17 at "-", after "bar": 15: {} diff --git a/src/dune b/src/dune index 0bfd1396c..21ec7d115 100644 --- a/src/dune +++ b/src/dune @@ -1,14 +1,13 @@ -(dirs (:standard \ toto)) +(dirs (:standard)) + (library (name ligo) (public_name ligo) (libraries - simple-utils - tezos-utils - tezos-micheline - main - ) + Preprocessor + simple-utils + tezos-utils + tezos-micheline + main) (preprocess - (pps ppx_let bisect_ppx --conditional) - ) -) + (pps ppx_let bisect_ppx --conditional))) diff --git a/src/main/compile/helpers.ml b/src/main/compile/helpers.ml index 1b8b390fc..b6809a20a 100644 --- a/src/main/compile/helpers.ml +++ b/src/main/compile/helpers.ml @@ -148,18 +148,18 @@ let pretty_print_cameligo source = ~offsets:true ~mode:`Point ~buffer in - Parser.Cameligo.ParserLog.pp_ast state ast; + Parser_cameligo.ParserLog.pp_ast state ast; ok buffer let pretty_print_reasonligo source = let%bind ast = Parser.Reasonligo.parse_file source in let buffer = Buffer.create 59 in let state = (* TODO: Should flow from the CLI *) - Parser.Reasonligo.ParserLog.mk_state + Parser_cameligo.ParserLog.mk_state ~offsets:true ~mode:`Point ~buffer in - Parser.Reasonligo.ParserLog.pp_ast state ast; + Parser_cameligo.ParserLog.pp_ast state ast; ok buffer let pretty_print syntax source = @@ -169,3 +169,17 @@ let pretty_print syntax source = PascaLIGO -> pretty_print_pascaligo source | CameLIGO -> pretty_print_cameligo source | ReasonLIGO -> pretty_print_reasonligo source + +let preprocess_pascaligo = Parser.Pascaligo.preprocess + +let preprocess_cameligo = Parser.Cameligo.preprocess + +let preprocess_reasonligo = Parser.Reasonligo.preprocess + +let preprocess syntax source = + let%bind v_syntax = + syntax_to_variant syntax (Some source) in + match v_syntax with + PascaLIGO -> preprocess_pascaligo source + | CameLIGO -> preprocess_cameligo source + | ReasonLIGO -> preprocess_reasonligo source diff --git a/src/main/compile/of_source.ml b/src/main/compile/of_source.ml index 8b737237b..75cb9f32c 100644 --- a/src/main/compile/of_source.ml +++ b/src/main/compile/of_source.ml @@ -19,5 +19,8 @@ let compile_contract_input : string -> string -> v_syntax -> Ast_imperative.expr let%bind (storage,parameter) = bind_map_pair (compile_expression syntax) (storage,parameter) in ok @@ Ast_imperative.e_pair storage parameter -let pretty_print source_filename syntax = - Helpers.pretty_print syntax source_filename +let pretty_print source_filename syntax = + Helpers.pretty_print syntax source_filename + +let preprocess source_filename syntax = + Helpers.preprocess syntax source_filename diff --git a/src/passes/1-parser/cameligo.ml b/src/passes/1-parser/cameligo.ml index 575445a0a..3ae2063c1 100644 --- a/src/passes/1-parser/cameligo.ml +++ b/src/passes/1-parser/cameligo.ml @@ -4,26 +4,46 @@ 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 SSet = Set.Make (String) (* Mock IOs TODO: Fill them with CLI options *) -module type IO = - sig - val ext : string - val options : EvalOpt.options - end +type language = [`PascaLIGO | `CameLIGO | `ReasonLIGO] -module PreIO = +module SubIO = struct - let ext = ".ligo" - let pre_options = - EvalOpt.make ~libs:[] - ~verbose:SSet.empty - ~offsets:true - ~mode:`Point - ~cmd:EvalOpt.Quiet - ~mono:false + type options = < + libs : string list; + verbose : SSet.t; + offsets : bool; + lang : language; + ext : string; (* ".mligo" *) + mode : [`Byte | `Point]; + cmd : EvalOpt.command; + mono : bool + > + + let options : options = + object + method libs = [] + method verbose = SSet.empty + method offsets = true + method lang = `CameLIGO + method ext = ".mligo" + method mode = `Point + method cmd = EvalOpt.Quiet + method mono = false + end + + let make = + EvalOpt.make ~libs:options#libs + ~verbose:options#verbose + ~offsets:options#offsets + ~lang:options#lang + ~ext:options#ext + ~mode:options#mode + ~cmd:options#cmd + ~mono:options#mono end module Parser = @@ -40,34 +60,33 @@ module ParserLog = include Parser_cameligo.ParserLog end -module PreUnit = - ParserUnit.Make (Lexer)(AST)(Parser)(ParErr)(ParserLog) +module Unit = + ParserUnit.Make (Lexer)(AST)(Parser)(ParErr)(ParserLog)(SubIO) module Errors = struct - (* let data = - [("location", - fun () -> Format.asprintf "%a" Location.pp_lift @@ loc)] *) - let generic message = let title () = "" and message () = message.Region.value in Trace.error ~data:[] title message end -let parse (module IO : IO) parser = - let module Unit = PreUnit (IO) in +let apply parser = let local_fail error = Trace.fail @@ Errors.generic - @@ Unit.format_error ~offsets:IO.options#offsets - IO.options#mode error in + @@ Unit.format_error ~offsets:SubIO.options#offsets + SubIO.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 + (* System errors *) + + | exception Sys_error msg -> + Trace.fail @@ Errors.generic (Region.wrap_ghost msg) (* Scoping errors *) | exception Scoping.Error (Scoping.Reserved_name name) -> @@ -110,71 +129,18 @@ let parse (module IO : IO) parser = 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 = - 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 +(* Parsing a contract in a file *) -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_file source = apply (fun () -> Unit.contract_in_file source) -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 +(* Parsing a contract in a string *) + +let parse_string source = apply (fun () -> Unit.contract_in_string source) + +(* Parsing an expression in a string *) + +let parse_expression source = apply (fun () -> Unit.expr_in_string source) + +(* Preprocessing a contract in a file *) + +let preprocess source = apply (fun () -> Unit.preprocess source) diff --git a/src/passes/1-parser/cameligo.mli b/src/passes/1-parser/cameligo.mli new file mode 100644 index 000000000..c4f66a596 --- /dev/null +++ b/src/passes/1-parser/cameligo.mli @@ -0,0 +1,21 @@ +(** This file provides an interface to the CameLIGO parser. *) + +module AST = Parser_cameligo.AST + +(** Open a CameLIGO filename given by string and convert into an + abstract syntax tree. *) +val parse_file : string -> AST.t Trace.result + +(** Convert a given string into a CameLIGO abstract syntax tree *) +val parse_string : string -> AST.t Trace.result + +(** Parse a given string as a CameLIGO expression and return an + expression AST. + + This is intended to be used for interactive interpreters, or other + scenarios where you would want to parse a CameLIGO expression + outside of a contract. *) +val parse_expression : string -> AST.expr Trace.result + +(** Preprocess a given CameLIGO file and preprocess it. *) +val preprocess : string -> Buffer.t Trace.result diff --git a/src/passes/1-parser/cameligo/.links b/src/passes/1-parser/cameligo/.links index a3ac060f6..702a10aca 100644 --- a/src/passes/1-parser/cameligo/.links +++ b/src/passes/1-parser/cameligo/.links @@ -1,8 +1,5 @@ $HOME/git/OCaml-build/Makefile -$HOME/git/ligo/vendors/ligo-utils/simple-utils/pos.mli -$HOME/git/ligo/vendors/ligo-utils/simple-utils/pos.ml -$HOME/git/ligo/vendors/ligo-utils/simple-utils/region.mli -$HOME/git/ligo/vendors/ligo-utils/simple-utils/region.ml + ../shared/Lexer.mli ../shared/Lexer.mll ../shared/EvalOpt.ml @@ -17,7 +14,9 @@ $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 -Stubs/Simple_utils.ml + $HOME/git/ligo/_build/default/src/passes/1-parser/cameligo/ParErr.ml \ No newline at end of file diff --git a/src/passes/1-parser/cameligo/AST.ml b/src/passes/1-parser/cameligo/AST.ml index 8cef386c2..c558eb72d 100644 --- a/src/passes/1-parser/cameligo/AST.ml +++ b/src/passes/1-parser/cameligo/AST.ml @@ -19,6 +19,8 @@ open Utils denoting the _region_ of the occurrence of the keyword "and". *) +module Region = Simple_utils.Region + type 'a reg = 'a Region.reg (* Keywords of OCaml *) diff --git a/src/passes/1-parser/cameligo/LexerMain.ml b/src/passes/1-parser/cameligo/LexerMain.ml index 60874bda0..2a281efd5 100644 --- a/src/passes/1-parser/cameligo/LexerMain.ml +++ b/src/passes/1-parser/cameligo/LexerMain.ml @@ -4,8 +4,7 @@ module Region = Simple_utils.Region module IO = struct - let ext = ".mligo" - let options = EvalOpt.read "CameLIGO" ext + let options = EvalOpt.(read ~lang:`CameLIGO ~ext:".mligo") end module M = LexerUnit.Make (IO) (Lexer.Make (LexToken)) diff --git a/src/passes/1-parser/cameligo/Makefile.cfg b/src/passes/1-parser/cameligo/Makefile.cfg index 2f2a6b197..5fcac2934 100644 --- a/src/passes/1-parser/cameligo/Makefile.cfg +++ b/src/passes/1-parser/cameligo/Makefile.cfg @@ -2,4 +2,4 @@ SHELL := dash BFLAGS := -strict-sequence -w +A-48-4 -g clean:: -> rm -f Parser.msg Parser.msg.map Parser.msg.states Version.ml +> \rm -f Parser.msg Parser.msg.map Parser.msg.states Version.ml diff --git a/src/passes/1-parser/cameligo/Parser.mly b/src/passes/1-parser/cameligo/Parser.mly index 237c08875..950423005 100644 --- a/src/passes/1-parser/cameligo/Parser.mly +++ b/src/passes/1-parser/cameligo/Parser.mly @@ -3,7 +3,7 @@ [@@@warning "-42"] -open Region +open Simple_utils.Region open AST (* END HEADER *) diff --git a/src/passes/1-parser/cameligo/ParserLog.ml b/src/passes/1-parser/cameligo/ParserLog.ml index 6bf9dcc36..4791ff6dc 100644 --- a/src/passes/1-parser/cameligo/ParserLog.ml +++ b/src/passes/1-parser/cameligo/ParserLog.ml @@ -2,6 +2,7 @@ [@@@coverage exclude_file] open AST +module Region = Simple_utils.Region open! Region let sprintf = Printf.sprintf @@ -866,7 +867,7 @@ and pp_let_in state node = let fields = if lhs_type = None then 3 else 4 in let fields = if kwd_rec = None then fields else fields+1 in let fields = if attributes = [] then fields else fields+1 in - let arity = + let arity = match kwd_rec with None -> 0 | Some (_) -> diff --git a/src/passes/1-parser/cameligo/ParserMain.ml b/src/passes/1-parser/cameligo/ParserMain.ml index 9c481f178..bc47d9199 100644 --- a/src/passes/1-parser/cameligo/ParserMain.ml +++ b/src/passes/1-parser/cameligo/ParserMain.ml @@ -1,9 +1,47 @@ -(** Driver for the CameLIGO parser *) +(* Driver for the CameLIGO parser *) + +module Region = Simple_utils.Region +module SSet = Set.Make (String) module IO = struct - let ext = ".mligo" - let options = EvalOpt.read "CameLIGO" ext + let options = EvalOpt.(read ~lang:`CameLIGO ~ext:".mligo") + end + +module SubIO = + struct + type options = < + libs : string list; + verbose : SSet.t; + offsets : bool; + lang : EvalOpt.language; + ext : string; + mode : [`Byte | `Point]; + cmd : EvalOpt.command; + mono : bool + > + + let options : options = + object + method libs = IO.options#libs + method verbose = IO.options#verbose + method offsets = IO.options#offsets + method lang = IO.options#lang + method ext = IO.options#ext + method mode = IO.options#mode + method cmd = IO.options#cmd + method mono = IO.options#mono + end + + let make = + EvalOpt.make ~libs:options#libs + ~verbose:options#verbose + ~offsets:options#offsets + ~lang:options#lang + ~ext:options#ext + ~mode:options#mode + ~cmd:options#cmd + ~mono:options#mono end module Parser = @@ -23,118 +61,16 @@ module ParserLog = module Lexer = Lexer.Make (LexToken) module Unit = - ParserUnit.Make (Lexer)(AST)(Parser)(ParErr)(ParserLog)(IO) + ParserUnit.Make (Lexer)(AST)(Parser)(ParErr)(ParserLog)(SubIO) (* Main *) -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 Region.reg) Stdlib.result = - try parser () with - (* Scoping errors *) - - | Scoping.Error (Scoping.Reserved_name name) -> - let token = - Lexer.Token.mk_ident name.Region.value name.Region.region in - (match token with - (* Cannot fail because [name] is a not a - reserved name for the lexer. *) - Stdlib.Error _ -> assert false - | Ok invalid -> - issue_error - ("Reserved name.\nHint: Change the name.\n", None, invalid)) - - | Scoping.Error (Scoping.Duplicate_variant name) -> - let token = - Lexer.Token.mk_constr name.Region.value name.Region.region in - let point = "Duplicate constructor in this sum type declaration.\n\ - Hint: Change the constructor.\n", - None, token - in issue_error point - - | Scoping.Error (Scoping.Non_linear_pattern var) -> - let token = - Lexer.Token.mk_ident var.Region.value var.Region.region in - (match token with - (* Cannot fail because [var] is a not a - reserved name for the lexer. *) - Stdlib.Error _ -> assert false - | Ok invalid -> - let point = "Repeated variable in this pattern.\n\ - Hint: Change the name.\n", - None, invalid - in issue_error point) - - | Scoping.Error (Scoping.Duplicate_field name) -> - let token = - Lexer.Token.mk_ident name.Region.value name.Region.region in - (match token with - (* Cannot fail because [name] is a not a - 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) - -(* 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 wrap = function + Stdlib.Ok _ -> flush_all () +| Error msg -> + (flush_all (); Printf.eprintf "\027[31m%s\027[0m%!" msg.Region.value) let () = - 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 + match IO.options#input with + None -> Unit.contract_in_stdin () |> wrap + | Some file_path -> Unit.contract_in_file file_path |> wrap diff --git a/src/passes/1-parser/cameligo/Scoping.ml b/src/passes/1-parser/cameligo/Scoping.ml index 483262deb..4b44a0189 100644 --- a/src/passes/1-parser/cameligo/Scoping.ml +++ b/src/passes/1-parser/cameligo/Scoping.ml @@ -1,5 +1,6 @@ [@@@warning "-42"] +module Region = Simple_utils.Region type t = Reserved_name of AST.variable diff --git a/src/passes/1-parser/cameligo/Scoping.mli b/src/passes/1-parser/cameligo/Scoping.mli index 61ca10f02..dd886f9a8 100644 --- a/src/passes/1-parser/cameligo/Scoping.mli +++ b/src/passes/1-parser/cameligo/Scoping.mli @@ -1,5 +1,7 @@ (* This module exports checks on scoping, called from the parser. *) +module Region = Simple_utils.Region + type t = Reserved_name of AST.variable | Duplicate_variant of AST.variable diff --git a/src/passes/1-parser/cameligo/Stubs/Simple_utils.ml b/src/passes/1-parser/cameligo/Stubs/Simple_utils.ml deleted file mode 100644 index 0360af1b5..000000000 --- a/src/passes/1-parser/cameligo/Stubs/Simple_utils.ml +++ /dev/null @@ -1,2 +0,0 @@ -module Region = Region -module Pos = Pos diff --git a/src/passes/1-parser/cameligo/dune b/src/passes/1-parser/cameligo/dune index 8824fdcd4..85a06d174 100644 --- a/src/passes/1-parser/cameligo/dune +++ b/src/passes/1-parser/cameligo/dune @@ -77,8 +77,8 @@ ; (targets error.messages) ; (deps Parser.mly ParToken.mly error.messages.checked-in) ; (action -; (with-stdout-to %{targets} -; (bash +; (with-stdout-to %{targets} +; (bash ; "menhir \ ; --unused-tokens \ ; --list-errors \ @@ -97,11 +97,11 @@ (targets error.messages) (deps Parser.mly ParToken.mly error.messages.checked-in LexToken.mli) (action - (with-stdout-to %{targets} - (run + (with-stdout-to %{targets} + (run menhir --unused-tokens - --update-errors error.messages.checked-in + --update-errors error.messages.checked-in --table --strict --external-tokens LexToken.mli @@ -115,8 +115,8 @@ (rule (target error.messages.new) (action - (with-stdout-to %{target} - (run + (with-stdout-to %{target} + (run menhir --unused-tokens --list-errors @@ -135,7 +135,7 @@ (name runtest) (deps error.messages error.messages.new) (action - (run + (run menhir --unused-tokens --table @@ -156,8 +156,8 @@ (targets ParErr.ml) (deps Parser.mly ParToken.mly error.messages.checked-in LexToken.mli) (action - (with-stdout-to %{targets} - (run + (with-stdout-to %{targets} + (run menhir --unused-tokens --table diff --git a/src/passes/1-parser/pascaligo.ml b/src/passes/1-parser/pascaligo.ml index 10eeaa30d..6e4759fe8 100644 --- a/src/passes/1-parser/pascaligo.ml +++ b/src/passes/1-parser/pascaligo.ml @@ -4,26 +4,46 @@ 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 +module SSet = Set.Make (String) (* Mock IOs TODO: Fill them with CLI options *) -module type IO = - sig - val ext : string - val options : EvalOpt.options - end +type language = [`PascaLIGO | `CameLIGO | `ReasonLIGO] -module PreIO = +module SubIO = struct - let ext = ".ligo" - let pre_options = - EvalOpt.make ~libs:[] - ~verbose:SSet.empty - ~offsets:true - ~mode:`Point - ~cmd:EvalOpt.Quiet - ~mono:false + type options = < + libs : string list; + verbose : SSet.t; + offsets : bool; + lang : language; + ext : string; (* ".ligo" *) + mode : [`Byte | `Point]; + cmd : EvalOpt.command; + mono : bool + > + + let options : options = + object + method libs = [] + method verbose = SSet.empty + method offsets = true + method lang = `PascaLIGO + method ext = ".ligo" + method mode = `Point + method cmd = EvalOpt.Quiet + method mono = false + end + + let make = + EvalOpt.make ~libs:options#libs + ~verbose:options#verbose + ~offsets:options#offsets + ~lang:options#lang + ~ext:options#ext + ~mode:options#mode + ~cmd:options#cmd + ~mono:options#mono end module Parser = @@ -40,34 +60,34 @@ module ParserLog = include Parser_pascaligo.ParserLog end -module PreUnit = - ParserUnit.Make (Lexer)(AST)(Parser)(ParErr)(ParserLog) +module Unit = + ParserUnit.Make (Lexer)(AST)(Parser)(ParErr)(ParserLog)(SubIO) module Errors = struct - (* let data = - [("location", - fun () -> Format.asprintf "%a" Location.pp_lift @@ loc)] *) - let generic message = let title () = "" and message () = message.Region.value in Trace.error ~data:[] title message end -let parse (module IO : IO) parser = - let module Unit = PreUnit (IO) in +let apply parser = let local_fail error = Trace.fail @@ Errors.generic - @@ Unit.format_error ~offsets:IO.options#offsets - IO.options#mode error in + @@ Unit.format_error ~offsets:SubIO.options#offsets + SubIO.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 + + (* System errors *) + + | exception Sys_error msg -> + Trace.fail @@ Errors.generic (Region.wrap_ghost msg) (* Scoping errors *) | exception Scoping.Error (Scoping.Reserved_name name) -> @@ -121,71 +141,18 @@ let parse (module IO : IO) parser = Hint: Change the name.\n", None, invalid)) -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 = - 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 +(* Parsing a contract in a file *) -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_file source = apply (fun () -> Unit.contract_in_file source) -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 +(* Parsing a contract in a string *) + +let parse_string source = apply (fun () -> Unit.contract_in_string source) + +(* Parsing an expression in a string *) + +let parse_expression source = apply (fun () -> Unit.expr_in_string source) + +(* Preprocessing a contract in a file *) + +let preprocess source = apply (fun () -> Unit.preprocess source) diff --git a/src/passes/1-parser/pascaligo.mli b/src/passes/1-parser/pascaligo.mli index 13e75b7e9..48ee3dadb 100644 --- a/src/passes/1-parser/pascaligo.mli +++ b/src/passes/1-parser/pascaligo.mli @@ -16,3 +16,6 @@ val parse_string : string -> AST.t Trace.result scenarios where you would want to parse a PascaLIGO expression outside of a contract. *) val parse_expression : string -> AST.expr Trace.result + +(** Preprocess a given PascaLIGO file and preprocess it. *) +val preprocess : string -> Buffer.t Trace.result diff --git a/src/passes/1-parser/pascaligo/.links b/src/passes/1-parser/pascaligo/.links index 70b9b360f..0b836a2d9 100644 --- a/src/passes/1-parser/pascaligo/.links +++ b/src/passes/1-parser/pascaligo/.links @@ -1,8 +1,5 @@ $HOME/git/OCaml-build/Makefile -$HOME/git/ligo/vendors/ligo-utils/simple-utils/pos.mli -$HOME/git/ligo/vendors/ligo-utils/simple-utils/pos.ml -$HOME/git/ligo/vendors/ligo-utils/simple-utils/region.mli -$HOME/git/ligo/vendors/ligo-utils/simple-utils/region.ml + ../shared/Lexer.mli ../shared/Lexer.mll ../shared/EvalOpt.ml @@ -21,7 +18,5 @@ $HOME/git/ligo/vendors/ligo-utils/simple-utils/region.ml ../shared/LexerUnit.ml ../shared/ParserUnit.mli ../shared/ParserUnit.ml -../shared/Memo.mli -../shared/Memo.ml -Stubs/Simple_utils.ml -$HOME/git/ligo/_build/default/src/passes/1-parser/pascaligo/ParErr.ml \ No newline at end of file + +$HOME/git/ligo/_build/default/src/passes/1-parser/pascaligo/ParErr.ml diff --git a/src/passes/1-parser/pascaligo/AST.ml b/src/passes/1-parser/pascaligo/AST.ml index b78eefd02..0d3a2b050 100644 --- a/src/passes/1-parser/pascaligo/AST.ml +++ b/src/passes/1-parser/pascaligo/AST.ml @@ -19,6 +19,8 @@ open Utils denoting the _region_ of the occurrence of the keyword "and". *) +module Region = Simple_utils.Region + type 'a reg = 'a Region.reg (* Keywords of LIGO *) diff --git a/src/passes/1-parser/pascaligo/LexToken.mll b/src/passes/1-parser/pascaligo/LexToken.mll index 5711bbac6..24c44ab71 100644 --- a/src/passes/1-parser/pascaligo/LexToken.mll +++ b/src/passes/1-parser/pascaligo/LexToken.mll @@ -11,8 +11,8 @@ let sprintf = Printf.sprintf module Region = Simple_utils.Region module Pos = Simple_utils.Pos -module SMap = Utils.String.Map -module SSet = Utils.String.Set +module SMap = Map.Make (String) +module SSet = Set.Make (String) (* Hack to roll back one lexeme in the current semantic action *) (* diff --git a/src/passes/1-parser/pascaligo/LexerMain.ml b/src/passes/1-parser/pascaligo/LexerMain.ml index 32606118a..3c8d7c642 100644 --- a/src/passes/1-parser/pascaligo/LexerMain.ml +++ b/src/passes/1-parser/pascaligo/LexerMain.ml @@ -4,8 +4,7 @@ module Region = Simple_utils.Region module IO = struct - let ext = ".ligo" - let options = EvalOpt.read "PascaLIGO" ext + let options = EvalOpt.(read ~lang:`PascaLIGO ~ext:".ligo") end module M = LexerUnit.Make (IO) (Lexer.Make (LexToken)) @@ -13,4 +12,4 @@ module M = LexerUnit.Make (IO) (Lexer.Make (LexToken)) let () = match M.trace () with Stdlib.Ok () -> () - | Error Region.{value; _} -> Utils.highlight value + | Error Region.{value; _} -> Printf.eprintf "\027[31m%s\027[0m%!" value diff --git a/src/passes/1-parser/pascaligo/Makefile.cfg b/src/passes/1-parser/pascaligo/Makefile.cfg index 2f2a6b197..5fcac2934 100644 --- a/src/passes/1-parser/pascaligo/Makefile.cfg +++ b/src/passes/1-parser/pascaligo/Makefile.cfg @@ -2,4 +2,4 @@ SHELL := dash BFLAGS := -strict-sequence -w +A-48-4 -g clean:: -> rm -f Parser.msg Parser.msg.map Parser.msg.states Version.ml +> \rm -f Parser.msg Parser.msg.map Parser.msg.states Version.ml diff --git a/src/passes/1-parser/pascaligo/Misc/pascaligo.ml b/src/passes/1-parser/pascaligo/Misc/pascaligo.ml deleted file mode 100644 index c323496e5..000000000 --- a/src/passes/1-parser/pascaligo/Misc/pascaligo.ml +++ /dev/null @@ -1,39 +0,0 @@ - -module ParserLog = Parser_pascaligo.ParserLog -module ParErr = Parser_pascaligo.ParErr -module SSet = Utils.String.Set - -(* Mock options. TODO: Plug in cmdliner. *) - -let pre_options = - EvalOpt.make - ~libs:[] - ~verbose:SSet.empty - ~offsets:true - ~mode:`Point - ~cmd:EvalOpt.Quiet - ~mono:true (* Monolithic API of Menhir for now *) -(* ~input:None *) -(* ~expr:true *) - -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 Front = ParserAPI.Make (Lexer)(Parser)(ParErr) - -let issue_error point = - let error = Front.format_error ~offsets:true (* TODO: CLI *) - `Point (* TODO: CLI *) point - in Stdlib.Error error diff --git a/src/passes/1-parser/pascaligo/Parser.mly b/src/passes/1-parser/pascaligo/Parser.mly index 502ea5fb2..eeaf1211f 100644 --- a/src/passes/1-parser/pascaligo/Parser.mly +++ b/src/passes/1-parser/pascaligo/Parser.mly @@ -3,7 +3,7 @@ [@@@warning "-42"] -open Region +open Simple_utils.Region open AST (* END HEADER *) diff --git a/src/passes/1-parser/pascaligo/ParserLog.ml b/src/passes/1-parser/pascaligo/ParserLog.ml index ccca02968..ce543ce8f 100644 --- a/src/passes/1-parser/pascaligo/ParserLog.ml +++ b/src/passes/1-parser/pascaligo/ParserLog.ml @@ -2,6 +2,8 @@ [@@@coverage exclude_file] open AST + +module Region = Simple_utils.Region open! Region let sprintf = Printf.sprintf diff --git a/src/passes/1-parser/pascaligo/ParserMain.ml b/src/passes/1-parser/pascaligo/ParserMain.ml index 464094f85..c94ca806d 100644 --- a/src/passes/1-parser/pascaligo/ParserMain.ml +++ b/src/passes/1-parser/pascaligo/ParserMain.ml @@ -1,9 +1,47 @@ (* Driver for the PascaLIGO parser *) +module Region = Simple_utils.Region +module SSet = Set.Make (String) + module IO = struct - let ext = ".ligo" - let options = EvalOpt.read "PascaLIGO" ext + let options = EvalOpt.(read ~lang:`PascaLIGO ~ext:".ligo") + end + +module SubIO = + struct + type options = < + libs : string list; + verbose : SSet.t; + offsets : bool; + lang : EvalOpt.language; + ext : string; + mode : [`Byte | `Point]; + cmd : EvalOpt.command; + mono : bool + > + + let options : options = + object + method libs = IO.options#libs + method verbose = IO.options#verbose + method offsets = IO.options#offsets + method lang = IO.options#lang + method ext = IO.options#ext + method mode = IO.options#mode + method cmd = IO.options#cmd + method mono = IO.options#mono + end + + let make = + EvalOpt.make ~libs:options#libs + ~verbose:options#verbose + ~offsets:options#offsets + ~lang:options#lang + ~ext:options#ext + ~mode:options#mode + ~cmd:options#cmd + ~mono:options#mono end module Parser = @@ -23,130 +61,16 @@ module ParserLog = module Lexer = Lexer.Make (LexToken) module Unit = - ParserUnit.Make (Lexer)(AST)(Parser)(ParErr)(ParserLog)(IO) + ParserUnit.Make (Lexer)(AST)(Parser)(ParErr)(ParserLog)(SubIO) (* Main *) -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 Region.reg) Stdlib.result = - try parser () with - (* Scoping errors *) - - | Scoping.Error (Scoping.Duplicate_parameter name) -> - let token = - Lexer.Token.mk_ident name.Region.value name.Region.region in - (match token with - (* Cannot fail because [name] is a not a - reserved name for the lexer. *) - Stdlib.Error _ -> assert false - | Ok invalid -> - issue_error ("Duplicate parameter.\nHint: Change the name.\n", - None, invalid)) - - | Scoping.Error (Scoping.Reserved_name name) -> - let token = - Lexer.Token.mk_ident name.Region.value name.Region.region in - (match token with - (* Cannot fail because [name] is a not a - reserved name for the lexer. *) - Stdlib.Error _ -> assert false - | Ok invalid -> - issue_error - ("Reserved name.\nHint: Change the name.\n", None, invalid)) - - | Scoping.Error (Scoping.Duplicate_variant name) -> - let token = - Lexer.Token.mk_constr name.Region.value name.Region.region in - let point = "Duplicate constructor in this sum type declaration.\n\ - Hint: Change the constructor.\n", - None, token - in issue_error point - - | Scoping.Error (Scoping.Non_linear_pattern var) -> - let token = - Lexer.Token.mk_ident var.Region.value var.Region.region in - (match token with - (* Cannot fail because [var] is a not a - reserved name for the lexer. *) - Stdlib.Error _ -> assert false - | Ok invalid -> - let point = "Repeated variable in this pattern.\n\ - Hint: Change the name.\n", - None, invalid - in issue_error point) - - | Scoping.Error (Scoping.Duplicate_field name) -> - let token = - Lexer.Token.mk_ident name.Region.value name.Region.region in - (match token with - (* Cannot fail because [name] is a not a - 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) - -(* 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 wrap = function + Stdlib.Ok _ -> flush_all () +| Error msg -> + (flush_all (); Printf.eprintf "\027[31m%s\027[0m%!" msg.Region.value) let () = - 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 + match IO.options#input with + None -> Unit.contract_in_stdin () |> wrap + | Some file_path -> Unit.contract_in_file file_path |> wrap diff --git a/src/passes/1-parser/pascaligo/Scoping.ml b/src/passes/1-parser/pascaligo/Scoping.ml index 2ac52f8d1..64a8eea52 100644 --- a/src/passes/1-parser/pascaligo/Scoping.ml +++ b/src/passes/1-parser/pascaligo/Scoping.ml @@ -1,5 +1,6 @@ [@@@warning "-42"] +module Region = Simple_utils.Region type t = Reserved_name of AST.variable diff --git a/src/passes/1-parser/pascaligo/Scoping.mli b/src/passes/1-parser/pascaligo/Scoping.mli index 71f8c1244..bc4372979 100644 --- a/src/passes/1-parser/pascaligo/Scoping.mli +++ b/src/passes/1-parser/pascaligo/Scoping.mli @@ -1,5 +1,7 @@ (* This module exports checks on scoping, called from the parser. *) +module Region = Simple_utils.Region + type t = Reserved_name of AST.variable | Duplicate_parameter of AST.variable diff --git a/src/passes/1-parser/pascaligo/Stubs/Simple_utils.ml b/src/passes/1-parser/pascaligo/Stubs/Simple_utils.ml deleted file mode 100644 index 0360af1b5..000000000 --- a/src/passes/1-parser/pascaligo/Stubs/Simple_utils.ml +++ /dev/null @@ -1,2 +0,0 @@ -module Region = Region -module Pos = Pos diff --git a/src/passes/1-parser/pascaligo/dune b/src/passes/1-parser/pascaligo/dune index d0d43f02f..a63252fe7 100644 --- a/src/passes/1-parser/pascaligo/dune +++ b/src/passes/1-parser/pascaligo/dune @@ -20,6 +20,7 @@ menhirLib parser_shared hex + Preprocessor simple-utils) (preprocess (pps bisect_ppx --conditional)) @@ -77,8 +78,8 @@ ; (targets error.messages) ; (deps Parser.mly ParToken.mly error.messages.checked-in) ; (action -; (with-stdout-to %{targets} -; (bash +; (with-stdout-to %{targets} +; (bash ; "menhir \ ; --unused-tokens \ ; --list-errors \ @@ -97,11 +98,11 @@ (targets error.messages) (deps Parser.mly ParToken.mly error.messages.checked-in LexToken.mli) (action - (with-stdout-to %{targets} - (run + (with-stdout-to %{targets} + (run menhir --unused-tokens - --update-errors error.messages.checked-in + --update-errors error.messages.checked-in --table --strict --external-tokens LexToken.mli @@ -115,8 +116,8 @@ (rule (target error.messages.new) (action - (with-stdout-to %{target} - (run + (with-stdout-to %{target} + (run menhir --unused-tokens --list-errors @@ -135,7 +136,7 @@ (name runtest) (deps error.messages error.messages.new) (action - (run + (run menhir --unused-tokens --table @@ -156,8 +157,8 @@ (targets ParErr.ml) (deps Parser.mly ParToken.mly error.messages.checked-in LexToken.mli) (action - (with-stdout-to %{targets} - (run + (with-stdout-to %{targets} + (run menhir --unused-tokens --table @@ -170,4 +171,3 @@ ) )) ) - diff --git a/src/passes/1-parser/reasonligo.ml b/src/passes/1-parser/reasonligo.ml index d1a5046dc..85f9557e4 100644 --- a/src/passes/1-parser/reasonligo.ml +++ b/src/passes/1-parser/reasonligo.ml @@ -2,31 +2,51 @@ open Trace module AST = Parser_cameligo.AST module LexToken = Parser_reasonligo.LexToken -module Lexer = Lexer.Make(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 SSet = Utils.String.Set +module SSet = Set.Make (String) (* Mock IOs TODO: Fill them with CLI options *) -module type IO = - sig - val ext : string - val options : EvalOpt.options - end +type language = [`PascaLIGO | `CameLIGO | `ReasonLIGO] -module PreIO = +module SubIO = struct - let ext = ".ligo" - let pre_options = - EvalOpt.make ~libs:[] - ~verbose:SSet.empty - ~offsets:true - ~mode:`Point - ~cmd:EvalOpt.Quiet - ~mono:false + type options = < + libs : string list; + verbose : SSet.t; + offsets : bool; + lang : language; + ext : string; (* ".religo" *) + mode : [`Byte | `Point]; + cmd : EvalOpt.command; + mono : bool + > + + let options : options = + object + method libs = [] + method verbose = SSet.empty + method offsets = true + method lang = `ReasonLIGO + method ext = ".religo" + method mode = `Point + method cmd = EvalOpt.Quiet + method mono = false + end + + let make = + EvalOpt.make ~libs:options#libs + ~verbose:options#verbose + ~offsets:options#offsets + ~lang:options#lang + ~ext:options#ext + ~mode:options#mode + ~cmd:options#cmd + ~mono:options#mono end module Parser = @@ -43,8 +63,8 @@ module ParserLog = include Parser_cameligo.ParserLog end -module PreUnit = - ParserUnit.Make (Lexer)(AST)(Parser)(ParErr)(ParserLog) +module Unit = + ParserUnit.Make (Lexer)(AST)(Parser)(ParErr)(ParserLog)(SubIO) module Errors = struct @@ -55,23 +75,23 @@ module Errors = let wrong_function_arguments (expr: AST.expr) = let title () = "" in - let message () = "It looks like you are defining a function, \ - however we do not\n\ - understand the parameters declaration.\n\ - Examples of valid functions:\n\ - let x = (a: string, b: int) : int => 3;\n\ - let tuple = ((a, b): (int, int)) => a + b; \n\ - let x = (a: string) : string => \"Hello, \" ++ a;\n" - in + let message () = + "It looks like you are defining a function, \ + however we do not\n\ + understand the parameters declaration.\n\ + Examples of valid functions:\n\ + let x = (a: string, b: int) : int => 3;\n\ + let tuple = ((a, b): (int, int)) => a + b; \n\ + let x = (a: string) : string => \"Hello, \" ++ a;\n" in let expression_loc = AST.expr_to_region expr in let data = [ ("location", fun () -> Format.asprintf "%a" Location.pp_lift @@ expression_loc)] in error ~data title message - - let invalid_wild (expr: AST.expr) = + + let invalid_wild (expr: AST.expr) = let title () = "" in - let message () = + let message () = "It looks like you are using a wild pattern where it cannot be used." in let expression_loc = AST.expr_to_region expr in @@ -82,13 +102,12 @@ module Errors = end -let parse (module IO : IO) parser = - let module Unit = PreUnit (IO) in +let apply parser = let local_fail error = Trace.fail @@ Errors.generic - @@ Unit.format_error ~offsets:IO.options#offsets - IO.options#mode error in + @@ Unit.format_error ~offsets:SubIO.options#offsets + SubIO.options#mode error in match parser () with Stdlib.Ok semantic_value -> Trace.ok semantic_value @@ -142,71 +161,18 @@ let parse (module IO : IO) parser = | exception SyntaxError.Error (SyntaxError.InvalidWild expr) -> Trace.fail @@ Errors.invalid_wild 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 = - 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 +(* Parsing a contract in a file *) -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_file source = apply (fun () -> Unit.contract_in_file source) -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 +(* Parsing a contract in a string *) + +let parse_string source = apply (fun () -> Unit.contract_in_string source) + +(* Parsing an expression in a string *) + +let parse_expression source = apply (fun () -> Unit.expr_in_string source) + +(* Preprocessing a contract in a file *) + +let preprocess source = apply (fun () -> Unit.preprocess source) diff --git a/src/passes/1-parser/reasonligo.mli b/src/passes/1-parser/reasonligo.mli new file mode 100644 index 000000000..890618a95 --- /dev/null +++ b/src/passes/1-parser/reasonligo.mli @@ -0,0 +1,21 @@ +(** This file provides an interface to the ReasonLIGO parser. *) + +module AST = Parser_cameligo.AST + +(** Open a ReasonLIGO filename given by string and convert into an + abstract syntax tree. *) +val parse_file : string -> AST.t Trace.result + +(** Convert a given string into a ReasonLIGO abstract syntax tree *) +val parse_string : string -> AST.t Trace.result + +(** Parse a given string as a ReasonLIGO expression and return an + expression AST. + + This is intended to be used for interactive interpreters, or other + scenarios where you would want to parse a ReasonLIGO expression + outside of a contract. *) +val parse_expression : string -> AST.expr Trace.result + +(** Preprocess a given ReasonLIGO file and preprocess it. *) +val preprocess : string -> Buffer.t Trace.result diff --git a/src/passes/1-parser/reasonligo/.links b/src/passes/1-parser/reasonligo/.links index d93e4b610..2be7fda97 100644 --- a/src/passes/1-parser/reasonligo/.links +++ b/src/passes/1-parser/reasonligo/.links @@ -1,8 +1,5 @@ $HOME/git/OCaml-build/Makefile -$HOME/git/ligo/vendors/ligo-utils/simple-utils/pos.mli -$HOME/git/ligo/vendors/ligo-utils/simple-utils/pos.ml -$HOME/git/ligo/vendors/ligo-utils/simple-utils/region.mli -$HOME/git/ligo/vendors/ligo-utils/simple-utils/region.ml + ../shared/Lexer.mli ../shared/Lexer.mll ../shared/EvalOpt.ml @@ -17,13 +14,17 @@ $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 -Stubs/Simple_utils.ml + Stubs/Parser_cameligo.ml + ../cameligo/AST.ml ../cameligo/ParserLog.mli ../cameligo/ParserLog.ml ../cameligo/Scoping.mli ../cameligo/Scoping.ml -$HOME/git/ligo/_build/default/src/passes/1-parser/reasonligo/ParErr.ml \ No newline at end of file + +$HOME/git/ligo/_build/default/src/passes/1-parser/reasonligo/ParErr.ml diff --git a/src/passes/1-parser/reasonligo/LexerMain.ml b/src/passes/1-parser/reasonligo/LexerMain.ml index 7e8e063da..4f063582f 100644 --- a/src/passes/1-parser/reasonligo/LexerMain.ml +++ b/src/passes/1-parser/reasonligo/LexerMain.ml @@ -4,8 +4,7 @@ module Region = Simple_utils.Region module IO = struct - let ext = ".religo" - let options = EvalOpt.read "ReasonLIGO" ext + let options = EvalOpt.(read ~lang:`ReasonLIGO ~ext:".religo") end module M = LexerUnit.Make (IO) (Lexer.Make (LexToken)) diff --git a/src/passes/1-parser/reasonligo/Makefile.cfg b/src/passes/1-parser/reasonligo/Makefile.cfg index 2f2a6b197..5fcac2934 100644 --- a/src/passes/1-parser/reasonligo/Makefile.cfg +++ b/src/passes/1-parser/reasonligo/Makefile.cfg @@ -2,4 +2,4 @@ SHELL := dash BFLAGS := -strict-sequence -w +A-48-4 -g clean:: -> rm -f Parser.msg Parser.msg.map Parser.msg.states Version.ml +> \rm -f Parser.msg Parser.msg.map Parser.msg.states Version.ml diff --git a/src/passes/1-parser/reasonligo/Parser.mly b/src/passes/1-parser/reasonligo/Parser.mly index 1c6078355..90819ab7a 100644 --- a/src/passes/1-parser/reasonligo/Parser.mly +++ b/src/passes/1-parser/reasonligo/Parser.mly @@ -3,6 +3,7 @@ [@@@warning "-42"] +module Region = Simple_utils.Region open Region module AST = Parser_cameligo.AST open! AST @@ -560,7 +561,7 @@ fun_expr: in raise (Error (WrongFunctionArguments e)) in let binders = fun_args_to_pattern $1 in - let lhs_type = match $1 with + let lhs_type = match $1 with EAnnot {value = {inside = _ , _, t; _}; region = r} -> Some (r,t) | _ -> None in diff --git a/src/passes/1-parser/reasonligo/ParserMain.ml b/src/passes/1-parser/reasonligo/ParserMain.ml index e64aecf0a..82ffc7b32 100644 --- a/src/passes/1-parser/reasonligo/ParserMain.ml +++ b/src/passes/1-parser/reasonligo/ParserMain.ml @@ -1,9 +1,47 @@ -(** Driver for the ReasonLIGO parser *) +(* Driver for the ReasonLIGO parser *) + +module Region = Simple_utils.Region +module SSet = Set.Make (String) module IO = struct - let ext = ".religo" - let options = EvalOpt.read "ReasonLIGO" ext + let options = EvalOpt.(read ~lang:`ReasonLIGO ~ext:".religo") + end + +module SubIO = + struct + type options = < + libs : string list; + verbose : SSet.t; + offsets : bool; + lang : EvalOpt.language; + ext : string; + mode : [`Byte | `Point]; + cmd : EvalOpt.command; + mono : bool + > + + let options : options = + object + method libs = IO.options#libs + method verbose = IO.options#verbose + method offsets = IO.options#offsets + method lang = IO.options#lang + method ext = IO.options#ext + method mode = IO.options#mode + method cmd = IO.options#cmd + method mono = IO.options#mono + end + + let make = + EvalOpt.make ~libs:options#libs + ~verbose:options#verbose + ~offsets:options#offsets + ~lang:options#lang + ~ext:options#ext + ~mode:options#mode + ~cmd:options#cmd + ~mono:options#mono end module Parser = @@ -23,138 +61,16 @@ module ParserLog = module Lexer = Lexer.Make (LexToken) module Unit = - ParserUnit.Make (Lexer)(AST)(Parser)(ParErr)(ParserLog)(IO) + ParserUnit.Make (Lexer)(AST)(Parser)(ParErr)(ParserLog)(SubIO) (* Main *) -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 Region.reg) Stdlib.result = - try parser () with - (* Ad hoc errors from the parser *) - - SyntaxError.Error (SyntaxError.WrongFunctionArguments expr) -> - let msg = "It looks like you are defining a function, \ - however we do not\n\ - understand the parameters declaration.\n\ - Examples of valid functions:\n\ - let x = (a: string, b: int) : int => 3;\n\ - let x = (a: string) : string => \"Hello, \" ++ a;\n" - 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 *) - | SyntaxError.Error (SyntaxError.InvalidWild expr) -> - let msg = "It looks like you are using a wild pattern where it cannot be used.\n" - 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.Error (Scoping.Reserved_name name) -> - let token = - Lexer.Token.mk_ident name.Region.value name.Region.region in - (match token with - (* Cannot fail because [name] is a not a - reserved name for the lexer. *) - Stdlib.Error _ -> assert false - | Ok invalid -> - issue_error - ("Reserved name.\nHint: Change the name.\n", None, invalid)) - - | Scoping.Error (Scoping.Duplicate_variant name) -> - let token = - Lexer.Token.mk_constr name.Region.value name.Region.region in - let point = "Duplicate constructor in this sum type declaration.\n\ - Hint: Change the constructor.\n", - None, token - in issue_error point - - | Scoping.Error (Scoping.Non_linear_pattern var) -> - let token = - Lexer.Token.mk_ident var.Region.value var.Region.region in - (match token with - (* Cannot fail because [var] is a not a - reserved name for the lexer. *) - Stdlib.Error _ -> assert false - | Ok invalid -> - let point = "Repeated variable in this pattern.\n\ - Hint: Change the name.\n", - None, invalid - in issue_error point) - - | Scoping.Error (Scoping.Duplicate_field name) -> - let token = - Lexer.Token.mk_ident name.Region.value name.Region.region in - (match token with - (* Cannot fail because [name] is a not a - 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) - -(* 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 wrap = function + Stdlib.Ok _ -> flush_all () +| Error msg -> + (flush_all (); Printf.eprintf "\027[31m%s\027[0m%!" msg.Region.value) let () = - 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 + match IO.options#input with + None -> Unit.contract_in_stdin () |> wrap + | Some file_path -> Unit.contract_in_file file_path |> wrap diff --git a/src/passes/1-parser/reasonligo/Stubs/Simple_utils.ml b/src/passes/1-parser/reasonligo/Stubs/Simple_utils.ml deleted file mode 100644 index 0360af1b5..000000000 --- a/src/passes/1-parser/reasonligo/Stubs/Simple_utils.ml +++ /dev/null @@ -1,2 +0,0 @@ -module Region = Region -module Pos = Pos diff --git a/src/passes/1-parser/reasonligo/dune b/src/passes/1-parser/reasonligo/dune index 6eb7304b8..f89578a4c 100644 --- a/src/passes/1-parser/reasonligo/dune +++ b/src/passes/1-parser/reasonligo/dune @@ -73,14 +73,13 @@ (action (run %{script_cover} --lex-tokens=LexToken.mli --par-tokens=ParToken.mly --ext=religo --unlexer=./Unlexer.exe --messages=Parser.msg --dir=. --concatenate Parser.mly ))) ;; Error messages - ;; Generate error messages from scratch ; (rule ; (targets error.messages) ; (deps Parser.mly ParToken.mly error.messages.checked-in) ; (action -; (with-stdout-to %{targets} -; (bash +; (with-stdout-to %{targets} +; (bash ; "menhir \ ; --unused-tokens \ ; --list-errors \ @@ -99,11 +98,11 @@ (targets error.messages) (deps Parser.mly ParToken.mly error.messages.checked-in LexToken.mli) (action - (with-stdout-to %{targets} - (run - menhir + (with-stdout-to %{targets} + (run + menhir --unused-tokens - --update-errors error.messages.checked-in + --update-errors error.messages.checked-in --table --strict --external-tokens LexToken.mli @@ -117,8 +116,8 @@ (rule (target error.messages.new) (action - (with-stdout-to %{target} - (run + (with-stdout-to %{target} + (run menhir --unused-tokens --list-errors @@ -137,7 +136,7 @@ (name runtest) (deps error.messages error.messages.new) (action - (run + (run menhir --unused-tokens --table @@ -158,8 +157,8 @@ (targets ParErr.ml) (deps Parser.mly ParToken.mly error.messages.checked-in LexToken.mli) (action - (with-stdout-to %{targets} - (run + (with-stdout-to %{targets} + (run menhir --unused-tokens --table diff --git a/src/passes/1-parser/shared/.links b/src/passes/1-parser/shared/.links index c366f9924..df8a82cd9 100644 --- a/src/passes/1-parser/shared/.links +++ b/src/passes/1-parser/shared/.links @@ -1,7 +1,7 @@ $HOME/git/OCaml-build/Makefile $HOME/git/OCaml-build/Makefile.cfg + $HOME/git/ligo/vendors/ligo-utils/simple-utils/pos.mli $HOME/git/ligo/vendors/ligo-utils/simple-utils/pos.ml $HOME/git/ligo/vendors/ligo-utils/simple-utils/region.mli $HOME/git/ligo/vendors/ligo-utils/simple-utils/region.ml -$HOME/git/ligo/vendors/ligo-utils/simple-utils/region.ml diff --git a/src/passes/1-parser/shared/EvalOpt.ml b/src/passes/1-parser/shared/EvalOpt.ml index 30277f72f..54d971846 100644 --- a/src/passes/1-parser/shared/EvalOpt.ml +++ b/src/passes/1-parser/shared/EvalOpt.ml @@ -1,45 +1,62 @@ -(** Parsing command-line options *) +(* Parsing command-line options *) + +(* The type [command] denotes some possible behaviours of the + compiler. *) -(** The type [command] denotes some possible behaviours of the - compiler. -*) type command = Quiet | Copy | Units | Tokens -(** The type [options] gathers the command-line options. -*) +type language = [`PascaLIGO | `CameLIGO | `ReasonLIGO] + +let lang_to_string = function + `PascaLIGO -> "PascaLIGO" +| `CameLIGO -> "CameLIGO" +| `ReasonLIGO -> "ReasonLIGO" + +(* The type [options] gathers the command-line options. *) + +module SSet = Set.Make (String) + type options = < input : string option; libs : string list; - verbose : Utils.String.Set.t; + verbose : SSet.t; offsets : bool; + lang : language; + ext : string; (* ".ligo", ".mligo", ".religo" *) mode : [`Byte | `Point]; cmd : command; mono : bool; expr : bool > -let make ~input ~libs ~verbose ~offsets ~mode ~cmd ~mono ~expr = +let make ~input ~libs ~verbose ~offsets ~lang ~ext ~mode ~cmd ~mono ~expr : options = object method input = input method libs = libs method verbose = verbose method offsets = offsets + method lang = lang + method ext = ext method mode = mode method cmd = cmd method mono = mono method expr = expr end -(** {1 Auxiliary functions} *) +(* Auxiliary functions *) let printf = Printf.printf let sprintf = Printf.sprintf let print = print_endline -let abort msg = - Utils.highlight (sprintf "Command-line error: %s\n" msg); exit 1 +(* Printing a string in red to standard error *) -(** {1 Help} *) +let highlight msg = Printf.eprintf "\027[31m%s\027[0m%!" msg + +let abort msg = + highlight (sprintf "Command-line error: %s\n" msg); exit 1 + +(* Help *) let help language extension () = let file = Filename.basename Sys.argv.(0) in @@ -55,16 +72,16 @@ let help language extension () = print " --bytes Bytes for source locations"; print " --mono Use Menhir monolithic API"; print " --expr Parse an expression"; - print " --verbose= cli, cpp, ast-tokens, ast (colon-separated)"; + print " --verbose= cli, preproc, ast-tokens, ast (colon-separated)"; print " --version Commit hash on stdout"; print " -h, --help This help"; exit 0 -(** {1 Version} *) +(* Version *) let version () = printf "%s\n" Version.version; exit 0 -(** {1 Specifying the command-line options a la GNU} *) +(* Specifying the command-line options a la GNU *) let copy = ref false and tokens = ref false @@ -72,7 +89,7 @@ and units = ref false and quiet = ref false and columns = ref false and bytes = ref false -and verbose = ref Utils.String.Set.empty +and verbose = ref SSet.empty and input = ref None and libs = ref [] and verb_str = ref "" @@ -84,11 +101,12 @@ let split_at_colon = Str.(split (regexp ":")) let add_path p = libs := !libs @ split_at_colon p let add_verbose d = - verbose := List.fold_left (Utils.swap Utils.String.Set.add) + verbose := List.fold_left (fun x y -> SSet.add y x) !verbose (split_at_colon d) let specs language extension = + let language = lang_to_string language in let open! Getopt in [ 'I', nolong, None, Some add_path; 'c', "copy", set copy true, None; @@ -105,17 +123,15 @@ let specs language extension = ] ;; -(** Handler of anonymous arguments -*) +(* Handler of anonymous arguments *) + let anonymous arg = match !input with None -> input := Some arg - | Some s -> Printf.printf "s=%s\n" s; - abort (sprintf "Multiple inputs") -;; + | Some _ -> abort (sprintf "Multiple inputs") + +(* Checking options and exporting them as non-mutable values *) -(** Checking options and exporting them as non-mutable values -*) let string_of convert = function None -> "None" | Some s -> sprintf "Some %s" (convert s) @@ -139,21 +155,20 @@ let print_opt () = printf "verbose = %s\n" !verb_str; printf "input = %s\n" (string_of quote !input); printf "libs = %s\n" (string_of_path !libs) -;; -let check extension = +let check lang ext = let () = - if Utils.String.Set.mem "cli" !verbose then print_opt () in + if SSet.mem "cli" !verbose then print_opt () in let input = match !input with - None | Some "-" -> !input + None | Some "-" -> None | Some file_path -> - if Filename.check_suffix file_path extension + if Filename.check_suffix file_path ext then if Sys.file_exists file_path then Some file_path else abort "Source file not found." - else abort ("Source file lacks the extension " ^ extension ^ ".") in + else abort ("Source file lacks the extension " ^ ext ^ ".") in (* Exporting remaining options as non-mutable values *) @@ -169,7 +184,7 @@ let check extension = and libs = !libs in let () = - if Utils.String.Set.mem "cli" verbose then + if SSet.mem "cli" verbose then begin printf "\nEXPORTED COMMAND LINE\n"; printf "copy = %b\n" copy; @@ -194,16 +209,16 @@ let check extension = | false, false, false, true -> Tokens | _ -> abort "Choose one of -q, -c, -u, -t." - in make ~input ~libs ~verbose ~offsets ~mode ~cmd ~mono ~expr + in make ~input ~libs ~verbose ~offsets ~mode ~cmd ~mono ~expr ~lang ~ext -(** {1 Parsing the command-line options} *) +(* Parsing the command-line options *) -let read language extension = +let read ~lang ~ext = try - Getopt.parse_cmdline (specs language extension) anonymous; + Getopt.parse_cmdline (specs lang ext) anonymous; (verb_str := let apply e a = if a = "" then e else Printf.sprintf "%s, %s" e a - in Utils.String.Set.fold apply !verbose ""); - check extension + in SSet.fold apply !verbose ""); + check lang ext with Getopt.Error msg -> abort msg diff --git a/src/passes/1-parser/shared/EvalOpt.mli b/src/passes/1-parser/shared/EvalOpt.mli index 95363469c..6ffd0ffce 100644 --- a/src/passes/1-parser/shared/EvalOpt.mli +++ b/src/passes/1-parser/shared/EvalOpt.mli @@ -48,11 +48,20 @@ type command = Quiet | Copy | Units | Tokens expressions is used, otherwise a full-fledged contract is expected.} } *) + +type language = [`PascaLIGO | `CameLIGO | `ReasonLIGO] + +val lang_to_string : language -> string + +module SSet : Set.S with type elt = string and type t = Set.Make(String).t + type options = < input : string option; libs : string list; - verbose : Utils.String.Set.t; + verbose : SSet.t; offsets : bool; + lang : language; + ext : string; (* ".ligo", ".mligo", ".religo" *) mode : [`Byte | `Point]; cmd : command; mono : bool; @@ -62,8 +71,10 @@ type options = < val make : input:string option -> libs:string list -> - verbose:Utils.String.Set.t -> + verbose:SSet.t -> offsets:bool -> + lang:language -> + ext:string -> mode:[`Byte | `Point] -> cmd:command -> mono:bool -> @@ -71,7 +82,7 @@ val make : options (** Parsing the command-line options on stdin. The first parameter is - the name of the concrete syntax, e.g., "pascaligo", and the second - is the file extension, e.g., ".ligo". - *) -val read : string -> string -> options + the name of the concrete syntax, e.g., [PascaLIGO], and the second + is the expected file extension, e.g., ".ligo". *) + +val read : lang:language -> ext:string -> options diff --git a/src/passes/1-parser/shared/Lexer.mli b/src/passes/1-parser/shared/Lexer.mli index 1d6180104..60e3be89b 100644 --- a/src/passes/1-parser/shared/Lexer.mli +++ b/src/passes/1-parser/shared/Lexer.mli @@ -135,7 +135,14 @@ module type S = val slide : token -> window -> window + type input = + File of file_path + | String of string + | Channel of in_channel + | Buffer of Lexing.lexbuf + type instance = { + input : input; read : log:logger -> Lexing.lexbuf -> token; buffer : Lexing.lexbuf; get_win : unit -> window; @@ -145,16 +152,15 @@ module type S = close : unit -> unit } - 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 + val lexbuf_from_input : + input -> (Lexing.lexbuf * (unit -> unit), open_err) Stdlib.result + + type language = [`PascaLIGO | `CameLIGO | `ReasonLIGO] + + val open_token_stream : + language -> input -> (instance, open_err) Stdlib.result (* Error reporting *) diff --git a/src/passes/1-parser/shared/Lexer.mll b/src/passes/1-parser/shared/Lexer.mll index 569486ef7..a67e438c8 100644 --- a/src/passes/1-parser/shared/Lexer.mll +++ b/src/passes/1-parser/shared/Lexer.mll @@ -157,7 +157,14 @@ module type S = val slide : token -> window -> window + type input = + File of file_path + | String of string + | Channel of in_channel + | Buffer of Lexing.lexbuf + type instance = { + input : input; read : log:logger -> Lexing.lexbuf -> token; buffer : Lexing.lexbuf; get_win : unit -> window; @@ -167,16 +174,15 @@ module type S = close : unit -> unit } - 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 + val lexbuf_from_input : + input -> (Lexing.lexbuf * (unit -> unit), open_err) Stdlib.result + + type language = [`PascaLIGO | `CameLIGO | `ReasonLIGO] + + val open_token_stream : + language -> input -> (instance, open_err) Stdlib.result (* Error reporting *) @@ -254,7 +260,7 @@ module Make (Token: TOKEN) : (S with module Token = Token) = Nil -> One token | One t | Two (t,_) -> Two (token,t) - (** Beyond tokens, the result of lexing is a state. The type + (* Beyond tokens, the result of lexing is a state. The type [state] represents the logical state of the lexing engine, that is, a value which is threaded during scanning and which denotes useful, high-level information beyond what the type @@ -292,6 +298,9 @@ module Make (Token: TOKEN) : (S with module Token = Token) = it to [decoder]. See the documentation of the third-party library Uutf. *) + + type language = [`PascaLIGO | `CameLIGO | `ReasonLIGO] + type state = { units : (Markup.t list * token) FQueue.t; markup : Markup.t list; @@ -299,7 +308,8 @@ module Make (Token: TOKEN) : (S with module Token = Token) = last : Region.t; pos : Pos.t; decoder : Uutf.decoder; - supply : Bytes.t -> int -> int -> unit + supply : Bytes.t -> int -> int -> unit; + lang : language } (* The call [enqueue (token, state)] updates functionally the @@ -388,7 +398,7 @@ module Make (Token: TOKEN) : (S with module Token = Token) = | Unterminated_string | Unterminated_integer | Odd_lengthed_bytes - | Unterminated_comment + | Unterminated_comment of string | Orphan_minus | Non_canonical_zero | Negative_byte_sequence @@ -401,51 +411,51 @@ module Make (Token: TOKEN) : (S with module Token = Token) = let error_to_string = function Invalid_utf8_sequence -> - "Invalid UTF-8 sequence.\n" + "Invalid UTF-8 sequence." | Unexpected_character c -> - sprintf "Unexpected character '%s'.\n" (Char.escaped c) + sprintf "Unexpected character '%s'." (Char.escaped c) | Undefined_escape_sequence -> "Undefined escape sequence.\n\ - Hint: Remove or replace the sequence.\n" + Hint: Remove or replace the sequence." | Missing_break -> "Missing break.\n\ - Hint: Insert some space.\n" + Hint: Insert some space." | Unterminated_string -> "Unterminated string.\n\ - Hint: Close with double quotes.\n" + Hint: Close with double quotes." | Unterminated_integer -> "Unterminated integer.\n\ - Hint: Remove the sign or proceed with a natural number.\n" + Hint: Remove the sign or proceed with a natural number." | Odd_lengthed_bytes -> "The length of the byte sequence is an odd number.\n\ - Hint: Add or remove a digit.\n" - | Unterminated_comment -> - "Unterminated comment.\n\ - Hint: Close with \"*)\".\n" + Hint: Add or remove a digit." + | Unterminated_comment ending -> + sprintf "Unterminated comment.\n\ + Hint: Close with \"%s\"." ending | Orphan_minus -> "Orphan minus sign.\n\ - Hint: Remove the trailing space.\n" + Hint: Remove the trailing space." | Non_canonical_zero -> "Non-canonical zero.\n\ - Hint: Use 0.\n" + Hint: Use 0." | Negative_byte_sequence -> "Negative byte sequence.\n\ - Hint: Remove the leading minus sign.\n" + Hint: Remove the leading minus sign." | Broken_string -> "The string starting here is interrupted by a line break.\n\ Hint: Remove the break, close the string before or insert a \ - backslash.\n" + backslash." | Invalid_character_in_string -> "Invalid character in string.\n\ - Hint: Remove or replace the character.\n" + Hint: Remove or replace the character." | Reserved_name s -> sprintf "Reserved name: \"%s\".\n\ - Hint: Change the name.\n" s + Hint: Change the name." s | Invalid_symbol -> "Invalid symbol.\n\ - Hint: Check the LIGO syntax you use.\n" + Hint: Check the LIGO syntax you use." | Invalid_natural -> - "Invalid natural." + "Invalid natural number." | Invalid_attribute -> "Invalid attribute." @@ -454,7 +464,7 @@ 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 - let value = sprintf "Lexical error %s:\n%s" reg msg + let value = sprintf "Lexical error %s:\n%s\n" reg msg in Region.{value; region} let fail region value = raise (Error Region.{region; value}) @@ -618,16 +628,16 @@ rule init state = parse and scan state = parse nl { scan (push_newline state lexbuf) lexbuf } | ' '+ { scan (push_space state lexbuf) lexbuf } -| '\t'+ { scan (push_tabs state lexbuf) lexbuf } +| '\t'+ { scan (push_tabs state lexbuf) lexbuf } | ident { mk_ident state lexbuf |> enqueue } | constr { mk_constr state lexbuf |> enqueue } | bytes { mk_bytes seq state lexbuf |> enqueue } | natural 'n' { mk_nat state lexbuf |> enqueue } | natural "mutez" { mk_mutez state lexbuf |> enqueue } | natural "tz" -| natural "tez" { mk_tez state lexbuf |> enqueue } +| natural "tez" { mk_tez state lexbuf |> enqueue } | decimal "tz" -| decimal "tez" { mk_tez_decimal state lexbuf |> enqueue } +| decimal "tez" { mk_tez_decimal state lexbuf |> enqueue } | natural { mk_int state lexbuf |> enqueue } | symbol { mk_sym state lexbuf |> enqueue } | eof { mk_eof state lexbuf |> enqueue } @@ -638,31 +648,43 @@ and scan state = parse let thread = {opening; len=1; acc=['"']} in scan_string thread state lexbuf |> mk_string |> enqueue } -| "(*" { let opening, _, state = sync state lexbuf in - let thread = {opening; len=2; acc=['*';'(']} in - let state = scan_block thread state lexbuf |> push_block - in scan state lexbuf } +| "(*" { if state.lang = `PascaLIGO || state.lang = `CameLIGO then + let opening, _, state = sync state lexbuf in + let thread = {opening; len=2; acc=['*';'(']} in + let state = scan_pascaligo_block thread state lexbuf |> push_block + in scan state lexbuf + else (rollback lexbuf; scan_two_sym state lexbuf) + } + +| "/*" { if state.lang = `ReasonLIGO then + let opening, _, state = sync state lexbuf in + let thread = {opening; len=2; acc=['*';'/']} in + let state = scan_reasonligo_block thread state lexbuf |> push_block + in scan state lexbuf + else (rollback lexbuf; scan_two_sym state lexbuf) + } | "//" { let opening, _, state = sync state lexbuf in let thread = {opening; len=2; acc=['/';'/']} in let state = scan_line thread state lexbuf |> push_line in scan state lexbuf } - (* Management of #include CPP directives + (* Management of #include preprocessing directives - An input LIGO program may contain GNU CPP (C preprocessor) - directives, and the entry modules (named *Main.ml) run CPP on them - in traditional mode: + An input LIGO program may contain preprocessing directives, and + the entry modules (named *Main.ml) run the preprocessor on them, + as if using the GNU C preprocessor in traditional mode: https://gcc.gnu.org/onlinedocs/cpp/Traditional-Mode.html - The main interest in using CPP is that it can stand for a poor - man's (flat) module system for LIGO thanks to #include - directives, and the traditional mode leaves the markup mostly - undisturbed. + The main interest in using a preprocessor is that it can stand + for a poor man's (flat) module system for LIGO thanks to #include + directives, and the equivalent of the traditional mode leaves the + markup undisturbed. - Some of the #line resulting from processing #include directives - deal with system file headers and thus have to be ignored for our + Contrary to the C preprocessor, our preprocessor does not + generate #line resulting from processing #include directives deal + with system file headers and thus have to be ignored for our purpose. Moreover, these #line directives may also carry some additional flags: @@ -671,7 +693,7 @@ and scan state = parse of which 1 and 2 indicate, respectively, the start of a new file and the return from a file (after its inclusion has been processed). - *) + *) | '#' blank* ("line" blank+)? (natural as line) blank+ '"' (string as file) '"' { @@ -714,6 +736,14 @@ and scan state = parse | _ as c { let region, _, _ = sync state lexbuf in fail region (Unexpected_character c) } +(* Scanning two symbols *) + +and scan_two_sym state = parse + symbol { scan_one_sym (mk_sym state lexbuf |> enqueue) lexbuf } + +and scan_one_sym state = parse + symbol { scan (mk_sym state lexbuf |> enqueue) lexbuf } + (* Scanning CPP #include flags *) and scan_flags state acc = parse @@ -745,39 +775,70 @@ and scan_string thread state = parse (* Finishing a block comment - (Note for Emacs: ("(*") - The lexing of block comments must take care of embedded block - comments that may occur within, as well as strings, so no substring - "*)" may inadvertently close the block. This is the purpose - of the first case of the scanner [scan_block]. + (For Emacs: ("(*") The lexing of block comments must take care of + embedded block comments that may occur within, as well as strings, + so no substring "*/" or "*)" may inadvertently close the + block. This is the purpose of the first case of the scanners + [scan_pascaligo_block] and [scan_reasonligo_block]. *) -and scan_block thread state = parse +and scan_pascaligo_block thread state = parse '"' | "(*" { let opening = thread.opening in let opening', lexeme, state = sync state lexbuf in let thread = push_string lexeme thread in let thread = {thread with opening=opening'} in let next = if lexeme = "\"" then scan_string - else scan_block in + else scan_pascaligo_block in let thread, state = next thread state lexbuf in let thread = {thread with opening} - in scan_block thread state lexbuf } + in scan_pascaligo_block thread state lexbuf } | "*)" { let _, lexeme, state = sync state lexbuf in push_string lexeme thread, state } | nl as nl { let () = Lexing.new_line lexbuf and state = {state with pos = state.pos#new_line nl} and thread = push_string nl thread - in scan_block thread state lexbuf } -| eof { fail thread.opening Unterminated_comment } + in scan_pascaligo_block thread state lexbuf } +| eof { fail thread.opening (Unterminated_comment "*)") } | _ { let () = rollback lexbuf in let len = thread.len in let thread, - status = scan_utf8 thread state lexbuf in + status = scan_utf8 "*)" thread state lexbuf in let delta = thread.len - len in let pos = state.pos#shift_one_uchar delta in match status with - None -> scan_block thread {state with pos} lexbuf - | Some error -> + Stdlib.Ok () -> + scan_pascaligo_block thread {state with pos} lexbuf + | Error error -> + let region = Region.make ~start:state.pos ~stop:pos + in fail region error } + +and scan_reasonligo_block thread state = parse + '"' | "/*" { let opening = thread.opening in + let opening', lexeme, state = sync state lexbuf in + let thread = push_string lexeme thread in + let thread = {thread with opening=opening'} in + let next = if lexeme = "\"" then scan_string + else scan_reasonligo_block in + let thread, state = next thread state lexbuf in + let thread = {thread with opening} + in scan_reasonligo_block thread state lexbuf } +| "*/" { let _, lexeme, state = sync state lexbuf + in push_string lexeme thread, state } +| nl as nl { let () = Lexing.new_line lexbuf + and state = {state with pos = state.pos#new_line nl} + and thread = push_string nl thread + in scan_reasonligo_block thread state lexbuf } +| eof { fail thread.opening (Unterminated_comment "*/") } +| _ { let () = rollback lexbuf in + let len = thread.len in + let thread, + status = scan_utf8 "*/" thread state lexbuf in + let delta = thread.len - len in + let pos = state.pos#shift_one_uchar delta in + match status with + Stdlib.Ok () -> + scan_reasonligo_block thread {state with pos} lexbuf + | Error error -> let region = Region.make ~start:state.pos ~stop:pos in fail region error } @@ -792,24 +853,36 @@ and scan_line thread state = parse | _ { let () = rollback lexbuf in let len = thread.len in let thread, - status = scan_utf8 thread state lexbuf in + status = scan_utf8_inline thread state lexbuf in let delta = thread.len - len in let pos = state.pos#shift_one_uchar delta in match status with - None -> scan_line thread {state with pos} lexbuf - | Some error -> + Stdlib.Ok () -> + scan_line thread {state with pos} lexbuf + | Error error -> let region = Region.make ~start:state.pos ~stop:pos in fail region error } -and scan_utf8 thread state = parse - eof { fail thread.opening Unterminated_comment } +and scan_utf8 closing thread state = parse + eof { fail thread.opening (Unterminated_comment closing) } | _ as c { let thread = push_char c thread in let lexeme = Lexing.lexeme lexbuf in let () = state.supply (Bytes.of_string lexeme) 0 1 in match Uutf.decode state.decoder with - `Uchar _ -> thread, None - | `Malformed _ -> thread, Some Invalid_utf8_sequence - | `Await -> scan_utf8 thread state lexbuf + `Uchar _ -> thread, Stdlib.Ok () + | `Malformed _ -> thread, Stdlib.Error Invalid_utf8_sequence + | `Await -> scan_utf8 closing thread state lexbuf + | `End -> assert false } + +and scan_utf8_inline thread state = parse + eof { thread, Stdlib.Ok () } +| _ as c { let thread = push_char c thread in + let lexeme = Lexing.lexeme lexbuf in + let () = state.supply (Bytes.of_string lexeme) 0 1 in + match Uutf.decode state.decoder with + `Uchar _ -> thread, Stdlib.Ok () + | `Malformed _ -> thread, Stdlib.Error Invalid_utf8_sequence + | `Await -> scan_utf8_inline thread state lexbuf | `End -> assert false } (* END LEXER DEFINITION *) @@ -863,7 +936,14 @@ and scan_utf8 thread state = parse type logger = Markup.t list -> token -> unit +type input = + File of file_path +| String of string +| Channel of in_channel +| Buffer of Lexing.lexbuf + type instance = { + input : input; read : log:logger -> Lexing.lexbuf -> token; buffer : Lexing.lexbuf; get_win : unit -> window; @@ -873,19 +953,29 @@ type instance = { close : unit -> unit } -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 lexbuf_from_input = function + File path -> + (try + let chan = open_in path in + let close () = close_in chan in + let lexbuf = Lexing.from_channel chan in + let () = + let open Lexing in + lexbuf.lex_curr_p <- {lexbuf.lex_curr_p with pos_fname = path} + in Ok (lexbuf, 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 () -> ()) + +let open_token_stream (lang: language) input = let file_path = match input with - File file_path -> - if file_path = "-" then "" else file_path + File path -> path | _ -> "" in let pos = Pos.min ~file:file_path in let buf_reg = ref (pos#byte, pos#byte) @@ -898,7 +988,8 @@ let open_token_stream input = pos; markup = []; decoder; - supply} in + supply; + lang} in let get_pos () = !state.pos and get_last () = !state.last @@ -966,32 +1057,14 @@ let open_token_stream input = check_right_context token buffer; patch_buffer (Token.to_region token)#byte_pos buffer; token in - - 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 + match lexbuf_from_input input 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} + input; read; buffer; get_win; get_pos; get_last; get_file; close} in Ok instance | Error _ as e -> e diff --git a/src/passes/1-parser/shared/LexerLog.ml b/src/passes/1-parser/shared/LexerLog.ml index bf0cf6dde..1f978f6b2 100644 --- a/src/passes/1-parser/shared/LexerLog.ml +++ b/src/passes/1-parser/shared/LexerLog.ml @@ -7,15 +7,22 @@ module type S = module Lexer : Lexer.S val output_token : - ?offsets:bool -> [`Byte | `Point] -> - EvalOpt.command -> out_channel -> - Markup.t list -> Lexer.token -> unit + ?offsets:bool -> + [`Byte | `Point] -> + EvalOpt.command -> + out_channel -> + Markup.t list -> + Lexer.token -> + unit type file_path = string val trace : - ?offsets:bool -> [`Byte | `Point] -> - file_path option -> EvalOpt.command -> + ?offsets:bool -> + [`Byte | `Point] -> + EvalOpt.language -> + Lexer.input -> + EvalOpt.command -> (unit, string Region.reg) Stdlib.result end @@ -49,16 +56,12 @@ module Make (Lexer: Lexer.S) : (S with module Lexer = Lexer) = type file_path = string - let trace ?(offsets=true) mode file_path_opt command : + let trace ?(offsets=true) mode lang input command : (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 + match Lexer.open_token_stream lang input with Ok Lexer.{read; buffer; close; _} -> let log = output_token ~offsets mode command stdout - and close_all () = close (); close_out stdout in + and close_all () = flush_all (); close () in let rec iter () = match read ~log buffer with token -> @@ -66,15 +69,11 @@ module Make (Lexer: Lexer.S) : (S with module Lexer = Lexer) = 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 + Lexer.format_error ~offsets mode ~file:true 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) + flush_all (); 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 3e4776889..e4bd05133 100644 --- a/src/passes/1-parser/shared/LexerLog.mli +++ b/src/passes/1-parser/shared/LexerLog.mli @@ -5,15 +5,22 @@ module type S = module Lexer : Lexer.S val output_token : - ?offsets:bool -> [`Byte | `Point] -> - EvalOpt.command -> out_channel -> - Markup.t list -> Lexer.token -> unit + ?offsets:bool -> + [`Byte | `Point] -> + EvalOpt.command -> + out_channel -> + Markup.t list -> + Lexer.token -> + unit type file_path = string val trace : - ?offsets:bool -> [`Byte | `Point] -> - file_path option -> EvalOpt.command -> + ?offsets:bool -> + [`Byte | `Point] -> + EvalOpt.language -> + Lexer.input -> + EvalOpt.command -> (unit, string Region.reg) Stdlib.result end diff --git a/src/passes/1-parser/shared/LexerUnit.ml b/src/passes/1-parser/shared/LexerUnit.ml index 6088ceb27..07837766c 100644 --- a/src/passes/1-parser/shared/LexerUnit.ml +++ b/src/passes/1-parser/shared/LexerUnit.ml @@ -1,110 +1,112 @@ -(* Functor to build a standalone LIGO lexer *) +(* Functor to build a LIGO lexer *) module Region = Simple_utils.Region +module Preproc = Preprocessor.Preproc +module SSet = Set.Make (String) module type IO = sig - val ext : string (* LIGO file extension *) val options : EvalOpt.options (* CLI options *) end module Make (IO: IO) (Lexer: Lexer.S) = struct - open Printf - module SSet = Utils.String.Set - (* Error printing and exception tracing *) let () = Printexc.record_backtrace true - (* 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 Utils.String.Set.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 - - (* Running the lexer on the input file *) + (* Preprocessing and lexing the input source *) let scan () : (Lexer.token list, string Region.reg) Stdlib.result = - (* Preprocessing the input *) + (* Preprocessing the input source *) - if SSet.mem "cpp" IO.options#verbose - then eprintf "%s\n%!" cpp_cmd - else (); + let preproc cin = + let buffer = Lexing.from_channel cin in + let open Lexing in + let () = + match IO.options#input with + None -> () + | Some pos_fname -> + buffer.lex_curr_p <- {buffer.lex_curr_p with pos_fname} in + let opt = (IO.options :> Preprocessor.EvalOpt.options) in + match Preproc.lex opt buffer with + Stdlib.Error (pp_buffer, err) -> + if SSet.mem "preproc" IO.options#verbose then + Printf.printf "%s\n%!" (Buffer.contents pp_buffer); + let formatted = + Preproc.format ~offsets:IO.options#offsets ~file:true err + in Stdlib.Error formatted + | Stdlib.Ok pp_buffer -> + (* Running the lexer on the preprocessed input *) - if Sys.command cpp_cmd <> 0 then - let msg = - sprintf "External error: the command \"%s\" failed." cpp_cmd - in Stdlib.Error (Region.wrap_ghost msg) - else - 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) + let source = Lexer.String (Buffer.contents pp_buffer) in + match Lexer.open_token_stream IO.options#lang source with + Ok Lexer.{read; buffer; close; _} -> + let close_all () = flush_all (); close () 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 () = + Printf.eprintf "[LexerUnit] file = %b\n%!" file 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) -> + flush_all (); Stdlib.Error (Region.wrap_ghost msg) in + match IO.options#input with + None -> preproc stdin + | Some file_path -> + try open_in file_path |> preproc with + Sys_error msg -> Stdlib.Error (Region.wrap_ghost msg) - (* Tracing the lexing (effectful) *) + (* Tracing the lexing *) module Log = LexerLog.Make (Lexer) let trace () : (unit, string Region.reg) Stdlib.result = (* Preprocessing the input *) - - if SSet.mem "cpp" IO.options#verbose - then eprintf "%s\n%!" cpp_cmd - else (); - - if Sys.command cpp_cmd <> 0 then - let msg = - sprintf "External error: the command \"%s\" failed." cpp_cmd - in Stdlib.Error (Region.wrap_ghost msg) - else - Log.trace ~offsets:IO.options#offsets - IO.options#mode - (Some pp_input) - IO.options#cmd - + let preproc cin = + let buffer = Lexing.from_channel cin in + let open Lexing in + let () = + match IO.options#input with + None | Some "-" -> () + | Some pos_fname -> + buffer.lex_curr_p <- {buffer.lex_curr_p with pos_fname} in + let opt = (IO.options :> Preprocessor.EvalOpt.options) in + match Preproc.lex opt buffer with + Stdlib.Error (pp_buffer, err) -> + if SSet.mem "preproc" IO.options#verbose then + Printf.printf "%s\n%!" (Buffer.contents pp_buffer); + let formatted = + Preproc.format ~offsets:IO.options#offsets ~file:true err + in Stdlib.Error formatted + | Stdlib.Ok pp_buffer -> + let preproc_str = Buffer.contents pp_buffer in + if SSet.mem "preproc" IO.options#verbose then + begin + Printf.printf "%s\n%!" (Buffer.contents pp_buffer); + Stdlib.Ok () + end + else Log.trace ~offsets:IO.options#offsets + IO.options#mode + IO.options#lang + (Lexer.String preproc_str) + IO.options#cmd + in match IO.options#input with + None -> preproc stdin + | Some file_path -> + try open_in file_path |> preproc with + Sys_error msg -> Stdlib.Error (Region.wrap_ghost msg) end diff --git a/src/passes/1-parser/shared/LexerUnit.mli b/src/passes/1-parser/shared/LexerUnit.mli index 988785e45..804182515 100644 --- a/src/passes/1-parser/shared/LexerUnit.mli +++ b/src/passes/1-parser/shared/LexerUnit.mli @@ -4,7 +4,6 @@ module Region = Simple_utils.Region module type IO = sig - val ext : string (* LIGO file extension *) val options : EvalOpt.options (* CLI options *) end diff --git a/src/passes/1-parser/shared/ParserAPI.ml b/src/passes/1-parser/shared/ParserAPI.ml index a991c8da5..5d4eedbd4 100644 --- a/src/passes/1-parser/shared/ParserAPI.ml +++ b/src/passes/1-parser/shared/ParserAPI.ml @@ -2,10 +2,15 @@ module Region = Simple_utils.Region +type options = < + offsets : bool; + mode : [`Byte | `Point]; + cmd : EvalOpt.command +> + module type IO = sig - val ext : string (* LIGO file extension *) - val options : EvalOpt.options (* CLI options *) + val options : options end module type PARSER = @@ -50,7 +55,7 @@ module type PARSER = (* Main functor *) -module Make (IO : IO) +module Make (IO: IO) (Lexer: Lexer.S) (Parser: PARSER with type token = Lexer.Token.token) (ParErr: sig val message : int -> string end) = @@ -95,14 +100,15 @@ module Make (IO : IO) None -> if Lexer.Token.is_eof invalid then "" else let invalid_lexeme = Lexer.Token.to_lexeme invalid in - Printf.sprintf ", before \"%s\"" invalid_lexeme + Printf.sprintf ", at \"%s\"" invalid_lexeme | Some valid -> let valid_lexeme = Lexer.Token.to_lexeme valid in - let s = Printf.sprintf ", after \"%s\"" valid_lexeme in - if Lexer.Token.is_eof invalid then s + if Lexer.Token.is_eof invalid then + Printf.sprintf ", after \"%s\"" valid_lexeme else let invalid_lexeme = Lexer.Token.to_lexeme invalid in - Printf.sprintf "%s and before \"%s\"" s invalid_lexeme in + Printf.sprintf " at \"%s\", after \"%s\"" + invalid_lexeme valid_lexeme in let header = header ^ trailer in let msg = header ^ (if msg = "" then ".\n" else ":\n" ^ msg) @@ -110,9 +116,9 @@ module Make (IO : IO) let failure get_win checkpoint = let message = ParErr.message (state checkpoint) in - let message = if message = "\n" then + let message = if message = "\n" then (string_of_int (state checkpoint)) ^ ": " - else + else message in match get_win () with @@ -133,20 +139,21 @@ module Make (IO : IO) module Incr = Parser.Incremental module Log = LexerLog.Make (Lexer) - let log = Log.output_token ~offsets:IO.options#offsets - IO.options#mode IO.options#cmd stdout + let log = Log.output_token + ~offsets:IO.options#offsets + IO.options#mode IO.options#cmd stdout let incr_contract Lexer.{read; buffer; get_win; close; _} = let supplier = I.lexer_lexbuf_to_supplier (read ~log) buffer and failure = failure get_win in let parser = Incr.contract buffer.Lexing.lex_curr_p in let ast = I.loop_handle success failure supplier parser - in close (); ast + in flush_all (); close (); ast let incr_expr Lexer.{read; buffer; get_win; close; _} = let supplier = I.lexer_lexbuf_to_supplier (read ~log) buffer and failure = failure get_win in let parser = Incr.interactive_expr buffer.Lexing.lex_curr_p in let expr = I.loop_handle success failure supplier parser - in close (); expr + in flush_all (); close (); expr end diff --git a/src/passes/1-parser/shared/ParserAPI.mli b/src/passes/1-parser/shared/ParserAPI.mli index d4a3791ee..e801db79c 100644 --- a/src/passes/1-parser/shared/ParserAPI.mli +++ b/src/passes/1-parser/shared/ParserAPI.mli @@ -2,10 +2,15 @@ module Region = Simple_utils.Region +type options = < + offsets : bool; + mode : [`Byte | `Point]; + cmd : EvalOpt.command +> + module type IO = sig - val ext : string (* LIGO file extension *) - val options : EvalOpt.options (* CLI options *) + val options : options end (* The signature generated by Menhir with additional type definitions diff --git a/src/passes/1-parser/shared/ParserUnit.ml b/src/passes/1-parser/shared/ParserUnit.ml index a0aced070..3cc9022b4 100644 --- a/src/passes/1-parser/shared/ParserUnit.ml +++ b/src/passes/1-parser/shared/ParserUnit.ml @@ -1,11 +1,26 @@ -(* Functor to build a standalone LIGO parser *) +(* Functor to build a LIGO parser *) -module Region = Simple_utils.Region +module Region = Simple_utils.Region +module Preproc = Preprocessor.Preproc +module SSet = Set.Make (String) -module type IO = +type language = [`PascaLIGO | `CameLIGO | `ReasonLIGO] + +module type SubIO = sig - val ext : string (* LIGO file extension *) - val options : EvalOpt.options (* CLI options *) + type options = < + libs : string list; + verbose : SSet.t; + offsets : bool; + lang : language; + ext : string; (* ".ligo", ".mligo", ".religo" *) + mode : [`Byte | `Point]; + cmd : EvalOpt.command; + mono : bool + > + + val options : options + val make : input:string option -> expr:bool -> EvalOpt.options end module type Pretty = @@ -32,18 +47,18 @@ module Make (Lexer: Lexer.S) (ParErr: sig val message : int -> string end) (ParserLog: Pretty with type ast = AST.t and type expr = AST.expr) - (IO: IO) = + (SubIO: SubIO) = struct open Printf - module SSet = Utils.String.Set + module SSet = Set.Make (String) (* Log of the lexer *) module Log = LexerLog.Make (Lexer) let log = - Log.output_token ~offsets:IO.options#offsets - IO.options#mode IO.options#cmd stdout + Log.output_token ~offsets:SubIO.options#offsets + SubIO.options#mode SubIO.options#cmd stdout (* Error handling (reexported from [ParserAPI]) *) @@ -54,7 +69,12 @@ module Make (Lexer: Lexer.S) (* Instantiating the parser *) - module Front = ParserAPI.Make (IO)(Lexer)(Parser)(ParErr) + module API_IO = + struct + let options = (SubIO.options :> ParserAPI.options) + end + + module Front = ParserAPI.Make (API_IO)(Lexer)(Parser)(ParErr) let format_error = Front.format_error @@ -67,13 +87,13 @@ module Make (Lexer: Lexer.S) (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 + ParserLog.mk_state ~offsets:SubIO.options#offsets + ~mode:SubIO.options#mode ~buffer:output in let close () = lexer_inst.Lexer.close () in let expr = try - if IO.options#mono then + if SubIO.options#mono then let tokeniser = lexer_inst.Lexer.read ~log and lexbuf = lexer_inst.Lexer.buffer in Front.mono_expr tokeniser lexbuf @@ -81,20 +101,20 @@ module Make (Lexer: Lexer.S) Front.incr_expr lexer_inst with exn -> close (); raise exn in let () = - if SSet.mem "ast-tokens" IO.options#verbose then + if SSet.mem "ast-tokens" SubIO.options#verbose then begin Buffer.clear output; ParserLog.print_expr state expr; Buffer.output_buffer stdout output end in let () = - if SSet.mem "ast" IO.options#verbose then + if SSet.mem "ast" SubIO.options#verbose then begin Buffer.clear output; ParserLog.pp_expr state expr; Buffer.output_buffer stdout output end - in close (); Ok expr + in flush_all (); close (); Ok expr (* Parsing a contract *) @@ -102,13 +122,13 @@ module Make (Lexer: Lexer.S) (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 + ParserLog.mk_state ~offsets:SubIO.options#offsets + ~mode:SubIO.options#mode ~buffer:output in let close () = lexer_inst.Lexer.close () in let ast = try - if IO.options#mono then + if SubIO.options#mono then let tokeniser = lexer_inst.Lexer.read ~log and lexbuf = lexer_inst.Lexer.buffer in Front.mono_contract tokeniser lexbuf @@ -116,25 +136,23 @@ module Make (Lexer: Lexer.S) Front.incr_contract lexer_inst with exn -> close (); raise exn in let () = - if SSet.mem "ast-tokens" IO.options#verbose then + if SSet.mem "ast-tokens" SubIO.options#verbose then begin Buffer.clear output; ParserLog.print_tokens state ast; Buffer.output_buffer stdout output end in let () = - if SSet.mem "ast" IO.options#verbose then + if SSet.mem "ast" SubIO.options#verbose then begin Buffer.clear output; ParserLog.pp_ast state ast; Buffer.output_buffer stdout output end - in close (); Ok ast + in flush_all (); close (); Ok ast (* Wrapper for the parsers above *) - type 'a parser = Lexer.instance -> ('a, message Region.reg) result - let apply lexer_inst parser = (* Calling the parser and filtering errors *) @@ -146,20 +164,18 @@ module Make (Lexer: Lexer.S) | exception Lexer.Error err -> let file = - match IO.options#input with - None | Some "-" -> false - | Some _ -> true in + lexer_inst.Lexer.buffer.Lexing.lex_curr_p.Lexing.pos_fname in let error = - Lexer.format_error ~offsets:IO.options#offsets - IO.options#mode err ~file + Lexer.format_error ~offsets:SubIO.options#offsets + SubIO.options#mode err ~file:(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 + Front.format_error ~offsets:SubIO.options#offsets + SubIO.options#mode point in Stdlib.Error error (* Monolithic API of Menhir *) @@ -169,16 +185,106 @@ module Make (Lexer: Lexer.S) 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 + | Lexer.One invalid -> invalid, None + | Lexer.Two (invalid, valid) -> invalid, Some valid in let point = "", valid_opt, invalid in let error = - Front.format_error ~offsets:IO.options#offsets - IO.options#mode point + Front.format_error ~offsets:SubIO.options#offsets + SubIO.options#mode point in Stdlib.Error error (* I/O errors *) | exception Sys_error error -> - Stdlib.Error (Region.wrap_ghost error) + flush_all (); Stdlib.Error (Region.wrap_ghost error) + + (* Preprocessing the input source *) + + let preproc options lexbuf = + Preproc.lex (options :> Preprocessor.EvalOpt.options) lexbuf + + (* Parsing a contract *) + + let gen_parser options input parser = + match Lexer.lexbuf_from_input input with + Stdlib.Error (Lexer.File_opening msg) -> + Stdlib.Error (Region.wrap_ghost msg) + | Ok (lexbuf, close) -> + (* Preprocessing the input source *) + let file = Lexing.(lexbuf.lex_curr_p.pos_fname) in + match preproc options lexbuf with + Stdlib.Error (pp_buffer, err) -> + if SSet.mem "preproc" options#verbose then + Printf.printf "%s\n%!" (Buffer.contents pp_buffer); + let formatted = + Preproc.format ~offsets:options#offsets + ~file:(file <> "") + err + in close (); Stdlib.Error formatted + | Stdlib.Ok buffer -> + (* Lexing and parsing the preprocessed input source *) + + let () = close () in + let input' = Lexer.String (Buffer.contents buffer) in + match Lexer.open_token_stream options#lang input' with + Ok instance -> + let open Lexing in + instance.Lexer.buffer.lex_curr_p <- + {instance.Lexer.buffer.lex_curr_p with pos_fname = file}; + apply instance parser + | Stdlib.Error (Lexer.File_opening msg) -> + Stdlib.Error (Region.wrap_ghost msg) + + (* Parsing a contract in a file *) + + let contract_in_file (source : string) = + let options = SubIO.make ~input:(Some source) ~expr:false + in gen_parser options (Lexer.File source) parse_contract + + (* Parsing a contract in a string *) + + let contract_in_string (source : string) = + let options = SubIO.make ~input:None ~expr:false in + gen_parser options (Lexer.String source) parse_contract + + (* Parsing a contract in stdin *) + + let contract_in_stdin () = + let options = SubIO.make ~input:None ~expr:false in + gen_parser options (Lexer.Channel stdin) parse_contract + + (* Parsing an expression in a string *) + + let expr_in_string (source : string) = + let options = SubIO.make ~input:None ~expr:true in + gen_parser options (Lexer.String source) parse_expr + + (* Parsing an expression in stdin *) + + let expr_in_stdin () = + let options = SubIO.make ~input:None ~expr:true in + gen_parser options (Lexer.Channel stdin) parse_expr + + (* Preprocess only *) + + let preprocess (source : string) = + let options = SubIO.make ~input:(Some source) ~expr:false in + try + let cin = open_in source in + let lexbuf = Lexing.from_channel cin in + let () = + let open Lexing in + lexbuf.lex_curr_p <- {lexbuf.lex_curr_p with pos_fname=source} + and options = (options :> Preprocessor.EvalOpt.options) in + match Preprocessor.Preproc.lex options lexbuf with + Stdlib.Ok _ as ok -> ok + | Error (_, err) -> + let formatted = + Preproc.format ~offsets:options#offsets + ~file:true + err + in close_in cin; Stdlib.Error formatted + with Sys_error error -> + flush_all (); 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 645808757..ebf577331 100644 --- a/src/passes/1-parser/shared/ParserUnit.mli +++ b/src/passes/1-parser/shared/ParserUnit.mli @@ -2,10 +2,25 @@ module Region = Simple_utils.Region -module type IO = +type language = [`PascaLIGO | `CameLIGO | `ReasonLIGO] + +module SSet : Set.S with type elt = string and type t = Set.Make(String).t + +module type SubIO = sig - val ext : string (* LIGO file extension *) - val options : EvalOpt.options (* CLI options *) + type options = < + libs : string list; + verbose : SSet.t; + offsets : bool; + lang : language; + ext : string; (* ".ligo", ".mligo", ".religo" *) + mode : [`Byte | `Point]; + cmd : EvalOpt.command; + mono : bool + > + + val options : options + val make : input:string option -> expr:bool -> EvalOpt.options end module type Pretty = @@ -32,7 +47,7 @@ module Make (Lexer : Lexer.S) (ParErr : sig val message : int -> string end) (ParserLog : Pretty with type ast = AST.t and type expr = AST.expr) - (IO: IO) : + (SubIO: SubIO) : sig (* Error handling reexported from [ParserAPI] without the exception [Point] *) @@ -50,10 +65,21 @@ module Make (Lexer : Lexer.S) (* Parsers *) - type 'a parser = Lexer.instance -> ('a, message Region.reg) result + val contract_in_file : + string -> (AST.t, message Region.reg) Stdlib.result - val apply : Lexer.instance -> 'a parser -> ('a, message Region.reg) result + val contract_in_string : + string -> (AST.t, message Region.reg) Stdlib.result - val parse_contract : AST.t parser - val parse_expr : AST.expr parser - end + val contract_in_stdin : + unit -> (AST.t, message Region.reg) Stdlib.result + + val expr_in_string : + string -> (AST.expr, message Region.reg) Stdlib.result + + val expr_in_stdin : + unit -> (AST.expr, message Region.reg) Stdlib.result + + val preprocess : + string -> (Buffer.t, message Region.reg) Stdlib.result +end diff --git a/src/passes/1-parser/shared/dune b/src/passes/1-parser/shared/dune index 10e377a93..870ddb3c6 100644 --- a/src/passes/1-parser/shared/dune +++ b/src/passes/1-parser/shared/dune @@ -8,7 +8,8 @@ simple-utils uutf getopt - zarith) + zarith + Preprocessor) (preprocess (pps bisect_ppx --conditional)) (modules @@ -17,8 +18,8 @@ ParserAPI Lexer LexerLog - Utils Markup + Utils FQueue EvalOpt Version)) diff --git a/src/passes/2-concrete_to_imperative/cameligo.ml b/src/passes/2-concrete_to_imperative/cameligo.ml index 0fea68765..b685feb58 100644 --- a/src/passes/2-concrete_to_imperative/cameligo.ml +++ b/src/passes/2-concrete_to_imperative/cameligo.ml @@ -120,7 +120,7 @@ module Errors = struct let data = [ ("expression" , (** TODO: The labelled arguments should be flowing from the CLI. *) - thunk @@ Parser.Cameligo.ParserLog.expr_to_string + thunk @@ Parser_cameligo.ParserLog.expr_to_string ~offsets:true ~mode:`Point t)] in error ~data title message @@ -204,7 +204,7 @@ let rec typed_pattern_to_typed_vars : Raw.pattern -> _ = fun pattern -> | Raw.PPar pp -> typed_pattern_to_typed_vars pp.value.inside | Raw.PTyped pt -> let (p,t) = pt.value.pattern,pt.value.type_expr in - let%bind p = tuple_pattern_to_vars p in + let%bind p = tuple_pattern_to_vars p in let%bind t = compile_type_expression t in ok @@ (p,t) | other -> (fail @@ wrong_pattern "parenthetical or type annotation" other) @@ -320,7 +320,7 @@ let rec compile_expression : | [] -> e_variable (Var.of_name name) | _ -> let aux expr (Label l) = e_record_accessor expr l in - List.fold_left aux (e_variable (Var.of_name name)) path in + List.fold_left aux (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) = @@ -330,13 +330,13 @@ let rec compile_expression : in bind_map_list aux @@ npseq_to_list updates in - let aux ur (path, expr) = + let aux ur (path, expr) = let rec aux record = function | [] -> failwith "error in parsing" | hd :: [] -> ok @@ e_record_update ~loc record hd expr - | hd :: tl -> + | hd :: tl -> let%bind expr = (aux (e_record_accessor ~loc record hd) tl) in - ok @@ e_record_update ~loc record hd expr + ok @@ e_record_update ~loc record hd expr in aux ur path in bind_fold_list aux record updates' @@ -392,9 +392,9 @@ let rec compile_expression : (chain_let_in tl body) | [] -> body (* Precluded by corner case assertion above *) in - let%bind ty_opt = match ty_opt with - | None -> (match let_rhs with - | EFun {value={binders;lhs_type}} -> + let%bind ty_opt = match ty_opt with + | None -> (match let_rhs with + | EFun {value={binders;lhs_type}} -> let f_args = nseq_to_list (binders) in let%bind lhs_type' = bind_map_option (fun x -> compile_type_expression (snd x)) lhs_type in let%bind ty = bind_map_list typed_pattern_to_typed_vars f_args in @@ -409,12 +409,12 @@ let rec compile_expression : (* Bind the right hand side so we only evaluate it once *) else ok (e_let_in (rhs_b, ty_opt) inline rhs' (chain_let_in prep_vars body)) in - let%bind ret_expr = match kwd_rec with + let%bind ret_expr = match kwd_rec with | None -> ok @@ ret_expr - | Some _ -> - match ret_expr.expression_content with + | Some _ -> + match ret_expr.expression_content with | E_let_in li -> ( - let%bind lambda = + let%bind lambda = let rec aux rhs = match rhs.expression_content with | E_lambda l -> ok @@ l | E_ascription a -> aux a.anno_expr @@ -423,9 +423,9 @@ let rec compile_expression : aux rhs' in let fun_name = fst @@ List.hd prep_vars in - let%bind fun_type = match ty_opt with + let%bind fun_type = match ty_opt with | Some t -> ok @@ t - | None -> match rhs'.expression_content with + | None -> match rhs'.expression_content with | E_ascription a -> ok a.type_annotation | _ -> fail @@ untyped_recursive_function e in @@ -878,9 +878,9 @@ and compile_declaration : Raw.declaration -> declaration Location.wrap list resu ok (Raw.EFun {region=Region.ghost ; value=fun_},List.fold_right' aux lhs_type' ty) in let%bind rhs' = compile_expression let_rhs in - let%bind lhs_type = match lhs_type with - | None -> (match let_rhs with - | EFun {value={binders;lhs_type}} -> + let%bind lhs_type = match lhs_type with + | None -> (match let_rhs with + | EFun {value={binders;lhs_type}} -> let f_args = nseq_to_list (binders) in let%bind lhs_type' = bind_map_option (fun x -> compile_type_expression (snd x)) lhs_type in let%bind ty = bind_map_list typed_pattern_to_typed_vars f_args in @@ -891,13 +891,13 @@ and compile_declaration : Raw.declaration -> declaration Location.wrap list resu | Some t -> ok @@ Some t in let binder = Var.of_name var.value in - let%bind rhs' = match recursive with - None -> ok @@ rhs' - | Some _ -> match rhs'.expression_content with + let%bind rhs' = match recursive with + None -> ok @@ rhs' + | Some _ -> match rhs'.expression_content with E_lambda lambda -> - (match lhs_type with - None -> fail @@ untyped_recursive_function var - | Some (lhs_type) -> + (match lhs_type with + None -> fail @@ untyped_recursive_function var + | Some (lhs_type) -> let expression_content = E_recursive {fun_name=binder;fun_type=lhs_type;lambda} in ok @@ {rhs' with expression_content}) | _ -> ok @@ rhs' @@ -996,7 +996,7 @@ and compile_cases : type a . (Raw.pattern * a) list -> (a, unit) matching_conten (** TODO: The labelled arguments should be flowing from the CLI. *) let content () = Printf.sprintf "Pattern : %s" - (Parser.Cameligo.ParserLog.pattern_to_string + (Parser_cameligo.ParserLog.pattern_to_string ~offsets:true ~mode:`Point x) in error title content in diff --git a/src/test/contracts/pledge.religo b/src/test/contracts/pledge.religo index 394435397..14024f292 100644 --- a/src/test/contracts/pledge.religo +++ b/src/test/contracts/pledge.religo @@ -1,14 +1,14 @@ -(* Pledge-Distribute — Accept money from a number of contributors and then donate - to an address designated by an oracle *) +/* Pledge-Distribute — Accept money from a number of contributors and then donate + to an address designated by an oracle */ -(* A lot of people (myself included) seem to expect an oracle to be more than it is. +/* A lot of people (myself included) seem to expect an oracle to be more than it is. That is, they expect it to be something complicated when it's actually pretty simple. An oracle is just an authorized source of information external to the chain, like an arbiter or moderator. For example, it's not possible to do an HTTP request to get info from a weather site directly using a smart contract. So instead what you do is make (or use) an oracle service which uploads the data to the chain so that contracts can use it. -*) +*/ type storage = address diff --git a/src/test/contracts/website2.religo b/src/test/contracts/website2.religo index f9b936047..e8c17cf82 100644 --- a/src/test/contracts/website2.religo +++ b/src/test/contracts/website2.religo @@ -1,4 +1,4 @@ -(* IF YOU CHANGE THIS, CHANGE THE EXAMPLE ON THE FRONT PAGE OF THE WEBSITE *) +/* IF YOU CHANGE THIS, CHANGE THE EXAMPLE ON THE FRONT PAGE OF THE WEBSITE */ type storage = int; @@ -22,4 +22,4 @@ let main = ((p,storage): (parameter, storage)) => { ([]: list (operation), storage); }; -(* IF YOU CHANGE THIS, CHANGE THE EXAMPLE ON THE FRONT PAGE OF THE WEBSITE *) +/* IF YOU CHANGE THIS, CHANGE THE EXAMPLE ON THE FRONT PAGE OF THE WEBSITE */ diff --git a/vendors/Preproc/EMain.ml b/vendors/Preproc/EMain.ml deleted file mode 100644 index 7108f35ca..000000000 --- a/vendors/Preproc/EMain.ml +++ /dev/null @@ -1,33 +0,0 @@ -(* 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 deleted file mode 100644 index 19462a8da..000000000 --- a/vendors/Preproc/Eparser.mly +++ /dev/null @@ -1,50 +0,0 @@ -%{ -(* 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 deleted file mode 100644 index cf7f342f9..000000000 --- a/vendors/Preproc/Error.ml +++ /dev/null @@ -1,31 +0,0 @@ -(* 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 deleted file mode 100644 index 23becbf76..000000000 --- a/vendors/Preproc/Escan.mll +++ /dev/null @@ -1,95 +0,0 @@ -{ -(* 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/Preproc.mll b/vendors/Preproc/Preproc.mll deleted file mode 100644 index bc3fc912a..000000000 --- a/vendors/Preproc/Preproc.mll +++ /dev/null @@ -1,585 +0,0 @@ -(* 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 deleted file mode 100644 index db05cc9b0..000000000 --- a/vendors/Preproc/ProcMain.ml +++ /dev/null @@ -1,5 +0,0 @@ -(* 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 deleted file mode 100644 index b15c65fef..000000000 --- a/vendors/Preproc/README.md +++ /dev/null @@ -1 +0,0 @@ -# A C# preprocessor in OCaml diff --git a/vendors/Preproc/build.sh b/vendors/Preproc/build.sh deleted file mode 100755 index e9d6546be..000000000 --- a/vendors/Preproc/build.sh +++ /dev/null @@ -1,23 +0,0 @@ -#!/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 deleted file mode 100755 index 6373ab745..000000000 --- a/vendors/Preproc/clean.sh +++ /dev/null @@ -1,3 +0,0 @@ -#!/bin/sh - -\rm -f *.cm* *.o *.byte *.opt diff --git a/vendors/Preproc/dune b/vendors/Preproc/dune deleted file mode 100644 index 22003d39e..000000000 --- a/vendors/Preproc/dune +++ /dev/null @@ -1,20 +0,0 @@ -(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/Preproc/.EMain.tag b/vendors/Preprocessor/.E_LexerMain.tag similarity index 100% rename from vendors/Preproc/.EMain.tag rename to vendors/Preprocessor/.E_LexerMain.tag diff --git a/vendors/Preproc/.Eparser.mly.tag b/vendors/Preprocessor/.E_Parser.mly.tag similarity index 100% rename from vendors/Preproc/.Eparser.mly.tag rename to vendors/Preprocessor/.E_Parser.mly.tag diff --git a/vendors/Preproc/.ProcMain.tag b/vendors/Preprocessor/.E_ParserMain.tag similarity index 100% rename from vendors/Preproc/.ProcMain.tag rename to vendors/Preprocessor/.E_ParserMain.tag diff --git a/vendors/Preprocessor/.PreprocMain.ml b/vendors/Preprocessor/.PreprocMain.ml new file mode 100644 index 000000000..e69de29bb diff --git a/vendors/Preprocessor/.PreprocMain.tag b/vendors/Preprocessor/.PreprocMain.tag new file mode 100644 index 000000000..e69de29bb diff --git a/vendors/Preproc/.links b/vendors/Preprocessor/.links similarity index 100% rename from vendors/Preproc/.links rename to vendors/Preprocessor/.links diff --git a/vendors/Preproc/Etree.ml b/vendors/Preprocessor/E_AST.ml similarity index 100% rename from vendors/Preproc/Etree.ml rename to vendors/Preprocessor/E_AST.ml diff --git a/vendors/Preprocessor/E_Lexer.mli b/vendors/Preprocessor/E_Lexer.mli new file mode 100644 index 000000000..b28896cc9 --- /dev/null +++ b/vendors/Preprocessor/E_Lexer.mli @@ -0,0 +1,22 @@ +(* Module for lexing boolean expressions of conditional directives *) + +(* Regions *) + +module Region = Simple_utils.Region + +val string_of_token : E_Parser.token -> string + +(* Errors *) + +type error = Invalid_character of char + +val error_to_string : error -> string + +val format : + ?offsets:bool -> error Region.reg -> file:bool -> string Region.reg + +(* Lexing boolean expressions (may raise [Error]) *) + +exception Error of error Region.reg + +val scan : Lexing.lexbuf -> E_Parser.token diff --git a/vendors/Preprocessor/E_Lexer.mll b/vendors/Preprocessor/E_Lexer.mll new file mode 100644 index 000000000..79b9307f2 --- /dev/null +++ b/vendors/Preprocessor/E_Lexer.mll @@ -0,0 +1,105 @@ +(* Auxiliary scanner for boolean expressions of the C# preprocessor *) + +{ +(* START OF HEADER *) + +module Region = Simple_utils.Region +module Pos = Simple_utils.Pos + +let sprintf = Printf.sprintf + +open E_Parser + +(* Concrete syntax of tokens. See module [E_Parser]. *) + +let string_of_token = function + True -> "true" +| False -> "false" +| Ident id -> id +| OR -> "||" +| AND -> "&&" +| EQ -> "==" +| NEQ -> "!=" +| NOT -> "!" +| LPAR -> "(" +| RPAR -> ")" +| EOL -> "EOL" + +(* Errors *) + +type error = Invalid_character of char + +let error_to_string = function + Invalid_character c -> + sprintf "Invalid character '%c' (%d)." c (Char.code c) + +let format ?(offsets=true) Region.{region; value} ~file = + let msg = error_to_string value + and reg = region#to_string ~file ~offsets `Byte in + let value = sprintf "Preprocessing error %s:\n%s\n" reg msg + in Region.{value; region} + +exception Error of error Region.reg + +let mk_reg buffer = + let start = Lexing.lexeme_start_p buffer |> Pos.from_byte + and stop = Lexing.lexeme_end_p buffer |> Pos.from_byte + in Region.make ~start ~stop + +let stop value region = raise (Error Region.{region; value}) +let fail error buffer = stop error (mk_reg buffer) + +(* END OF HEADER *) +} + +(* 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 scan = parse + blank+ { scan lexbuf } +| newline { Lexing.new_line lexbuf; EOL } +| eof { EOL } +| "true" { True } +| "false" { False } +| ident as id { Ident id } +| '(' { LPAR } +| ')' { RPAR } +| "||" { OR } +| "&&" { AND } +| "==" { EQ } +| "!=" { NEQ } +| "!" { NOT } +| "//" { inline_com lexbuf } +| _ as c { fail (Invalid_character c) lexbuf } + +and inline_com = parse + newline { Lexing.new_line lexbuf; EOL } +| eof { EOL } +| _ { inline_com lexbuf } + +{ + (* START OF TRAILER *) + (* END OF TRAILER *) +} diff --git a/vendors/Preprocessor/E_LexerMain.ml b/vendors/Preprocessor/E_LexerMain.ml new file mode 100644 index 000000000..93b0a5930 --- /dev/null +++ b/vendors/Preprocessor/E_LexerMain.ml @@ -0,0 +1,33 @@ +(* Standalone lexer for booleans expression of preprocessing + directives for PascaLIGO *) + +module Region = Simple_utils.Region + +let highlight msg = Printf.eprintf "\027[31m%s\027[0m%!" msg + +let options = EvalOpt.(read ~lang:`PascaLIGO ~ext:".ligo") + +let lex in_chan = + let buffer = Lexing.from_channel in_chan in + let open Lexing in + let () = + match options#input with + Some "-" | None -> () + | Some pos_fname -> + buffer.lex_curr_p <- {buffer.lex_curr_p with pos_fname} in + let rec iter () = + match E_Lexer.scan buffer with + token -> Printf.printf "%s\n" (E_Lexer.string_of_token token); + if token <> E_Parser.EOL then iter () + | exception E_Lexer.Error err -> + let formatted = + E_Lexer.format ~offsets:options#offsets ~file:true err + in highlight formatted.Region.value + in iter (); close_in in_chan + +let () = + match options#input with + Some "-" | None -> lex stdin + | Some file_path -> + try open_in file_path |> lex with + Sys_error msg -> highlight msg diff --git a/vendors/Preprocessor/E_Parser.mly b/vendors/Preprocessor/E_Parser.mly new file mode 100644 index 000000000..8405426c7 --- /dev/null +++ b/vendors/Preprocessor/E_Parser.mly @@ -0,0 +1,50 @@ +%{ +(* Grammar for boolean expressions in preprocessing directives of C# *) +%} + +%token Ident "" +%token True "true" +%token False "false" +%token OR "||" +%token AND "&&" +%token EQ "==" +%token NEQ "!=" +%token NOT "!" +%token LPAR "(" +%token RPAR ")" +%token EOL + +(* Entries *) + +%start expr +%type expr + +%% + +(* Grammar *) + +expr: + or_expr EOL { $1 } + +or_expr: + or_expr "||" and_expr { E_AST.Or ($1,$3) } +| and_expr { $1 } + +and_expr: + and_expr "&&" unary_expr { E_AST.And ($1,$3) } +| equality_expr { $1 } + +equality_expr: + equality_expr "==" unary_expr { E_AST.Eq ($1,$3) } +| equality_expr "!=" unary_expr { E_AST.Neq ($1,$3) } +| unary_expr { $1 } + +unary_expr: + primary_expr { $1 } +| "!" unary_expr { E_AST.Not $2 } + +primary_expr: + "true" { E_AST.True } +| "false" { E_AST.False } +| "" { E_AST.Ident $1 } +| "(" or_expr ")" { $2 } diff --git a/vendors/Preprocessor/E_ParserMain.ml b/vendors/Preprocessor/E_ParserMain.ml new file mode 100644 index 000000000..653e80425 --- /dev/null +++ b/vendors/Preprocessor/E_ParserMain.ml @@ -0,0 +1,43 @@ +(* Standalone parser for booleans expression of preprocessing + directives for PascaLIGO *) + +module Region = Simple_utils.Region + +let highlight msg = Printf.eprintf "\027[31m%s\027[0m%!" msg + +let options = EvalOpt.(read ~lang:`PascaLIGO ~ext:".ligo") + +let parse in_chan = + let buffer = Lexing.from_channel in_chan in + let open Lexing in + let () = + match options#input with + Some "-" | None -> () + | Some pos_fname -> + buffer.lex_curr_p <- {buffer.lex_curr_p with pos_fname} in + let () = + try + let tree = E_Parser.expr E_Lexer.scan buffer in + let value = Preproc.(eval Env.empty tree) + in Printf.printf "%s\n" (string_of_bool value) + with + E_Lexer.Error error -> + let formatted = + E_Lexer.format ~offsets:options#offsets ~file:true error + in highlight formatted.Region.value + | E_Parser.Error -> + let region = Preproc.mk_reg buffer + and value = Preproc.Parse_error in + let error = Region.{value; region} in + let formatted = + Preproc.format ~offsets:options#offsets + ~file:true error + in highlight formatted.Region.value + in close_in in_chan + +let () = + match options#input with + Some "-" | None -> parse stdin + | Some file_path -> + try open_in file_path |> parse with + Sys_error msg -> highlight msg diff --git a/vendors/Preprocessor/EvalOpt.ml b/vendors/Preprocessor/EvalOpt.ml new file mode 100644 index 000000000..63c92fad1 --- /dev/null +++ b/vendors/Preprocessor/EvalOpt.ml @@ -0,0 +1,124 @@ +(* Parsing command-line options *) + +(* The type [options] gathers the command-line options. *) + +type language = [`PascaLIGO | `CameLIGO | `ReasonLIGO] + +let lang_to_string = function + `PascaLIGO -> "PascaLIGO" +| `CameLIGO -> "CameLIGO" +| `ReasonLIGO -> "ReasonLIGO" + +module SSet = Set.Make (String) + +type options = < + input : string option; + libs : string list; + verbose : SSet.t; + offsets : bool; + lang : language; + ext : string (* ".ligo", ".mligo", ".religo" *) +> + +let make ~input ~libs ~lang ~offsets ~verbose ~ext : options = + object + method input = input + method libs = libs + method lang = lang + method offsets = offsets + method verbose = verbose + method ext = ext + end + +(* Auxiliary functions and modules *) + +let printf = Printf.printf +let sprintf = Printf.sprintf +let print = print_endline + +(* Printing a string in red to standard error *) + +let highlight msg = Printf.eprintf "\027[31m%s\027[0m%!" msg + +(* Failure *) + +let abort msg = + highlight (sprintf "Command-line error: %s\n" msg); exit 1 + +(* Help *) + +let help lang ext () = + let file = Filename.basename Sys.argv.(0) in + printf "Usage: %s [