[interpreter] Simplify functor

Author: rossberg

interpreter/script/js.ml

@@ -526,8 +526,8 @@ let rec of_definition def =
   | Textual m -> of_bytes (Encode.encode m)
   | Encoded (_, bs) -> of_bytes bs
   | Quoted (_, s) ->
-    try of_definition (snd (Parse.Module.from_string s))
-    with Script.Syntax _ ->
+    try of_definition (snd (Parse.Module.parse_string s))
+    with Parse.Syntax _ ->
       of_bytes "<malformed quote>"
 
 let of_wrapper mods x_opt name wrap_action wrap_assertion at =
@@ -595,7 +595,7 @@ let of_command mods cmd =
       match def.it with
       | Textual m -> m
       | Encoded (_, bs) -> Decode.decode "binary" bs
-      | Quoted (_, s) -> unquote (snd (Parse.Module.from_string s))
+      | Quoted (_, s) -> unquote (snd (Parse.Module.parse_string s))
     in bind mods x_opt (unquote def);
     "let " ^ current_var mods ^ " = instance(" ^ of_definition def ^ ");\n" ^
     (if x_opt = None then "" else

interpreter/script/run.ml

@@ -119,18 +119,14 @@ let input_from get_script run =
   | Abort _ -> false
 
 let input_script name lexbuf run =
-  input_from (fun () ->
-    Lexing.set_filename lexbuf name;
-    Parse.Script.from_lexbuf lexbuf) run
+  input_from (fun () -> Parse.Script.parse name lexbuf) run
 
 let input_script1 name lexbuf run =
-  input_from (fun () ->
-    Lexing.set_filename lexbuf name;
-    Parse.Script1.from_lexbuf lexbuf) run
+  input_from (fun () -> Parse.Script1.parse name lexbuf) run
 
 let input_sexpr name lexbuf run =
   input_from (fun () ->
-    let var_opt, def = Parse.Module.from_lexbuf lexbuf in
+    let var_opt, def = Parse.Module.parse name lexbuf in
     [Module (var_opt, def) @@ no_region]) run
 
 let input_binary name buf run =
@@ -344,7 +340,7 @@ let rec run_definition def : Ast.module_ =
     Decode.decode name bs
   | Quoted (_, s) ->
     trace "Parsing quote...";
-    let _, def' = Parse.Module.from_string s in
+    let _, def' = Parse.Module.parse_string s in
     run_definition def'
 
 let run_action act : Values.value list =
@@ -450,7 +446,7 @@ let run_assertion ass =
     trace "Asserting malformed...";
     (match ignore (run_definition def) with
     | exception Decode.Code (_, msg) -> assert_message ass.at "decoding" msg re
-    | exception Syntax (_, msg) -> assert_message ass.at "parsing" msg re
+    | exception Parse.Syntax (_, msg) -> assert_message ass.at "parsing" msg re
     | _ -> Assert.error ass.at "expected decoding/parsing error"
     )
 

interpreter/script/script.ml

@@ -63,8 +63,6 @@ and meta' =
 
 and script = command list
 
-exception Syntax of Source.region * string
-
 
 let () =
   let type_of_ref' = !Values.type_of_ref' in

interpreter/text/arrange.ml

@@ -679,14 +679,14 @@ let definition mode x_opt def =
         match def.it with
         | Textual m -> m
         | Encoded (_, bs) -> Decode.decode "" bs
-        | Quoted (_, s) -> unquote (snd (Parse.Module.from_string s))
+        | Quoted (_, s) -> unquote (snd (Parse.Module.parse_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) -> unquote (snd (Parse.Module.from_string s))
+        | Quoted (_, s) -> unquote (snd (Parse.Module.parse_string s))
       in binary_module_with_var_opt x_opt (unquote def)
     | `Original ->
       match def.it with

interpreter/text/lexer.mll

@@ -14,7 +14,7 @@ let region lexbuf =
   let right = convert_pos (Lexing.lexeme_end_p lexbuf) in
   {left = left; right = right}
 
-let error lexbuf msg = raise (Script.Syntax (region lexbuf, msg))
+let error lexbuf msg = raise (Parse_error.Syntax (region lexbuf, msg))
 let error_nest start lexbuf msg =
   lexbuf.Lexing.lex_start_p <- start;
   error lexbuf msg

interpreter/text/parse.ml

@@ -1,66 +1,52 @@
-exception Syntax = Script.Syntax
+exception Syntax = Parse_error.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
+  val parse : string -> Lexing.lexbuf -> t
+  val parse_file : string -> t
+  val parse_string : string -> t
+  val parse_channel : in_channel -> t
 end
 
-module type Rule =
-sig
-  type t
-  val rule : (Lexing.lexbuf -> Parser.token) -> Lexing.lexbuf -> t
-end
-
-module Make (M : Rule) : S with type t = M.t =
-struct
-  type t = M.t
-
-  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 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 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 make (type a) (start : _ -> _ -> a) : (module S with type t = a) =
+  (module struct
+    type t = a
 
-  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
+    let parse name buf =
       Lexing.set_filename buf name;
-      from_lexbuf buf
-    )
-end
-
-module Module = Make (struct
-  type t = Script.var option * Script.definition
-  let rule = Parser.module1
-end)
-
-module Script1 = Make (struct
-  type t = Script.script
-  let rule = Parser.script1
-end)
-
-module Script = Make (struct
-  type t =  Script.script
-  let rule = Parser.script
-end)
+      try
+        MenhirLib.Convert.Simplified.traditional2revised start (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 parse_string s =
+      parse "string" (Lexing.from_string ~with_positions:true s)
+
+    let parse_channel oc =
+      parse "channel" (Lexing.from_channel ~with_positions:true oc)
+
+    let parse_file name =
+      let oc = open_in name in
+      Fun.protect ~finally:(fun () -> close_in oc) (fun () ->
+        parse name (Lexing.from_channel ~with_positions:true oc)
+      )
+  end)
+
+module Module = (val make Parser.module1)
+module Script = (val make Parser.script)
+module Script1 = (val make Parser.script1)

interpreter/text/parse.mli

@@ -3,10 +3,10 @@ exception Syntax of Source.region * string
 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
+  val parse : string -> Lexing.lexbuf -> t
+  val parse_file : string -> t
+  val parse_string : string -> t
+  val parse_channel : in_channel -> t
 end
 
 module Module : S with type t = Script.var option * Script.definition

interpreter/text/parse_error.ml

@@ -0,0 +1,3 @@
+(* This is here since both Lexer, Parser, and Parse need it,
+ * but menhir cannot create a Parser that exports it. *)
+exception Syntax of Source.region * string

interpreter/text/parser.mly

@@ -8,7 +8,7 @@ open Script
 
 (* Error handling *)
 
-let error at msg = raise (Script.Syntax (at, msg))
+let error at msg = raise (Parse_error.Syntax (at, msg))
 
 
 (* Position handling *)