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

Shared more code in ParserUnit.ml

Browse Source 
Rewrite of the integration of the preprocessor.
Compiles bt DOES NOT PASS THE CI.
This commit is contained in:
Christian Rinderknecht 2020-04-03 19:08:14 +02:00
parent 6c1a1f91e2
commit 1941f9ae4b
21 changed files with 448 additions and 466 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
src/dune
View File

@ -1,14 +1,13 @@
(dirs (:standard \ toto)) (dirs (:standard))
(library (library
(name ligo) (name ligo)
(public_name ligo) (public_name ligo)
(libraries (libraries
simple-utils Preprocessor
tezos-utils simple-utils
tezos-micheline tezos-utils
main tezos-micheline
) main)
(preprocess (preprocess
(pps ppx_let bisect_ppx --conditional) (pps ppx_let bisect_ppx --conditional)))
)
)

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

@ -4,26 +4,46 @@ module Lexer = Lexer.Make(LexToken)
module Scoping = Parser_cameligo.Scoping module Scoping = Parser_cameligo.Scoping
module Region = Simple_utils.Region module Region = Simple_utils.Region
module ParErr = Parser_cameligo.ParErr module ParErr = Parser_cameligo.ParErr
module SSet = Utils.String.Set module SSet = Set.Make (String)
(* Mock IOs TODO: Fill them with CLI options *) (* Mock IOs TODO: Fill them with CLI options *)
module type IO = type language = [`PascaLIGO | `CameLIGO | `ReasonLIGO]
sig
val ext : string
val options : EvalOpt.options
end
module PreIO = module SubIO =
struct struct
let ext = ".ligo" type options = <
let pre_options = libs : string list;
EvalOpt.make ~libs:[] verbose : SSet.t;
~verbose:SSet.empty offsets : bool;
~offsets:true lang : language;
~mode:`Point ext : string; (* ".mligo" *)
~cmd:EvalOpt.Quiet mode : [`Byte | `Point];
~mono:false cmd : EvalOpt.command;
mono : bool
>
let options : options =
object
method libs = []
method verbose = SSet.empty
method offsets = true
method lang = `CameLIGO
method ext = ".mligo"
method mode = `Point
method cmd = EvalOpt.Quiet
method mono = false
end
let make =
EvalOpt.make ~libs:options#libs
~verbose:options#verbose
~offsets:options#offsets
~lang:options#lang
~ext:options#ext
~mode:options#mode
~cmd:options#cmd
~mono:options#mono
end end
module Parser = module Parser =
@ -40,34 +60,33 @@ module ParserLog =
include Parser_cameligo.ParserLog include Parser_cameligo.ParserLog
end end
module PreUnit = module Unit =
ParserUnit.Make (Lexer)(AST)(Parser)(ParErr)(ParserLog) ParserUnit.Make (Lexer)(AST)(Parser)(ParErr)(ParserLog)(SubIO)
module Errors = module Errors =
struct struct
(* let data =
[("location",
fun () -> Format.asprintf "%a" Location.pp_lift @@ loc)] *)
let generic message = let generic message =
let title () = "" let title () = ""
and message () = message.Region.value and message () = message.Region.value
in Trace.error ~data:[] title message in Trace.error ~data:[] title message
end end
let parse (module IO : IO) parser = let apply parser =
let module Unit = PreUnit (IO) in
let local_fail error = let local_fail error =
Trace.fail Trace.fail
@@ Errors.generic @@ Errors.generic
@@ Unit.format_error ~offsets:IO.options#offsets @@ Unit.format_error ~offsets:SubIO.options#offsets
IO.options#mode error in SubIO.options#mode error in
match parser () with match parser () with
Stdlib.Ok semantic_value -> Trace.ok semantic_value Stdlib.Ok semantic_value -> Trace.ok semantic_value
(* Lexing and parsing errors *) (* Lexing and parsing errors *)
| Stdlib.Error error -> Trace.fail @@ Errors.generic error | Stdlib.Error error -> Trace.fail @@ Errors.generic error
(* System errors *)
| exception Sys_error msg ->
Trace.fail @@ Errors.generic (Region.wrap_ghost msg)
(* Scoping errors *) (* Scoping errors *)
| exception Scoping.Error (Scoping.Reserved_name name) -> | exception Scoping.Error (Scoping.Reserved_name name) ->
@ -110,71 +129,14 @@ let parse (module IO : IO) parser =
Hint: Change the name.\n", Hint: Change the name.\n",
None, invalid)) None, invalid))
let parse_file (source: string) = (* Parsing a contract in a file *)
let module IO =
struct
let ext = PreIO.ext
let options =
PreIO.pre_options ~input:(Some source) ~expr:false
end in
let lib_path =
match IO.options#libs with
[] -> ""
| libs -> let mk_I dir path = Printf.sprintf " -I %s%s" dir path
in List.fold_right mk_I libs "" in
let prefix =
match IO.options#input with
None | Some "-" -> "temp"
| Some file -> Filename.(remove_extension @@ basename file) in
let suffix = ".pp" ^ IO.ext in
let pp_input =
if SSet.mem "cpp" IO.options#verbose
then prefix ^ suffix
else let pp_input, pp_out =
Filename.open_temp_file prefix suffix
in close_out pp_out; pp_input in
let cpp_cmd =
match IO.options#input with
None | Some "-" ->
Printf.sprintf "cpp -traditional-cpp%s - > %s"
lib_path pp_input
| Some file ->
Printf.sprintf "cpp -traditional-cpp%s %s > %s"
lib_path file pp_input in
let open Trace in
let%bind () = sys_command cpp_cmd in
let module Unit = PreUnit (IO) in
match Lexer.(open_token_stream @@ File pp_input) with
Ok instance ->
let thunk () = Unit.apply instance Unit.parse_contract
in parse (module IO) thunk
| Stdlib.Error (Lexer.File_opening msg) ->
Trace.fail @@ Errors.generic @@ Region.wrap_ghost msg
let parse_string (s: string) = let parse_file source = apply (fun () -> Unit.parse_file source)
let module IO =
struct
let ext = PreIO.ext
let options = PreIO.pre_options ~input:None ~expr:false
end in
let module Unit = PreUnit (IO) in
match Lexer.(open_token_stream @@ String s) with
Ok instance ->
let thunk () = Unit.apply instance Unit.parse_contract
in parse (module IO) thunk
| Stdlib.Error (Lexer.File_opening msg) ->
Trace.fail @@ Errors.generic @@ Region.wrap_ghost msg
let parse_expression (s: string) = (* Parsing a contract in a string *)
let module IO =
struct let parse_string source = apply (fun () -> Unit.parse_string source)
let ext = PreIO.ext
let options = PreIO.pre_options ~input:None ~expr:true (* Parsing an expression in a string *)
end in
let module Unit = PreUnit (IO) in let parse_expression source = apply (fun () -> Unit.parse_expression source)
match Lexer.(open_token_stream @@ String s) with
Ok instance ->
let thunk () = Unit.apply instance Unit.parse_expr
in parse (module IO) thunk
| Stdlib.Error (Lexer.File_opening msg) ->
Trace.fail @@ Errors.generic @@ Region.wrap_ghost msg

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

@ -4,26 +4,46 @@ module Lexer = Lexer.Make(LexToken)
module Scoping = Parser_pascaligo.Scoping module Scoping = Parser_pascaligo.Scoping
module Region = Simple_utils.Region module Region = Simple_utils.Region
module ParErr = Parser_pascaligo.ParErr module ParErr = Parser_pascaligo.ParErr
module SSet = Utils.String.Set module SSet = Set.Make (String)
(* Mock IOs TODO: Fill them with CLI options *) (* Mock IOs TODO: Fill them with CLI options *)
module type IO = type language = [`PascaLIGO | `CameLIGO | `ReasonLIGO]
sig
val ext : string
val options : EvalOpt.options
end
module PreIO = module SubIO =
struct struct
let ext = ".ligo" type options = <
let pre_options = libs : string list;
EvalOpt.make ~libs:[] verbose : SSet.t;
~verbose:SSet.empty offsets : bool;
~offsets:true lang : language;
~mode:`Point ext : string; (* ".ligo" *)
~cmd:EvalOpt.Quiet mode : [`Byte | `Point];
~mono:false cmd : EvalOpt.command;
mono : bool
>
let options : options =
object
method libs = []
method verbose = SSet.empty
method offsets = true
method lang = `PascaLIGO
method ext = ".ligo"
method mode = `Point
method cmd = EvalOpt.Quiet
method mono = false
end
let make =
EvalOpt.make ~libs:options#libs
~verbose:options#verbose
~offsets:options#offsets
~lang:options#lang
~ext:options#ext
~mode:options#mode
~cmd:options#cmd
~mono:options#mono
end end
module Parser = module Parser =
@ -40,34 +60,34 @@ module ParserLog =
include Parser_pascaligo.ParserLog include Parser_pascaligo.ParserLog
end end
module PreUnit = module Unit =
ParserUnit.Make (Lexer)(AST)(Parser)(ParErr)(ParserLog) ParserUnit.Make (Lexer)(AST)(Parser)(ParErr)(ParserLog)(SubIO)
module Errors = module Errors =
struct struct
(* let data =
[("location",
fun () -> Format.asprintf "%a" Location.pp_lift @@ loc)] *)
let generic message = let generic message =
let title () = "" let title () = ""
and message () = message.Region.value and message () = message.Region.value
in Trace.error ~data:[] title message in Trace.error ~data:[] title message
end end
let parse (module IO : IO) parser = let apply parser =
let module Unit = PreUnit (IO) in
let local_fail error = let local_fail error =
Trace.fail Trace.fail
@@ Errors.generic @@ Errors.generic
@@ Unit.format_error ~offsets:IO.options#offsets @@ Unit.format_error ~offsets:SubIO.options#offsets
IO.options#mode error in SubIO.options#mode error in
match parser () with match parser () with
Stdlib.Ok semantic_value -> Trace.ok semantic_value Stdlib.Ok semantic_value -> Trace.ok semantic_value
(* Lexing and parsing errors *) (* Lexing and parsing errors *)
| Stdlib.Error error -> Trace.fail @@ Errors.generic error | Stdlib.Error error -> Trace.fail @@ Errors.generic error
(* System errors *)
| exception Sys_error msg ->
Trace.fail @@ Errors.generic (Region.wrap_ghost msg)
(* Scoping errors *) (* Scoping errors *)
| exception Scoping.Error (Scoping.Reserved_name name) -> | exception Scoping.Error (Scoping.Reserved_name name) ->
@ -121,71 +141,14 @@ let parse (module IO : IO) parser =
Hint: Change the name.\n", Hint: Change the name.\n",
None, invalid)) None, invalid))
let parse_file source = (* Parsing a contract in a file *)
let module IO =
struct
let ext = PreIO.ext
let options =
PreIO.pre_options ~input:(Some source) ~expr:false
end in
let module Unit = PreUnit (IO) in
let lib_path =
match IO.options#libs with
[] -> ""
| libs -> let mk_I dir path = Printf.sprintf " -I %s%s" dir path
in List.fold_right mk_I libs "" in
let prefix =
match IO.options#input with
None | Some "-" -> "temp"
| Some file -> Filename.(remove_extension @@ basename file) in
let suffix = ".pp" ^ IO.ext in
let pp_input =
if SSet.mem "cpp" IO.options#verbose
then prefix ^ suffix
else let pp_input, pp_out =
Filename.open_temp_file prefix suffix
in close_out pp_out; pp_input in
let cpp_cmd =
match IO.options#input with
None | Some "-" ->
Printf.sprintf "cpp -traditional-cpp%s - > %s"
lib_path pp_input
| Some file ->
Printf.sprintf "cpp -traditional-cpp%s %s > %s"
lib_path file pp_input in
let open Trace in
let%bind () = sys_command cpp_cmd in
match Lexer.(open_token_stream @@ File pp_input) with
Ok instance ->
let thunk () = Unit.apply instance Unit.parse_contract
in parse (module IO) thunk
| Stdlib.Error (Lexer.File_opening msg) ->
Trace.fail @@ Errors.generic @@ Region.wrap_ghost msg
let parse_string (s: string) = let parse_file source = apply (fun () -> Unit.parse_file source)
let module IO =
struct
let ext = PreIO.ext
let options = PreIO.pre_options ~input:None ~expr:false
end in
let module Unit = PreUnit (IO) in
match Lexer.(open_token_stream @@ String s) with
Ok instance ->
let thunk () = Unit.apply instance Unit.parse_contract
in parse (module IO) thunk
| Stdlib.Error (Lexer.File_opening msg) ->
Trace.fail @@ Errors.generic @@ Region.wrap_ghost msg
let parse_expression (s: string) = (* Parsing a contract in a string *)
let module IO =
struct let parse_string source = apply (fun () -> Unit.parse_string source)
let ext = PreIO.ext
let options = PreIO.pre_options ~input:None ~expr:true (* Parsing an expression in a string *)
end in
let module Unit = PreUnit (IO) in let parse_expression source = apply (fun () -> Unit.parse_expression source)
match Lexer.(open_token_stream @@ String s) with
Ok instance ->
let thunk () = Unit.apply instance Unit.parse_expr
in parse (module IO) thunk
| Stdlib.Error (Lexer.File_opening msg) ->
Trace.fail @@ Errors.generic @@ Region.wrap_ghost msg

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

@ -5,6 +5,8 @@ $HOME/git/ligo/vendors/ligo-utils/simple-utils/pos.ml
$HOME/git/ligo/vendors/ligo-utils/simple-utils/region.mli $HOME/git/ligo/vendors/ligo-utils/simple-utils/region.mli
$HOME/git/ligo/vendors/ligo-utils/simple-utils/region.ml $HOME/git/ligo/vendors/ligo-utils/simple-utils/region.ml
$HOME/git/ligo/vendors/Preprocessor/EvalOpt.mli PP_EvalOpt.mli
$HOME/git/ligo/vendors/Preprocessor/EvalOpt.ml PP_EvalOpt.ml
$HOME/git/ligo/vendors/Preprocessor/E_AST.ml $HOME/git/ligo/vendors/Preprocessor/E_AST.ml
$HOME/git/ligo/vendors/Preprocessor/E_Lexer.mll $HOME/git/ligo/vendors/Preprocessor/E_Lexer.mll
$HOME/git/ligo/vendors/Preprocessor/EvalOpt.ml $HOME/git/ligo/vendors/Preprocessor/EvalOpt.ml

4
src/passes/1-parser/pascaligo/LexToken.mll
View File

@ -11,8 +11,8 @@ let sprintf = Printf.sprintf
module Region = Simple_utils.Region module Region = Simple_utils.Region
module Pos = Simple_utils.Pos module Pos = Simple_utils.Pos
module SMap = Utils.String.Map module SMap = Map.Make (String)
module SSet = Utils.String.Set module SSet = Set.Make (String)
(* Hack to roll back one lexeme in the current semantic action *) (* Hack to roll back one lexeme in the current semantic action *)
(* (*

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

@ -4,7 +4,7 @@ module Region = Simple_utils.Region
module IO = module IO =
struct struct
let options = EvalOpt.(read ~lang:PascaLIGO ~ext:".ligo") let options = EvalOpt.(read ~lang:`PascaLIGO ~ext:".ligo")
end end
module M = LexerUnit.Make (IO) (Lexer.Make (LexToken)) module M = LexerUnit.Make (IO) (Lexer.Make (LexToken))
@ -12,4 +12,4 @@ module M = LexerUnit.Make (IO) (Lexer.Make (LexToken))
let () = let () =
match M.trace () with match M.trace () with
Stdlib.Ok () -> () Stdlib.Ok () -> ()
| Error Region.{value; _} -> Utils.highlight value | Error Region.{value; _} -> Printf.eprintf "\027[31m%s\027[0m%!" value

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

@ -2,7 +2,7 @@
module IO = module IO =
struct struct
let options = EvalOpt.(read ~lang:PascaLIGO ~ext:".ligo") let options = EvalOpt.(read ~lang:`PascaLIGO ~ext:".ligo")
end end
module Parser = module Parser =
@ -24,6 +24,8 @@ module Lexer = Lexer.Make (LexToken)
module Unit = module Unit =
ParserUnit.Make (Lexer)(AST)(Parser)(ParErr)(ParserLog)(IO) ParserUnit.Make (Lexer)(AST)(Parser)(ParErr)(ParserLog)(IO)
module SSet = Set.Make (String)
(* Main *) (* Main *)
let issue_error error : ('a, string Region.reg) Stdlib.result = let issue_error error : ('a, string Region.reg) Stdlib.result =
@ -38,8 +40,8 @@ let parse parser : ('a, string Region.reg) Stdlib.result =
let token = let token =
Lexer.Token.mk_ident name.Region.value name.Region.region in Lexer.Token.mk_ident name.Region.value name.Region.region in
(match token with (match token with
(* Cannot fail because [name] is a not a (* Cannot fail because [name] is not a reserved name for the
reserved name for the lexer. *) lexer. *)
Stdlib.Error _ -> assert false Stdlib.Error _ -> assert false
| Ok invalid -> | Ok invalid ->
issue_error ("Duplicate parameter.\nHint: Change the name.\n", issue_error ("Duplicate parameter.\nHint: Change the name.\n",
@ -49,8 +51,8 @@ let parse parser : ('a, string Region.reg) Stdlib.result =
let token = let token =
Lexer.Token.mk_ident name.Region.value name.Region.region in Lexer.Token.mk_ident name.Region.value name.Region.region in
(match token with (match token with
(* Cannot fail because [name] is a not a (* Cannot fail because [name] is not a reserved name for the
reserved name for the lexer. *) lexer. *)
Stdlib.Error _ -> assert false Stdlib.Error _ -> assert false
| Ok invalid -> | Ok invalid ->
issue_error issue_error
@ -68,8 +70,8 @@ let parse parser : ('a, string Region.reg) Stdlib.result =
let token = let token =
Lexer.Token.mk_ident var.Region.value var.Region.region in Lexer.Token.mk_ident var.Region.value var.Region.region in
(match token with (match token with
(* Cannot fail because [var] is a not a (* Cannot fail because [var] is not a reserved name for the
reserved name for the lexer. *) lexer. *)
Stdlib.Error _ -> assert false Stdlib.Error _ -> assert false
| Ok invalid -> | Ok invalid ->
let point = "Repeated variable in this pattern.\n\ let point = "Repeated variable in this pattern.\n\
@ -93,49 +95,6 @@ let parse parser : ('a, string Region.reg) Stdlib.result =
(* Preprocessing the input source *) (* Preprocessing the input source *)
(*
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.options#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
*)
(* Preprocessing the input source *)
let preproc cin : unit = let preproc cin : unit =
let close () = flush_all (); close_in cin in let close () = flush_all (); close_in cin in
let buffer = Lexing.from_channel cin in let buffer = Lexing.from_channel cin in
@ -147,7 +106,7 @@ let preproc cin : unit =
buffer.lex_curr_p <- {buffer.lex_curr_p with pos_fname} in buffer.lex_curr_p <- {buffer.lex_curr_p with pos_fname} in
match Preproc.lex IO.options buffer with match Preproc.lex IO.options buffer with
Stdlib.Error (pp_buffer, err) -> Stdlib.Error (pp_buffer, err) ->
if Utils.String.Set.mem "preproc" IO.options#verbose then if SSet.mem "preproc" IO.options#verbose then
Printf.printf "%s\n%!" (Buffer.contents pp_buffer); Printf.printf "%s\n%!" (Buffer.contents pp_buffer);
let Region.{value; _} = let Region.{value; _} =
Preproc.format ~offsets:IO.options#offsets ~file:true err Preproc.format ~offsets:IO.options#offsets ~file:true err

1
src/passes/1-parser/pascaligo/Stubs/Preprocessor.ml
View File

@ -1 +1,2 @@
module Preproc = Preproc module Preproc = Preproc
module EvalOpt = PP_EvalOpt

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

@ -2,31 +2,51 @@ open Trace
module AST = Parser_cameligo.AST module AST = Parser_cameligo.AST
module LexToken = Parser_reasonligo.LexToken module LexToken = Parser_reasonligo.LexToken
module Lexer = Lexer.Make(LexToken) module Lexer = Lexer.Make (LexToken)
module Scoping = Parser_cameligo.Scoping module Scoping = Parser_cameligo.Scoping
module Region = Simple_utils.Region module Region = Simple_utils.Region
module ParErr = Parser_reasonligo.ParErr module ParErr = Parser_reasonligo.ParErr
module SyntaxError = Parser_reasonligo.SyntaxError module SyntaxError = Parser_reasonligo.SyntaxError
module SSet = Utils.String.Set module SSet = Set.Make (String)
(* Mock IOs TODO: Fill them with CLI options *) (* Mock IOs TODO: Fill them with CLI options *)
module type IO = type language = [`PascaLIGO | `CameLIGO | `ReasonLIGO]
sig
val ext : string
val options : EvalOpt.options
end
module PreIO = module SubIO =
struct struct
let ext = ".ligo" type options = <
let pre_options = libs : string list;
EvalOpt.make ~libs:[] verbose : SSet.t;
~verbose:SSet.empty offsets : bool;
~offsets:true lang : language;
~mode:`Point ext : string; (* ".religo" *)
~cmd:EvalOpt.Quiet mode : [`Byte | `Point];
~mono:false cmd : EvalOpt.command;
mono : bool
>
let options : options =
object
method libs = []
method verbose = SSet.empty
method offsets = true
method lang = `ReasonLIGO
method ext = ".religo"
method mode = `Point
method cmd = EvalOpt.Quiet
method mono = false
end
let make =
EvalOpt.make ~libs:options#libs
~verbose:options#verbose
~offsets:options#offsets
~lang:options#lang
~ext:options#ext
~mode:options#mode
~cmd:options#cmd
~mono:options#mono
end end
module Parser = module Parser =
@ -43,8 +63,8 @@ module ParserLog =
include Parser_cameligo.ParserLog include Parser_cameligo.ParserLog
end end
module PreUnit = module Unit =
ParserUnit.Make (Lexer)(AST)(Parser)(ParErr)(ParserLog) ParserUnit.Make (Lexer)(AST)(Parser)(ParErr)(ParserLog)(SubIO)
module Errors = module Errors =
struct struct
@ -55,14 +75,14 @@ module Errors =
let wrong_function_arguments (expr: AST.expr) = let wrong_function_arguments (expr: AST.expr) =
let title () = "" in let title () = "" in
let message () = "It looks like you are defining a function, \ let message () =
however we do not\n\ "It looks like you are defining a function, \
understand the parameters declaration.\n\ however we do not\n\
Examples of valid functions:\n\ understand the parameters declaration.\n\
let x = (a: string, b: int) : int => 3;\n\ Examples of valid functions:\n\
let tuple = ((a, b): (int, int)) => a + b; \n\ let x = (a: string, b: int) : int => 3;\n\
let x = (a: string) : string => \"Hello, \" ++ a;\n" let tuple = ((a, b): (int, int)) => a + b; \n\
in let x = (a: string) : string => \"Hello, \" ++ a;\n" in
let expression_loc = AST.expr_to_region expr in let expression_loc = AST.expr_to_region expr in
let data = [ let data = [
("location", ("location",
@ -70,13 +90,12 @@ module Errors =
in error ~data title message in error ~data title message
end end
let parse (module IO : IO) parser = let apply parser =
let module Unit = PreUnit (IO) in
let local_fail error = let local_fail error =
Trace.fail Trace.fail
@@ Errors.generic @@ Errors.generic
@@ Unit.format_error ~offsets:IO.options#offsets @@ Unit.format_error ~offsets:SubIO.options#offsets
IO.options#mode error in SubIO.options#mode error in
match parser () with match parser () with
Stdlib.Ok semantic_value -> Trace.ok semantic_value Stdlib.Ok semantic_value -> Trace.ok semantic_value
@ -128,71 +147,14 @@ let parse (module IO : IO) parser =
| exception SyntaxError.Error (SyntaxError.WrongFunctionArguments expr) -> | exception SyntaxError.Error (SyntaxError.WrongFunctionArguments expr) ->
Trace.fail @@ Errors.wrong_function_arguments expr Trace.fail @@ Errors.wrong_function_arguments expr
let parse_file (source: string) = (* Parsing a contract in a file *)
let module IO =
struct
let ext = PreIO.ext
let options =
PreIO.pre_options ~input:(Some source) ~expr:false
end in
let lib_path =
match IO.options#libs with
[] -> ""
| libs -> let mk_I dir path = Printf.sprintf " -I %s%s" dir path
in List.fold_right mk_I libs "" in
let prefix =
match IO.options#input with
None | Some "-" -> "temp"
| Some file -> Filename.(remove_extension @@ basename file) in
let suffix = ".pp" ^ IO.ext in
let pp_input =
if SSet.mem "cpp" IO.options#verbose
then prefix ^ suffix
else let pp_input, pp_out =
Filename.open_temp_file prefix suffix
in close_out pp_out; pp_input in
let cpp_cmd =
match IO.options#input with
None | Some "-" ->
Printf.sprintf "cpp -traditional-cpp%s - > %s"
lib_path pp_input
| Some file ->
Printf.sprintf "cpp -traditional-cpp%s %s > %s"
lib_path file pp_input in
let open Trace in
let%bind () = sys_command cpp_cmd in
let module Unit = PreUnit (IO) in
match Lexer.(open_token_stream @@ File pp_input) with
Ok instance ->
let thunk () = Unit.apply instance Unit.parse_contract
in parse (module IO) thunk
| Stdlib.Error (Lexer.File_opening msg) ->
Trace.fail @@ Errors.generic @@ Region.wrap_ghost msg
let parse_string (s: string) = let parse_file source = apply (fun () -> Unit.parse_file source)
let module IO =
struct
let ext = PreIO.ext
let options = PreIO.pre_options ~input:None ~expr:false
end in
let module Unit = PreUnit (IO) in
match Lexer.(open_token_stream @@ String s) with
Ok instance ->
let thunk () = Unit.apply instance Unit.parse_contract
in parse (module IO) thunk
| Stdlib.Error (Lexer.File_opening msg) ->
Trace.fail @@ Errors.generic @@ Region.wrap_ghost msg
let parse_expression (s: string) = (* Parsing a contract in a string *)
let module IO =
struct let parse_string source = apply (fun () -> Unit.parse_string source)
let ext = PreIO.ext
let options = PreIO.pre_options ~input:None ~expr:true (* Parsing an expression in a string *)
end in
let module Unit = PreUnit (IO) in let parse_expression source = apply (fun () -> Unit.parse_expression source)
match Lexer.(open_token_stream @@ String s) with
Ok instance ->
let thunk () = Unit.apply instance Unit.parse_expr
in parse (module IO) thunk
| Stdlib.Error (Lexer.File_opening msg) ->
Trace.fail @@ Errors.generic @@ Region.wrap_ghost msg

28
src/passes/1-parser/shared/EvalOpt.ml
View File

@ -5,19 +5,21 @@
type command = Quiet | Copy | Units | Tokens type command = Quiet | Copy | Units | Tokens
type language = PascaLIGO | CameLIGO | ReasonLIGO type language = [`PascaLIGO | `CameLIGO | `ReasonLIGO]
let lang_to_string = function let lang_to_string = function
PascaLIGO -> "PascaLIGO" `PascaLIGO -> "PascaLIGO"
| CameLIGO -> "CameLIGO" | `CameLIGO -> "CameLIGO"
| ReasonLIGO -> "ReasonLIGO" | `ReasonLIGO -> "ReasonLIGO"
(* The type [options] gathers the command-line options. *) (* The type [options] gathers the command-line options. *)
module SSet = Set.Make (String)
type options = < type options = <
input : string option; input : string option;
libs : string list; libs : string list;
verbose : Utils.String.Set.t; verbose : SSet.t;
offsets : bool; offsets : bool;
lang : language; lang : language;
ext : string; (* ".ligo", ".mligo", ".religo" *) ext : string; (* ".ligo", ".mligo", ".religo" *)
@ -47,8 +49,12 @@ let printf = Printf.printf
let sprintf = Printf.sprintf let sprintf = Printf.sprintf
let print = print_endline let print = print_endline
(* Printing a string in red to standard error *)
let highlight msg = Printf.eprintf "\027[31m%s\027[0m%!" msg
let abort msg = let abort msg =
Utils.highlight (sprintf "Command-line error: %s\n" msg); exit 1 highlight (sprintf "Command-line error: %s\n" msg); exit 1
(* Help *) (* Help *)
@ -83,7 +89,7 @@ and units = ref false
and quiet = ref false and quiet = ref false
and columns = ref false and columns = ref false
and bytes = ref false and bytes = ref false
and verbose = ref Utils.String.Set.empty and verbose = ref SSet.empty
and input = ref None and input = ref None
and libs = ref [] and libs = ref []
and verb_str = ref "" and verb_str = ref ""
@ -95,7 +101,7 @@ let split_at_colon = Str.(split (regexp ":"))
let add_path p = libs := !libs @ split_at_colon p let add_path p = libs := !libs @ split_at_colon p
let add_verbose d = let add_verbose d =
verbose := List.fold_left (Utils.swap Utils.String.Set.add) verbose := List.fold_left (fun x y -> SSet.add y x)
!verbose !verbose
(split_at_colon d) (split_at_colon d)
@ -152,7 +158,7 @@ let print_opt () =
let check lang ext = let check lang ext =
let () = let () =
if Utils.String.Set.mem "cli" !verbose then print_opt () in if SSet.mem "cli" !verbose then print_opt () in
let input = let input =
match !input with match !input with
@ -178,7 +184,7 @@ let check lang ext =
and libs = !libs in and libs = !libs in
let () = let () =
if Utils.String.Set.mem "cli" verbose then if SSet.mem "cli" verbose then
begin begin
printf "\nEXPORTED COMMAND LINE\n"; printf "\nEXPORTED COMMAND LINE\n";
printf "copy = %b\n" copy; printf "copy = %b\n" copy;
@ -213,6 +219,6 @@ let read ~lang ~ext =
(verb_str := (verb_str :=
let apply e a = let apply e a =
if a = "" then e else Printf.sprintf "%s, %s" e a if a = "" then e else Printf.sprintf "%s, %s" e a
in Utils.String.Set.fold apply !verbose ""); in SSet.fold apply !verbose "");
check lang ext check lang ext
with Getopt.Error msg -> abort msg with Getopt.Error msg -> abort msg

8
src/passes/1-parser/shared/EvalOpt.mli
View File

@ -49,14 +49,16 @@ type command = Quiet | Copy | Units | Tokens
expected.} expected.}
} *) } *)
type language = PascaLIGO | CameLIGO | ReasonLIGO type language = [`PascaLIGO | `CameLIGO | `ReasonLIGO]
val lang_to_string : language -> string val lang_to_string : language -> string
module SSet : Set.S with type elt = string and type t = Set.Make(String).t
type options = < type options = <
input : string option; input : string option;
libs : string list; libs : string list;
verbose : Utils.String.Set.t; verbose : SSet.t;
offsets : bool; offsets : bool;
lang : language; lang : language;
ext : string; (* ".ligo", ".mligo", ".religo" *) ext : string; (* ".ligo", ".mligo", ".religo" *)
@ -69,7 +71,7 @@ type options = <
val make : val make :
input:string option -> input:string option ->
libs:string list -> libs:string list ->
verbose:Utils.String.Set.t -> verbose:SSet.t ->
offsets:bool -> offsets:bool ->
lang:language -> lang:language ->
ext:string -> ext:string ->

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

@ -135,7 +135,15 @@ module type S =
val slide : token -> window -> window val slide : token -> window -> window
type input =
File of file_path (* "-" means stdin *)
| Stdin
| String of string
| Channel of in_channel
| Buffer of Lexing.lexbuf
type instance = { type instance = {
input : input;
read : log:logger -> Lexing.lexbuf -> token; read : log:logger -> Lexing.lexbuf -> token;
buffer : Lexing.lexbuf; buffer : Lexing.lexbuf;
get_win : unit -> window; get_win : unit -> window;
@ -145,15 +153,11 @@ module type S =
close : unit -> unit close : unit -> unit
} }
type input =
File of file_path (* "-" means stdin *)
| Stdin
| String of string
| Channel of in_channel
| Buffer of Lexing.lexbuf
type open_err = File_opening of string type open_err = File_opening of string
val lexbuf_from_input :
input -> (Lexing.lexbuf * (unit -> unit), open_err) Stdlib.result
val open_token_stream : input -> (instance, open_err) Stdlib.result val open_token_stream : input -> (instance, open_err) Stdlib.result
(* Error reporting *) (* Error reporting *)

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

@ -157,7 +157,15 @@ module type S =
val slide : token -> window -> window val slide : token -> window -> window
type input =
File of file_path (* "-" means stdin *)
| Stdin
| String of string
| Channel of in_channel
| Buffer of Lexing.lexbuf
type instance = { type instance = {
input : input;
read : log:logger -> Lexing.lexbuf -> token; read : log:logger -> Lexing.lexbuf -> token;
buffer : Lexing.lexbuf; buffer : Lexing.lexbuf;
get_win : unit -> window; get_win : unit -> window;
@ -167,15 +175,11 @@ module type S =
close : unit -> unit close : unit -> unit
} }
type input =
File of file_path (* "-" means stdin *)
| Stdin
| String of string
| Channel of in_channel
| Buffer of Lexing.lexbuf
type open_err = File_opening of string type open_err = File_opening of string
val lexbuf_from_input :
input -> (Lexing.lexbuf * (unit -> unit), open_err) Stdlib.result
val open_token_stream : input -> (instance, open_err) Stdlib.result val open_token_stream : input -> (instance, open_err) Stdlib.result
(* Error reporting *) (* Error reporting *)
@ -865,7 +869,15 @@ and scan_utf8 thread state = parse
type logger = Markup.t list -> token -> unit type logger = Markup.t list -> token -> unit
type input =
File of file_path (* "-" means stdin *)
| Stdin
| String of string
| Channel of in_channel
| Buffer of Lexing.lexbuf
type instance = { type instance = {
input : input;
read : log:logger -> Lexing.lexbuf -> token; read : log:logger -> Lexing.lexbuf -> token;
buffer : Lexing.lexbuf; buffer : Lexing.lexbuf;
get_win : unit -> window; get_win : unit -> window;
@ -875,15 +887,28 @@ type instance = {
close : unit -> unit close : unit -> unit
} }
type input =
File of file_path (* "-" means stdin *)
| Stdin
| String of string
| Channel of in_channel
| Buffer of Lexing.lexbuf
type open_err = File_opening of string type open_err = File_opening of string
let lexbuf_from_input = function
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
let lexbuf = Lexing.from_channel chan in
let () =
let open Lexing in
lexbuf.lex_curr_p <- {lexbuf.lex_curr_p with pos_fname = path}
in Ok (lexbuf, close)
with Sys_error msg -> Stdlib.Error (File_opening msg))
| String s ->
Ok (Lexing.from_string s, fun () -> ())
| Channel chan ->
let close () = close_in chan in
Ok (Lexing.from_channel chan, close)
| Buffer b -> Ok (b, fun () -> ())
let open_token_stream input = let open_token_stream input =
let file_path = match input with let file_path = match input with
File file_path -> File file_path ->
@ -968,32 +993,14 @@ let open_token_stream input =
check_right_context token buffer; check_right_context token buffer;
patch_buffer (Token.to_region token)#byte_pos buffer; patch_buffer (Token.to_region token)#byte_pos buffer;
token in token in
match lexbuf_from_input input with
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) -> Ok (buffer, close) ->
let () = let () =
match input with match input with
File path when path <> "" -> reset ~file:path buffer File path when path <> "" -> reset ~file:path buffer
| _ -> () in | _ -> () in
let instance = { let instance = {
read; buffer; get_win; get_pos; get_last; get_file; close} input; read; buffer; get_win; get_pos; get_last; get_file; close}
in Ok instance in Ok instance
| Error _ as e -> e | Error _ as e -> e

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

@ -1,7 +1,8 @@
(* Functor to build a standalone LIGO lexer *) (* Functor to build a LIGO lexer *)
module Region = Simple_utils.Region module Region = Simple_utils.Region
module Preproc = Preprocessor.Preproc module Preproc = Preprocessor.Preproc
module SSet = Set.Make (String)
module type IO = module type IO =
sig sig
@ -27,9 +28,10 @@ module Make (IO: IO) (Lexer: Lexer.S) =
None | Some "-" -> () None | Some "-" -> ()
| Some pos_fname -> | Some pos_fname ->
buffer.lex_curr_p <- {buffer.lex_curr_p with pos_fname} in buffer.lex_curr_p <- {buffer.lex_curr_p with pos_fname} in
match Preproc.lex IO.options buffer with let opt = (IO.options :> Preprocessor.EvalOpt.options) in
match Preproc.lex opt buffer with
Stdlib.Error (pp_buffer, err) -> Stdlib.Error (pp_buffer, err) ->
if Utils.String.Set.mem "preproc" IO.options#verbose then if SSet.mem "preproc" IO.options#verbose then
Printf.printf "%s\n%!" (Buffer.contents pp_buffer); Printf.printf "%s\n%!" (Buffer.contents pp_buffer);
let formatted = let formatted =
Preproc.format ~offsets:IO.options#offsets ~file:true err Preproc.format ~offsets:IO.options#offsets ~file:true err
@ -79,17 +81,18 @@ module Make (IO: IO) (Lexer: Lexer.S) =
match IO.options#input with match IO.options#input with
None | Some "-" -> () None | Some "-" -> ()
| Some pos_fname -> | Some pos_fname ->
buffer.lex_curr_p <- {buffer.lex_curr_p with pos_fname} in buffer.lex_curr_p <- {buffer.lex_curr_p with pos_fname} in
match Preproc.lex IO.options buffer with let opt = (IO.options :> Preprocessor.EvalOpt.options) in
match Preproc.lex opt buffer with
Stdlib.Error (pp_buffer, err) -> Stdlib.Error (pp_buffer, err) ->
if Utils.String.Set.mem "preproc" IO.options#verbose then if SSet.mem "preproc" IO.options#verbose then
Printf.printf "%s\n%!" (Buffer.contents pp_buffer); Printf.printf "%s\n%!" (Buffer.contents pp_buffer);
let formatted = let formatted =
Preproc.format ~offsets:IO.options#offsets ~file:true err Preproc.format ~offsets:IO.options#offsets ~file:true err
in Stdlib.Error formatted in Stdlib.Error formatted
| Stdlib.Ok pp_buffer -> | Stdlib.Ok pp_buffer ->
let preproc_str = Buffer.contents pp_buffer in let preproc_str = Buffer.contents pp_buffer in
if Utils.String.Set.mem "preproc" IO.options#verbose then if SSet.mem "preproc" IO.options#verbose then
begin begin
Printf.printf "%s\n%!" (Buffer.contents pp_buffer); Printf.printf "%s\n%!" (Buffer.contents pp_buffer);
Stdlib.Ok () Stdlib.Ok ()

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

@ -2,9 +2,15 @@
module Region = Simple_utils.Region module Region = Simple_utils.Region
type options = <
offsets : bool;
mode : [`Byte | `Point];
cmd : EvalOpt.command
>
module type IO = module type IO =
sig sig
val options : EvalOpt.options (* CLI options *) val options : options
end end
module type PARSER = module type PARSER =
@ -49,7 +55,7 @@ module type PARSER =
(* Main functor *) (* Main functor *)
module Make (IO : IO) module Make (IO: IO)
(Lexer: Lexer.S) (Lexer: Lexer.S)
(Parser: PARSER with type token = Lexer.Token.token) (Parser: PARSER with type token = Lexer.Token.token)
(ParErr: sig val message : int -> string end) = (ParErr: sig val message : int -> string end) =
@ -132,8 +138,9 @@ module Make (IO : IO)
module Incr = Parser.Incremental module Incr = Parser.Incremental
module Log = LexerLog.Make (Lexer) module Log = LexerLog.Make (Lexer)
let log = Log.output_token ~offsets:IO.options#offsets let log = Log.output_token
IO.options#mode IO.options#cmd stdout ~offsets:IO.options#offsets
IO.options#mode IO.options#cmd stdout
let incr_contract Lexer.{read; buffer; get_win; close; _} = let incr_contract Lexer.{read; buffer; get_win; close; _} =
let supplier = I.lexer_lexbuf_to_supplier (read ~log) buffer let supplier = I.lexer_lexbuf_to_supplier (read ~log) buffer

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

@ -2,9 +2,15 @@
module Region = Simple_utils.Region module Region = Simple_utils.Region
type options = <
offsets : bool;
mode : [`Byte | `Point];
cmd : EvalOpt.command
>
module type IO = module type IO =
sig sig
val options : EvalOpt.options (* CLI options *) val options : options
end end
(* The signature generated by Menhir with additional type definitions (* The signature generated by Menhir with additional type definitions

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

@ -1,10 +1,26 @@
(* Functor to build a standalone LIGO parser *) (* Functor to build a LIGO parser *)
module Region = Simple_utils.Region module Region = Simple_utils.Region
module Preproc = Preprocessor.Preproc
module SSet = Set.Make (String)
module type IO = type language = [`PascaLIGO | `CameLIGO | `ReasonLIGO]
module type SubIO =
sig sig
val options : EvalOpt.options (* CLI options *) type options = <
libs : string list;
verbose : SSet.t;
offsets : bool;
lang : language;
ext : string; (* ".ligo", ".mligo", ".religo" *)
mode : [`Byte | `Point];
cmd : EvalOpt.command;
mono : bool
>
val options : options
val make : input:string option -> expr:bool -> EvalOpt.options
end end
module type Pretty = module type Pretty =
@ -31,18 +47,18 @@ module Make (Lexer: Lexer.S)
(ParErr: sig val message : int -> string end) (ParErr: sig val message : int -> string end)
(ParserLog: Pretty with type ast = AST.t (ParserLog: Pretty with type ast = AST.t
and type expr = AST.expr) and type expr = AST.expr)
(IO: IO) = (SubIO: SubIO) =
struct struct
open Printf open Printf
module SSet = Utils.String.Set module SSet = Set.Make (String)
(* Log of the lexer *) (* Log of the lexer *)
module Log = LexerLog.Make (Lexer) module Log = LexerLog.Make (Lexer)
let log = let log =
Log.output_token ~offsets:IO.options#offsets Log.output_token ~offsets:SubIO.options#offsets
IO.options#mode IO.options#cmd stdout SubIO.options#mode SubIO.options#cmd stdout
(* Error handling (reexported from [ParserAPI]) *) (* Error handling (reexported from [ParserAPI]) *)
@ -53,7 +69,12 @@ module Make (Lexer: Lexer.S)
(* Instantiating the parser *) (* Instantiating the parser *)
module Front = ParserAPI.Make (IO)(Lexer)(Parser)(ParErr) module API_IO =
struct
let options = (SubIO.options :> ParserAPI.options)
end
module Front = ParserAPI.Make (API_IO)(Lexer)(Parser)(ParErr)
let format_error = Front.format_error let format_error = Front.format_error
@ -66,13 +87,13 @@ module Make (Lexer: Lexer.S)
(AST.expr, message Region.reg) Stdlib.result = (AST.expr, message Region.reg) Stdlib.result =
let output = Buffer.create 131 in let output = Buffer.create 131 in
let state = let state =
ParserLog.mk_state ~offsets:IO.options#offsets ParserLog.mk_state ~offsets:SubIO.options#offsets
~mode:IO.options#mode ~mode:SubIO.options#mode
~buffer:output in ~buffer:output in
let close () = lexer_inst.Lexer.close () in let close () = lexer_inst.Lexer.close () in
let expr = let expr =
try try
if IO.options#mono then if SubIO.options#mono then
let tokeniser = lexer_inst.Lexer.read ~log let tokeniser = lexer_inst.Lexer.read ~log
and lexbuf = lexer_inst.Lexer.buffer and lexbuf = lexer_inst.Lexer.buffer
in Front.mono_expr tokeniser lexbuf in Front.mono_expr tokeniser lexbuf
@ -80,14 +101,14 @@ module Make (Lexer: Lexer.S)
Front.incr_expr lexer_inst Front.incr_expr lexer_inst
with exn -> close (); raise exn in with exn -> close (); raise exn in
let () = let () =
if SSet.mem "ast-tokens" IO.options#verbose then if SSet.mem "ast-tokens" SubIO.options#verbose then
begin begin
Buffer.clear output; Buffer.clear output;
ParserLog.print_expr state expr; ParserLog.print_expr state expr;
Buffer.output_buffer stdout output Buffer.output_buffer stdout output
end in end in
let () = let () =
if SSet.mem "ast" IO.options#verbose then if SSet.mem "ast" SubIO.options#verbose then
begin begin
Buffer.clear output; Buffer.clear output;
ParserLog.pp_expr state expr; ParserLog.pp_expr state expr;
@ -101,13 +122,13 @@ module Make (Lexer: Lexer.S)
(AST.t, message Region.reg) Stdlib.result = (AST.t, message Region.reg) Stdlib.result =
let output = Buffer.create 131 in let output = Buffer.create 131 in
let state = let state =
ParserLog.mk_state ~offsets:IO.options#offsets ParserLog.mk_state ~offsets:SubIO.options#offsets
~mode:IO.options#mode ~mode:SubIO.options#mode
~buffer:output in ~buffer:output in
let close () = lexer_inst.Lexer.close () in let close () = lexer_inst.Lexer.close () in
let ast = let ast =
try try
if IO.options#mono then if SubIO.options#mono then
let tokeniser = lexer_inst.Lexer.read ~log let tokeniser = lexer_inst.Lexer.read ~log
and lexbuf = lexer_inst.Lexer.buffer and lexbuf = lexer_inst.Lexer.buffer
in Front.mono_contract tokeniser lexbuf in Front.mono_contract tokeniser lexbuf
@ -115,14 +136,14 @@ module Make (Lexer: Lexer.S)
Front.incr_contract lexer_inst Front.incr_contract lexer_inst
with exn -> close (); raise exn in with exn -> close (); raise exn in
let () = let () =
if SSet.mem "ast-tokens" IO.options#verbose then if SSet.mem "ast-tokens" SubIO.options#verbose then
begin begin
Buffer.clear output; Buffer.clear output;
ParserLog.print_tokens state ast; ParserLog.print_tokens state ast;
Buffer.output_buffer stdout output Buffer.output_buffer stdout output
end in end in
let () = let () =
if SSet.mem "ast" IO.options#verbose then if SSet.mem "ast" SubIO.options#verbose then
begin begin
Buffer.clear output; Buffer.clear output;
ParserLog.pp_ast state ast; ParserLog.pp_ast state ast;
@ -130,9 +151,16 @@ module Make (Lexer: Lexer.S)
end end
in flush_all (); close (); Ok ast in flush_all (); close (); Ok ast
(* Wrapper for the parsers above *) (* Checking if a lexer input is a file *)
type 'a parser = Lexer.instance -> ('a, message Region.reg) result let is_file input =
let open Lexer in
match input with
File "-" | File "" -> false
| File _ -> true
| Stdin | String _ | Channel _ | Buffer _ -> false
(* Wrapper for the parsers above *)
let apply lexer_inst parser = let apply lexer_inst parser =
(* Calling the parser and filtering errors *) (* Calling the parser and filtering errors *)
@ -144,21 +172,18 @@ module Make (Lexer: Lexer.S)
(* Lexing errors *) (* Lexing errors *)
| exception Lexer.Error err -> | exception Lexer.Error err ->
let file = let file = is_file lexer_inst.Lexer.input in
match IO.options#input with
None | Some "-" -> false
| Some _ -> true in
let error = let error =
Lexer.format_error ~offsets:IO.options#offsets Lexer.format_error ~offsets:SubIO.options#offsets
IO.options#mode err ~file SubIO.options#mode err ~file
in Stdlib.Error error in Stdlib.Error error
(* Incremental API of Menhir *) (* Incremental API of Menhir *)
| exception Front.Point point -> | exception Front.Point point ->
let error = let error =
Front.format_error ~offsets:IO.options#offsets Front.format_error ~offsets:SubIO.options#offsets
IO.options#mode point SubIO.options#mode point
in Stdlib.Error error in Stdlib.Error error
(* Monolithic API of Menhir *) (* Monolithic API of Menhir *)
@ -168,16 +193,68 @@ module Make (Lexer: Lexer.S)
match lexer_inst.Lexer.get_win () with match lexer_inst.Lexer.get_win () with
Lexer.Nil -> Lexer.Nil ->
assert false (* Safe: There is always at least EOF. *) assert false (* Safe: There is always at least EOF. *)
| Lexer.One invalid -> invalid, None | Lexer.One invalid -> invalid, None
| Lexer.Two (invalid, valid) -> invalid, Some valid in | Lexer.Two (invalid, valid) -> invalid, Some valid in
let point = "", valid_opt, invalid in let point = "", valid_opt, invalid in
let error = let error =
Front.format_error ~offsets:IO.options#offsets Front.format_error ~offsets:SubIO.options#offsets
IO.options#mode point SubIO.options#mode point
in Stdlib.Error error in Stdlib.Error error
(* I/O errors *) (* I/O errors *)
| exception Sys_error error -> | exception Sys_error error ->
flush_all (); Stdlib.Error (Region.wrap_ghost error) flush_all (); Stdlib.Error (Region.wrap_ghost error)
(* Preprocessing the input source *)
let preproc options lexbuf =
Preproc.lex (options :> Preprocessor.EvalOpt.options) lexbuf
(* Parsing a contract *)
let gen_parser options input parser =
match Lexer.lexbuf_from_input input with
Stdlib.Error (Lexer.File_opening msg) ->
Stdlib.Error (Region.wrap_ghost msg)
| Ok (lexbuf, close) ->
(* Preprocessing the input source *)
match preproc options lexbuf with
Stdlib.Error (pp_buffer, err) ->
if SSet.mem "preproc" options#verbose then
Printf.printf "%s\n%!" (Buffer.contents pp_buffer);
let formatted =
Preproc.format ~offsets:options#offsets
~file:(is_file input)
err
in close (); Stdlib.Error formatted
| Stdlib.Ok buffer ->
(* Lexing and parsing the preprocessed input source *)
let () = close () in
let input' = Lexer.String (Buffer.contents buffer) in
match Lexer.open_token_stream input' with
Ok instance -> apply instance parser
| Stdlib.Error (Lexer.File_opening msg) ->
Stdlib.Error (Region.wrap_ghost msg)
(* Parsing a contract in a file *)
let parse_file (source : string) =
let options = SubIO.make ~input:(Some source) ~expr:false
in gen_parser options (Lexer.File source) parse_contract
(* Parsing a contract in a string *)
let parse_string (source : string) =
let options = SubIO.make ~input:None ~expr:false in
gen_parser options (Lexer.String source) parse_contract
(* Parsing an expression in a string *)
let parse_expression (source : string) =
let options = SubIO.make ~input:None ~expr:true in
gen_parser options (Lexer.String source) parse_expr
end end

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

@ -2,9 +2,25 @@
module Region = Simple_utils.Region module Region = Simple_utils.Region
module type IO = type language = [`PascaLIGO | `CameLIGO | `ReasonLIGO]
module SSet : Set.S with type elt = string and type t = Set.Make(String).t
module type SubIO =
sig sig
val options : EvalOpt.options (* CLI options *) type options = <
libs : string list;
verbose : SSet.t;
offsets : bool;
lang : language;
ext : string; (* ".ligo", ".mligo", ".religo" *)
mode : [`Byte | `Point];
cmd : EvalOpt.command;
mono : bool
>
val options : options
val make : input:string option -> expr:bool -> EvalOpt.options
end end
module type Pretty = module type Pretty =
@ -31,7 +47,7 @@ module Make (Lexer : Lexer.S)
(ParErr : sig val message : int -> string end) (ParErr : sig val message : int -> string end)
(ParserLog : Pretty with type ast = AST.t (ParserLog : Pretty with type ast = AST.t
and type expr = AST.expr) and type expr = AST.expr)
(IO: IO) : (SubIO: SubIO) :
sig sig
(* Error handling reexported from [ParserAPI] without the (* Error handling reexported from [ParserAPI] without the
exception [Point] *) exception [Point] *)
@ -49,10 +65,12 @@ module Make (Lexer : Lexer.S)
(* Parsers *) (* Parsers *)
type 'a parser = Lexer.instance -> ('a, message Region.reg) result val parse_file :
string -> (AST.t, message Region.reg) Stdlib.result
val apply : Lexer.instance -> 'a parser -> ('a, message Region.reg) result val parse_string :
string -> (AST.t, message Region.reg) Stdlib.result
val parse_contract : AST.t parser val parse_expression :
val parse_expr : AST.expr parser string -> (AST.expr, message Region.reg) Stdlib.result
end end

4
src/passes/1-parser/shared/dune
View File

@ -9,7 +9,7 @@
uutf uutf
getopt getopt
zarith zarith
Preproc) Preprocessor)
(preprocess (preprocess
(pps bisect_ppx --conditional)) (pps bisect_ppx --conditional))
(modules (modules
@ -18,8 +18,8 @@
ParserAPI ParserAPI
Lexer Lexer
LexerLog LexerLog
Utils
Markup Markup
Utils
FQueue FQueue
EvalOpt EvalOpt
Version)) Version))

32
vendors/UnionFind/UnionFind.install vendored
View File

@ -1,23 +1,9 @@
lib: [ lib: [
"_build/install/default/lib/UnionFind/META" "_build/install/default/lib/UnionFind/META"
"_build/install/default/lib/UnionFind/Partition.cmi"
"_build/install/default/lib/UnionFind/Partition.cmti"
"_build/install/default/lib/UnionFind/Partition.mli" "_build/install/default/lib/UnionFind/Partition.mli"
"_build/install/default/lib/UnionFind/Partition0.cmi"
"_build/install/default/lib/UnionFind/Partition0.cmt"
"_build/install/default/lib/UnionFind/Partition0.cmx"
"_build/install/default/lib/UnionFind/Partition0.ml" "_build/install/default/lib/UnionFind/Partition0.ml"
"_build/install/default/lib/UnionFind/Partition1.cmi"
"_build/install/default/lib/UnionFind/Partition1.cmt"
"_build/install/default/lib/UnionFind/Partition1.cmx"
"_build/install/default/lib/UnionFind/Partition1.ml" "_build/install/default/lib/UnionFind/Partition1.ml"
"_build/install/default/lib/UnionFind/Partition2.cmi"
"_build/install/default/lib/UnionFind/Partition2.cmt"
"_build/install/default/lib/UnionFind/Partition2.cmx"
"_build/install/default/lib/UnionFind/Partition2.ml" "_build/install/default/lib/UnionFind/Partition2.ml"
"_build/install/default/lib/UnionFind/Partition3.cmi"
"_build/install/default/lib/UnionFind/Partition3.cmt"
"_build/install/default/lib/UnionFind/Partition3.cmx"
"_build/install/default/lib/UnionFind/Partition3.ml" "_build/install/default/lib/UnionFind/Partition3.ml"
"_build/install/default/lib/UnionFind/UnionFind.a" "_build/install/default/lib/UnionFind/UnionFind.a"
"_build/install/default/lib/UnionFind/UnionFind.cma" "_build/install/default/lib/UnionFind/UnionFind.cma"
@ -29,6 +15,24 @@ lib: [
"_build/install/default/lib/UnionFind/unionFind.cmt" "_build/install/default/lib/UnionFind/unionFind.cmt"
"_build/install/default/lib/UnionFind/unionFind.cmx" "_build/install/default/lib/UnionFind/unionFind.cmx"
"_build/install/default/lib/UnionFind/unionFind.ml" "_build/install/default/lib/UnionFind/unionFind.ml"
"_build/install/default/lib/UnionFind/unionFind__.cmi"
"_build/install/default/lib/UnionFind/unionFind__.cmt"
"_build/install/default/lib/UnionFind/unionFind__.cmx"
"_build/install/default/lib/UnionFind/unionFind__.ml"
"_build/install/default/lib/UnionFind/unionFind__Partition.cmi"
"_build/install/default/lib/UnionFind/unionFind__Partition.cmti"
"_build/install/default/lib/UnionFind/unionFind__Partition0.cmi"
"_build/install/default/lib/UnionFind/unionFind__Partition0.cmt"
"_build/install/default/lib/UnionFind/unionFind__Partition0.cmx"
"_build/install/default/lib/UnionFind/unionFind__Partition1.cmi"
"_build/install/default/lib/UnionFind/unionFind__Partition1.cmt"
"_build/install/default/lib/UnionFind/unionFind__Partition1.cmx"
"_build/install/default/lib/UnionFind/unionFind__Partition2.cmi"
"_build/install/default/lib/UnionFind/unionFind__Partition2.cmt"
"_build/install/default/lib/UnionFind/unionFind__Partition2.cmx"
"_build/install/default/lib/UnionFind/unionFind__Partition3.cmi"
"_build/install/default/lib/UnionFind/unionFind__Partition3.cmt"
"_build/install/default/lib/UnionFind/unionFind__Partition3.cmx"
] ]
doc: [ doc: [
"_build/install/default/doc/UnionFind/LICENSE" "_build/install/default/doc/UnionFind/LICENSE"

2
vendors/UnionFind/dune vendored
View File

@ -1,6 +1,6 @@
(library (library
(name UnionFind) (name UnionFind)
(public_name UnionFind) (public_name UnionFind)
(wrapped false) (wrapped true)
(modules Partition0 Partition1 Partition2 Partition3 Partition UnionFind) (modules Partition0 Partition1 Partition2 Partition3 Partition UnionFind)
(modules_without_implementation Partition)) (modules_without_implementation Partition))