[interpreter] Minor code clean-ups

Author: rossberg

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 "<malformed quote>"
 

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

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 "<invalid module>"
 
 let access x_opt n =

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

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