Parser plumbing

lib/Makefile

@@ -9,7 +9,7 @@ data:
 	cd data && python3.6 ../pack_data.py > ../data.ml
 
 main.byte:
-	ocamlfind ocamlc -g -I "mlts_api/_build" -package elpi -package js_of_ocaml -package js_of_ocaml.ppx -package base64 -linkpkg mlts_API.cma data.mli data.ml main.ml -o main.byte
+	ocamlfind ocamlc -g -I "mlts_api/_build" -package elpi -package js_of_ocaml -package js_of_ocaml.ppx -package base64 -package menhirLib -linkpkg mlts_API.cma data.mli data.ml main.ml -o main.byte
 
 js: main.byte
 	js_of_ocaml --opt 3 +weak.js main.byte

lib/mlts_api/.merlin

@@ -1 +1,3 @@
-B _build
+B _build
+PKG ocamlbuild
+PKG menhirLib

lib/mlts_api/Makefile

@@ -2,4 +2,4 @@
 .PHONY: 	all 
 
 all:
-	ocamlbuild mlts_API.cma
+	ocamlbuild -use-ocamlfind mlts_API.cma

lib/mlts_api/_tags

@@ -1 +1,2 @@
-true: use_menhir, explain
+true: use_menhir, explain, package(menhirLib)
+<mltsParser.*>: explain, menhir_table

lib/mlts_api/mlts_API.ml

@@ -7,18 +7,52 @@ let string_of_pos l c =
   ("Line " ^ (string_of_int l)
    ^ ", column "^ (string_of_int c) ^ ": ")
 
+exception Parse_error of string option * Lexing.position * Lexing.position
+let parse parse_fun lexbuf =
+  (* see the Menhir manual for the description of
+     error messages support *)
+  let open MenhirLib.General in
+  let module Interp = MltsParser.MenhirInterpreter in
+  let input = Interp.lexer_lexbuf_to_supplier MltsLexer.token lexbuf in
+  let success prog = prog in
+  let failure error_state =
+    let env = match[@warning "-4"] error_state with
+      | Interp.HandlingError env -> env
+      | _ -> assert false in
+    match Interp.stack env with
+    | lazy Nil -> assert false
+    | lazy (Cons (Interp.Element (state, _, start_pos, end_pos), _)) ->
+      let message =
+        match MltsParser_messages.message (Interp.number state) with
+        | exception Not_found -> None
+        | empty when String.trim empty = "" -> None
+        | "<YOUR SYNTAX ERROR MESSAGE HERE>\n" -> None
+        | error_message -> Some error_message
+      in
+      raise (Parse_error (message, start_pos, end_pos))
+  in
+  Interp.loop_handle success failure input
+    (parse_fun lexbuf.Lexing.lex_curr_p)
+
 let parse_and_translate mlts_prog =
   let tokens = Lexing.from_string mlts_prog in
   try
-    let p = MltsParser.main MltsLexer.token tokens in
-
+    let p = parse MltsParser.Incremental.main tokens in
     let prog, _, _, _ = Translator.toLPString p in
     prog
   with Translator.TranslatorError(s, pos)
        -> raise (Error("Translation error : " ^ s, 0, 0))
      | MltsLexer.Error(s, pos)
        -> let l, c = ints_of_pos pos in
           raise (Error((string_of_pos l c) ^ "Lexing error : " ^ s, l, c))
-     | MltsParser.Error ->
-        let l, c = ints_of_pos (tokens.Lexing.lex_curr_p) in
-        raise (Error((string_of_pos l c) ^ "Parsing error.", l, c))
+     | Parse_error (parser_message, start_pos, end_pos) ->
+        let l, c = ints_of_pos start_pos in
+        ignore end_pos;
+        (* TODO: use both the start and end position of the error
+           (they may span several characters and several lines) *)
+        let message = Printf.sprintf "%sParsing error%s"
+            (string_of_pos l c)
+            (match parser_message with
+             | None -> "."
+             | Some str -> " : " ^ str) in
+        raise (Error(message, l, c))

lib/mlts_api/myocamlbuild.ml

@@ -0,0 +1,95 @@
+open Ocamlbuild_plugin
+
+module Menhir = struct
+  let menhir () =
+    if !Options.ocamlyacc = N then V"MENHIR" else !Options.ocamlyacc
+  let menhir_tags mly =
+    tags_of_pathname mly ++"ocaml"++"parser"++"menhir"
+
+  let menhir_produce_messages env build =
+    let messages, mly = env "%.messages", env "%.mly" in
+    let open Ocamlbuild_pack in
+    Ocaml_compiler.prepare_compile build mly;
+    Cmd(S[menhir (); T (menhir_tags mly);
+          A "--list-errors"; P mly; Sh ">"; Px messages])
+
+  let menhir_compile_messages env build =
+    let mly = env "%.mly" in
+    let messages = env "%.messages" in
+    let target = env "%_messages.ml" in
+    Cmd(S[menhir (); T (menhir_tags mly); P mly;
+          A "--compile-errors"; P messages;
+          Sh ">"; Px target])
+
+  let menhir_update_messages env build =
+    let mly = env "%.mly" in
+    let messages = env "%.messages" in
+    let tmp = Filename.temp_file "menhir" ".messages" in
+    Seq [
+      Cmd(S[menhir (); T (menhir_tags mly); P mly;
+            A "--update-errors"; P messages;
+            Sh ">"; P tmp]);
+      Cmd(S[A "mv"; P tmp; P messages]);
+    ]
+
+  let dispatcher = function
+      | After_rules ->
+        flag ["menhir"; "parser"; "menhir_trace"] (A"--trace");
+        flag ["menhir"; "parser"; "menhir_table"] (A "--table");
+        flag ["menhir"; "parser"; "menhir_canonical"] (A"--canonical");
+        rule "menhir: .mly -> .messages"
+          ~prod:"%.messages"
+          ~deps:["%.mly"]
+          menhir_produce_messages;
+        rule "menhir: .mly & .messages -> _messages.ml"
+          ~prod:"%_messages.ml"
+          ~deps:["%.mly"; "%.messages"]
+          menhir_compile_messages;
+        rule "menhir: .mly & .messages -> .messages & .messages.update"
+          ~stamp:"%.messages.update"
+          ~deps:["%.mly"; "%.messages"]
+          menhir_update_messages;
+      | _ -> ()
+end
+
+(* Howto: create and maintain parser error-message files
+
+# If you have no .messages file in your repository,
+# create one from foo.mly with the following commands:
+
+ocamlbuild -use-ocamlfind foo.messages
+cp _build/foo.messages .
+
+# Once you have a foo.messages file, you can get
+# an OCaml module Foo_messages with the following command
+
+ocamlbuild -use-ocamlfind foo_messages.ml
+
+# (see _build/foo_messages.ml for what this
+#  auto-generated source file looks like.)
+# You don't actually need to run this command and can use Foo_messages
+# as an OCaml module in your code, ocamlbuild will build it on-demand
+
+# Once you have your foo.messages file, you need to fill the error messages
+# in it. foo_messages.ml will get updated automatically. However, if your
+# foo.mly file changes, foo.messages will not get updated automatically
+# (this requires manual error-message adaptation in general),
+# so you should manually request the update with using the
+# foo.messages.update stamp target:
+
+ocamlbuild -use-ocamlfind foo.messages.update
+cp _build/foo.messages .
+
+# then check using your version-control system that the changes
+# to the .messages file are as you expect
+
+*)
+
+
+let _ =
+       dispatch
+         (fun hook ->
+            Menhir.dispatcher hook;
+         )
+
+