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

Refactoring of the front-end towards integration of the local builds

Browse Source 
and the globol build, using the parser error messages, for instance.
This commit is contained in:
Christian Rinderknecht 2020-01-23 18:28:04 +01:00
parent c73c563461
commit 4f4294bf56
23 changed files with 1007 additions and 589 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

289
src/passes/1-parser/cameligo.ml
View File

@ -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 *)
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_cameligo.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
fun () -> Format.asprintf "%a" Location.pp_lift @@ e.region)]
in error ~data title message
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
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) (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
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 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
| 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
| 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.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

67
src/passes/1-parser/cameligo/ParserMain.ml
View File

@ -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 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.parse Unit.parse_expr) with
then
match parse (fun () -> Unit.apply instance 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
| 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 msg -> Printf.eprintf "\027[31m%s\027[0m%!" msg
| 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

10
src/passes/1-parser/cameligo/dune
View File

@ -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)))

276
src/passes/1-parser/pascaligo.ml
View File

@ -4,21 +4,51 @@ 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 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 title () = Printf.sprintf "\nReserved name \"%s\"" value in
let message () = "" in
let data = [
("location",
@ -27,7 +57,7 @@ module Errors =
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",
@ -36,7 +66,7 @@ module Errors =
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 = [
@ -44,111 +74,165 @@ module Errors =
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",
("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 parser_error source (start: Lexing.position)
(stop: Lexing.position) lexbuf =
let title () = "parser error" in
let file =
if source = "" then ""
else
Format.sprintf "In file \"%s|%s\"" start.pos_fname source in
let message () =
Format.sprintf
"Parse error at \"%s\" from (%d, %d) to (%d, %d). %s\n"
(Lexing.lexeme lexbuf)
start.pos_lnum (start.pos_cnum - start.pos_bol)
stop.pos_lnum (stop.pos_cnum - stop.pos_bol)
file in
let loc =
if start.pos_cnum = -1 then
Region.make
~start:(Pos.min ~file:source) ~stop:(Pos.from_byte stop)
else
Region.make ~start:(Pos.from_byte start)
~stop:(Pos.from_byte stop) in
let data =
[("parser_loc",
fun () -> Format.asprintf "%a" Location.pp_lift @@ loc)] in
error ~data title message
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

1
src/passes/1-parser/pascaligo/.links
View File

@ -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

7
src/passes/1-parser/pascaligo/LexerMain.ml
View File

@ -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

72
src/passes/1-parser/pascaligo/ParserMain.ml
View File

@ -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\
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 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.parse Unit.parse_expr) with
then
match parse (fun () -> Unit.apply instance 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
| 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 msg -> Printf.eprintf "\027[31m%s\027[0m%!" msg
| 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

8
src/passes/1-parser/pascaligo/dune
View File

@ -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)))

281
src/passes/1-parser/reasonligo.ml
View File

@ -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)]
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

6
src/passes/1-parser/reasonligo/Parser.mly
View File

@ -451,11 +451,9 @@ fun_expr:
};
region
}
| e -> (
| e ->
let open! SyntaxError in
raise (Error (WrongFunctionArguments e))
)
in
raise (Error (WrongFunctionArguments e)) in
let fun_args_to_pattern = function
EAnnot {
value = {

73
src/passes/1-parser/reasonligo/ParserMain.ml
View File

@ -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
and region = AST.expr_to_region expr in
let error = Unit.short_error ~offsets:IO.options#offsets
IO.options#mode msg reg
in Stdlib.Error error
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 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.parse Unit.parse_expr) with
then
match parse (fun () -> Unit.apply instance 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
| 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 msg -> Printf.eprintf "\027[31m%s\027[0m%!" msg
| 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

13
src/passes/1-parser/reasonligo/dune
View File

@ -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)))

13
src/passes/1-parser/shared/Lexer.mli
View File

@ -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

76
src/passes/1-parser/shared/Lexer.mll
View File

@ -167,7 +167,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 *)
@ -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 *)

23
src/passes/1-parser/shared/LexerLog.ml
View File

@ -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,10 +50,13 @@ 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
(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 () =
@ -69,7 +74,7 @@ module Make (Lexer: Lexer.S) : (S with module Lexer = Lexer) =
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
in close_all (); result
| Stdlib.Error (Lexer.File_opening msg) ->
close_out stdout; Stdlib.Error (Region.wrap_ghost msg)
end

4
src/passes/1-parser/shared/LexerLog.mli
View File

@ -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

18
src/passes/1-parser/shared/LexerUnit.ml
View File

@ -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,11 +61,10 @@ 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
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
@ -82,13 +83,14 @@ module Make (IO: IO) (Lexer: Lexer.S) =
in Stdlib.Error msg in
let result = read_tokens []
in close_all (); result
with Sys_error msg -> close_out stdout; Stdlib.Error msg
| 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

6
src/passes/1-parser/shared/LexerUnit.mli
View File

@ -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

4
src/passes/1-parser/shared/ParserAPI.ml
View File

@ -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
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

5
src/passes/1-parser/shared/ParserAPI.mli
View File

@ -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

109
src/passes/1-parser/shared/ParserUnit.ml
View File

@ -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,41 +135,12 @@ 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 *)
let lexer_inst = Lexer.open_token_stream (Some pp_input) in
(* Making the tokeniser *)
let module Log = LexerLog.Make (Lexer) in
let log =
Log.output_token ~offsets:IO.options#offsets
IO.options#mode IO.options#cmd stdout in
let tokeniser = lexer_inst.Lexer.read ~log in
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
match parser lexer_inst with
Stdlib.Error _ as error -> error
| Stdlib.Ok _ as node -> node
@ -229,6 +181,7 @@ module Make (Lexer: Lexer.S)
(* I/O errors *)
| exception Sys_error error -> Stdlib.Error error
| exception Sys_error error ->
Stdlib.Error (Region.wrap_ghost error)
end

28
src/passes/1-parser/shared/ParserUnit.mli
View File

@ -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

11
vendors/ligo-utils/simple-utils/trace.ml vendored
View File

@ -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