Skip to content

Commit

Permalink
[interpreter] Minor code clean-ups
Browse files Browse the repository at this point in the history
  • Loading branch information
rossberg committed Nov 14, 2023
1 parent 4f69eee commit 1cc3804
Show file tree
Hide file tree
Showing 5 changed files with 57 additions and 68 deletions.
4 changes: 1 addition & 3 deletions interpreter/script/js.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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 "<malformed quote>"

Expand Down
8 changes: 3 additions & 5 deletions interpreter/script/run.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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 () ->
Expand Down
10 changes: 3 additions & 7 deletions interpreter/text/arrange.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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 "<invalid module>"

let access x_opt n =
Expand Down
80 changes: 43 additions & 37 deletions interpreter/text/parse.ml
Original file line number Diff line number Diff line change
@@ -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
Expand Down
23 changes: 7 additions & 16 deletions interpreter/text/parse.mli
Original file line number Diff line number Diff line change
@@ -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

0 comments on commit 1cc3804

Please sign in to comment.