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