Commit facc2e90 authored by POTTIER Francois's avatar POTTIER Francois

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

Things are reasonably clean now.
parent cca9e4f5
......@@ -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 =
......
......@@ -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
......
......@@ -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
......@@ -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
......@@ -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;
]
) ::
......
......@@ -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
......
......@@ -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
......
(* 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. *)
......
......@@ -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()
])
])) ::
......
......@@ -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. *)
......
......@@ -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
......
......@@ -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
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment