From 1cc380417960cf4d656d792718890d64c18e2f17 Mon Sep 17 00:00:00 2001 From: Andreas Rossberg Date: Tue, 14 Nov 2023 11:57:20 +0100 Subject: [PATCH] [interpreter] Minor code clean-ups --- interpreter/script/js.ml | 4 +- interpreter/script/run.ml | 8 ++-- interpreter/text/arrange.ml | 10 ++--- interpreter/text/parse.ml | 80 ++++++++++++++++++++----------------- interpreter/text/parse.mli | 23 ++++------- 5 files changed, 57 insertions(+), 68 deletions(-) diff --git a/interpreter/script/js.ml b/interpreter/script/js.ml index d49ac6500b..acf4908200 100644 --- a/interpreter/script/js.ml +++ b/interpreter/script/js.ml @@ -526,9 +526,7 @@ let rec of_definition def = | Textual m -> of_bytes (Encode.encode m) | Encoded (_, bs) -> of_bytes bs | Quoted (_, s) -> - try - let _v, m = Parse.Module.from_string s in - of_definition m + try of_definition (snd (Parse.Module.from_string s)) with Script.Syntax _ -> of_bytes "" diff --git a/interpreter/script/run.ml b/interpreter/script/run.ml index 05ef1b0167..ca35d03dfe 100644 --- a/interpreter/script/run.ml +++ b/interpreter/script/run.ml @@ -105,7 +105,7 @@ let input_from get_script run = true with | Decode.Code (at, msg) -> error at "decoding error" msg - | Syntax (at, msg) -> error at "syntax error" msg + | Parse.Syntax (at, msg) -> error at "syntax error" msg | Valid.Invalid (at, msg) -> error at "invalid module" msg | Import.Unknown (at, msg) -> error at "link failure" msg | Eval.Link (at, msg) -> error at "link failure" msg @@ -121,14 +121,12 @@ let input_from get_script run = let input_script name lexbuf run = input_from (fun () -> Lexing.set_filename lexbuf name; - Parse.Script.from_lexbuf lexbuf) - run + Parse.Script.from_lexbuf lexbuf) run let input_script1 name lexbuf run = input_from (fun () -> Lexing.set_filename lexbuf name; - Parse.Script1.from_lexbuf lexbuf) - run + Parse.Script1.from_lexbuf lexbuf) run let input_sexpr name lexbuf run = input_from (fun () -> diff --git a/interpreter/text/arrange.ml b/interpreter/text/arrange.ml index a11e50045d..0a9bddb0f6 100644 --- a/interpreter/text/arrange.ml +++ b/interpreter/text/arrange.ml @@ -679,25 +679,21 @@ let definition mode x_opt def = match def.it with | Textual m -> m | Encoded (_, bs) -> Decode.decode "" bs - | Quoted (_, s) -> - let _v, m = Parse.Module.from_string s in - unquote m + | Quoted (_, s) -> unquote (snd (Parse.Module.from_string s)) in module_with_var_opt x_opt (unquote def) | `Binary -> let rec unquote def = match def.it with | Textual m -> Encode.encode m | Encoded (_, bs) -> Encode.encode (Decode.decode "" bs) - | Quoted (_, s) -> - let _v, m = Parse.Module.from_string s in - unquote m + | Quoted (_, s) -> unquote (snd (Parse.Module.from_string s)) in binary_module_with_var_opt x_opt (unquote def) | `Original -> match def.it with | Textual m -> module_with_var_opt x_opt m | Encoded (_, bs) -> binary_module_with_var_opt x_opt bs | Quoted (_, s) -> quoted_module_with_var_opt x_opt s - with Script.Syntax _ -> + with Parse.Syntax _ -> quoted_module_with_var_opt x_opt "" let access x_opt n = diff --git a/interpreter/text/parse.ml b/interpreter/text/parse.ml index 306025af17..7e8ab5a86d 100644 --- a/interpreter/text/parse.ml +++ b/interpreter/text/parse.ml @@ -1,47 +1,53 @@ -module Make (M : sig +exception Syntax = Script.Syntax + +module type S = +sig type t + val from_lexbuf : Lexing.lexbuf -> t + val from_file : string -> t + val from_string : string -> t + val from_channel : in_channel -> t +end +module type Rule = +sig + type t val rule : (Lexing.lexbuf -> Parser.token) -> Lexing.lexbuf -> t +end -end) = struct - - type nonrec t = M.t - - let from_lexbuf = - let parser = MenhirLib.Convert.Simplified.traditional2revised M.rule in - fun buf -> - let provider () = - let tok = Lexer.token buf in - let start = Lexing.lexeme_start_p buf in - let stop = Lexing.lexeme_end_p buf in - tok, start, stop - in - try parser provider with - | Parser.Error -> - let left = Lexer.convert_pos buf.Lexing.lex_start_p in - let right = Lexer.convert_pos buf.Lexing.lex_curr_p in - let region = { Source.left; right } in - raise (Script.Syntax (region, "unexpected token")) - | Script.Syntax (region, s) as exn -> - if region <> Source.no_region then raise exn - else - let region' = { - Source.left = Lexer.convert_pos buf.Lexing.lex_start_p; - Source.right = Lexer.convert_pos buf.Lexing.lex_curr_p } - in - raise (Script.Syntax (region', s)) - - let from_file filename = - let chan = open_in filename in - Fun.protect ~finally:(fun () -> close_in chan) - (fun () -> - let lb = Lexing.from_channel ~with_positions:true chan in - Lexing.set_filename lb filename; - from_lexbuf lb) +module Make (M : Rule) : S with type t = M.t = +struct + type t = M.t - let from_string s = from_lexbuf (Lexing.from_string ~with_positions:true s) + let provider buf () = + let tok = Lexer.token buf in + let start = Lexing.lexeme_start_p buf in + let stop = Lexing.lexeme_end_p buf in + tok, start, stop + + let convert_pos buf = + { Source.left = Lexer.convert_pos buf.Lexing.lex_start_p; + Source.right = Lexer.convert_pos buf.Lexing.lex_curr_p + } + let from_lexbuf buf = + try + MenhirLib.Convert.Simplified.traditional2revised M.rule (provider buf) + with + | Parser.Error -> + raise (Syntax (convert_pos buf, "unexpected token")) + | Syntax (region, s) when region <> Source.no_region -> + raise (Syntax (convert_pos buf, s)) + + let from_string s = from_lexbuf (Lexing.from_string ~with_positions:true s) let from_channel c = from_lexbuf (Lexing.from_channel ~with_positions:true c) + let from_file name = + let chan = open_in name in + Fun.protect ~finally:(fun () -> close_in chan) (fun () -> + let buf = Lexing.from_channel ~with_positions:true chan in + Lexing.set_filename buf name; + from_lexbuf buf + ) end module Module = Make (struct diff --git a/interpreter/text/parse.mli b/interpreter/text/parse.mli index 4077329760..fbef88ecc5 100644 --- a/interpreter/text/parse.mli +++ b/interpreter/text/parse.mli @@ -1,23 +1,14 @@ -module Module : sig - type t = Script.var option * Script.definition - val from_lexbuf : Lexing.lexbuf -> t - val from_file : string -> t - val from_string : string -> t - val from_channel : in_channel -> t -end +exception Syntax of Source.region * string -module Script1 : sig - type t = Script.script +module type S = +sig + type t val from_lexbuf : Lexing.lexbuf -> t val from_file : string -> t val from_string : string -> t val from_channel : in_channel -> t end -module Script : sig - type t = Script.script - val from_lexbuf : Lexing.lexbuf -> t - val from_file : string -> t - val from_string : string -> t - val from_channel : in_channel -> t -end +module Module : S with type t = Script.var option * Script.definition +module Script1 : S with type t = Script.script +module Script : S with type t = Script.script