Cleanup in the generation of the .ml and .mli files.

Things are reasonably clean now.

src/IL.mli

@@ -21,7 +21,7 @@ and interface_item =
 
 and module_type =
   | MTNamedModuleType of string
-  | MTWithType of module_type * string * with_kind * typ
+  | MTWithType of module_type * string list * string * with_kind * typ
   | MTSigEnd of interface
 
 and with_kind =

src/IncrementalEngine.ml

@@ -94,10 +94,16 @@ end
 
 module type INSPECTION = sig
 
-  type xsymbol
+  type 'a lr1state
 
   type production
 
+  type 'a symbol
+
+  type xsymbol
+
+  val symbol: 'a lr1state -> 'a symbol
+
   val lhs: production -> xsymbol
 
   val rhs: production -> xsymbol list

src/codeBits.ml

@@ -217,7 +217,7 @@ let interface_to_structure i =
    constraints. *)
 
 let with_types wk name tys =
-  List.fold_left (fun mt (name, ty) ->
-    MTWithType (mt, name, wk, ty)
+  List.fold_left (fun mt (params, name, ty) ->
+    MTWithType (mt, params, name, wk, ty)
   ) (MTNamedModuleType name) tys
 

src/codeBits.mli

@@ -84,5 +84,5 @@ val interface_to_structure: interface -> structure
 
 (* Constructing a named module type together with a list of "with type"
    constraints. *)
-val with_types: IL.with_kind -> string -> (string * IL.typ) list -> IL.module_type
+val with_types: IL.with_kind -> string -> (string list * string * IL.typ) list -> IL.module_type
 

src/interface.ml

@@ -34,6 +34,27 @@ let interpreter =
 let result t =
   TypApp (interpreter ^ ".result", [ t ])
 
+let raw_lr1state =
+  "lr1state"
+
+let lr1state =
+  interpreter ^ "." ^ raw_lr1state
+
+let tlr1state a : typ =
+  TypApp (lr1state, [a])
+
+(* This interface item is a re-definition of the type [lr1state] as
+   an abbreviation for [MenhirInterpreter.lr1state]. *)
+
+let lr1state_redef =
+  let a = "a" in
+  IITypeDecls [{
+    typename = raw_lr1state;
+    typeparams = [ a ];
+    typerhs = TAbbrev (tlr1state (TypVar a));
+    typeconstraint = None
+  }]
+
 (* -------------------------------------------------------------------------- *)
 
 (* The name of the sub-module that contains the incremental entry points. *)
@@ -87,6 +108,7 @@ let incremental_api grammar () =
     with_types WKDestructive
       "MenhirLib.IncrementalEngine.INCREMENTAL_ENGINE"
       [
+        [],
         "token", (* NOT [tctoken], which is qualified if [--external-tokens] is used *)
         TokenType.ttoken
       ]
@@ -109,29 +131,29 @@ let incremental_api grammar () =
 
 let inspection_api grammar () =
 
+  let a = "a" in
+
   IIComment "The inspection API." ::
   IIModule (inspection, MTSigEnd (
 
+    (* Define the types [terminal], [nonterminal], [symbol], [xsymbol]. *)
+
     TokenType.tokengadtdef grammar @
     NonterminalType.nonterminalgadtdef grammar @
     SymbolType.symbolgadtdef() @
     SymbolType.xsymboldef() @
 
-    IIComment "This function maps a state to its incoming symbol." ::
-    IIValDecls [
-      let ty =
-        arrow (TypApp (interpreter ^ ".lr1state", [ TypVar "a" ]))
-              (TypApp ("symbol", [ TypVar "a" ]))
-      in
-      (* TEMPORARY code sharing with tableBackend *)
-      "symbol", type2scheme ty
-    ] ::
+    (* Include the signature that lists the inspection functions, with
+       appropriate type instantiations. *)
 
+    IIComment "The inspection functions." ::
     IIInclude (
       with_types WKDestructive
         "MenhirLib.IncrementalEngine.INSPECTION" [
-          SymbolType.tcxsymbol, SymbolType.txsymbol;
-          "production", TypApp ("MenhirInterpreter.production", [])
+          [ a ], "lr1state", tlr1state (TypVar a);
+          [], "production", TypApp ("MenhirInterpreter.production", []);
+          [ a ], SymbolType.tcsymbolgadt, SymbolType.tsymbolgadt (TypVar a);
+          [], SymbolType.tcxsymbol, SymbolType.txsymbol;
         ]
     ) ::
 

src/interface.mli

@@ -18,6 +18,12 @@ val interpreter: string
 
 val result: IL.typ -> IL.typ
 
+(* The type ['a lr1state], defined by the interpreter sub-module. *)
+
+val lr1state: string
+val tlr1state: IL.typ -> IL.typ
+val lr1state_redef: IL.interface_item
+
 (* The name of the sub-module that contains the incremental entry points. *)
 
 val incremental: string

src/printer.ml

@@ -677,16 +677,16 @@ let with_kind f = function
 let rec module_type f = function
   | MTNamedModuleType s ->
       output_string f s
-  | MTWithType (mt, name, wk, t) ->
+  | MTWithType (mt, params, name, wk, t) ->
       fprintf f "%a%a"
         module_type mt
-        (indent 2 with_type) (name, wk, t)
+        (indent 2 with_type) (params, name, wk, t)
   | MTSigEnd i ->
       sigend f i
 
-and with_type f (name, wk, t) =
-  fprintf f "with type %s %a %a"
-    name
+and with_type f (params, name, wk, t) =
+  fprintf f "with type %a %a %a"
+    typ (TypApp (name, List.map (fun v -> TypVar v) params))
     with_kind wk
     typ t
 

src/symbolType.mli

 (* The symbol GADT is the union of the terminal and nonterminal GADTs. *)
 
+val tcsymbolgadt: string
 val tsymbolgadt: IL.typ -> IL.typ
 
 (* The conventional names of the data constructors. *)

src/tableBackend.ml

@@ -65,9 +65,6 @@ let entry =
 let start =
   interpreter ^ ".start"
 
-let lr1state =
-  interpreter ^ ".lr1state"
-
 let basics =
   "Basics" (* name of an internal sub-module *)
 
@@ -776,16 +773,13 @@ let esymbol (symbol : Symbol.t) : expr =
 let xsymbol (symbol : Symbol.t) : expr =
   EData (dataX, [ esymbol symbol ])
 
-(* The type [MenhirInterpreter.lr1state] is known (to us) to be an
-   alias for [int], so we can pattern match on it. To the user,
-   though, it will be an abstract type. *)
-
-let tlr1state a : typ =
-  TypApp (lr1state, [a])
-
 (* Produce a function [symbol] that maps a state of type ['a lr1state]
    (represented as an integer value) to a value of type ['a symbol]. *)
 
+(* The type [MenhirInterpreter.lr1state] is known (to us) to be an alias for
+   [int], so we can pattern match on it. To the user, though, it will be an
+   abstract type. *)
+
 let incoming_symbol_def () = {
   valpublic = true;
   valpat = PVar "symbol";
@@ -912,6 +906,7 @@ let program =
 
         SIModuleDef (more, MStruct (
           interface_to_structure (
+            lr1state_redef ::
             tokengadtdef grammar @
             nonterminalgadtdef grammar @
             symbolgadtdef() @
@@ -921,13 +916,10 @@ let program =
 
         SIInclude (MVar more) ::
 
-        SIValDefs (false, [
-          incoming_symbol_def()
-        ]) ::
-
         SIInclude (MApp (MVar make_inspection, MStruct [
           SIInclude (MVar more);
           SIValDefs (false, [
+            incoming_symbol_def();
             production_defs()
           ])
         ])) ::

src/tableFormat.ml

@@ -121,8 +121,14 @@ end
 
 module type INSPECTION_TABLES = sig
 
+  type 'a lr1state
+  type 'a symbol
   type xsymbol
 
+  (* This function maps a state to its incoming symbol. *)
+
+  val symbol: 'a lr1state -> 'a symbol
+
   (* The definition (i.e. left-hand side and right-hand side) of every
      (non-start) production. *)
 

src/tableInterpreter.ml

@@ -171,6 +171,9 @@ end)
 
 module MakeInspection (T : TableFormat.INSPECTION_TABLES) = struct
 
+  let symbol =
+    T.symbol
+
   let production_def prod =
     assert (0 <= prod && prod < Array.length T.production_defs);
     match T.production_defs.(prod) with

src/tableInterpreter.mli

@@ -24,6 +24,8 @@ module Make (T : TableFormat.TABLES)
 module MakeInspection (T : TableFormat.INSPECTION_TABLES)
 
 : IncrementalEngine.INSPECTION
-  with type xsymbol := T.xsymbol
+  with type 'a lr1state := 'a T.lr1state
+   and type 'a symbol := 'a T.symbol
+   and type xsymbol := T.xsymbol
    and type production := int