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