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 = ...@@ -21,7 +21,7 @@ and interface_item =
and module_type = and module_type =
| MTNamedModuleType of string | MTNamedModuleType of string
| MTWithType of module_type * string * with_kind * typ | MTWithType of module_type * string list * string * with_kind * typ
| MTSigEnd of interface | MTSigEnd of interface
and with_kind = and with_kind =
......
...@@ -94,10 +94,16 @@ end ...@@ -94,10 +94,16 @@ end
module type INSPECTION = sig module type INSPECTION = sig
type xsymbol type 'a lr1state
type production type production
type 'a symbol
type xsymbol
val symbol: 'a lr1state -> 'a symbol
val lhs: production -> xsymbol val lhs: production -> xsymbol
val rhs: production -> xsymbol list val rhs: production -> xsymbol list
......
...@@ -217,7 +217,7 @@ let interface_to_structure i = ...@@ -217,7 +217,7 @@ let interface_to_structure i =
constraints. *) constraints. *)
let with_types wk name tys = let with_types wk name tys =
List.fold_left (fun mt (name, ty) -> List.fold_left (fun mt (params, name, ty) ->
MTWithType (mt, name, wk, ty) MTWithType (mt, params, name, wk, ty)
) (MTNamedModuleType name) tys ) (MTNamedModuleType name) tys
...@@ -84,5 +84,5 @@ val interface_to_structure: interface -> structure ...@@ -84,5 +84,5 @@ val interface_to_structure: interface -> structure
(* Constructing a named module type together with a list of "with type" (* Constructing a named module type together with a list of "with type"
constraints. *) 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 = ...@@ -34,6 +34,27 @@ let interpreter =
let result t = let result t =
TypApp (interpreter ^ ".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. *) (* The name of the sub-module that contains the incremental entry points. *)
...@@ -87,6 +108,7 @@ let incremental_api grammar () = ...@@ -87,6 +108,7 @@ let incremental_api grammar () =
with_types WKDestructive with_types WKDestructive
"MenhirLib.IncrementalEngine.INCREMENTAL_ENGINE" "MenhirLib.IncrementalEngine.INCREMENTAL_ENGINE"
[ [
[],
"token", (* NOT [tctoken], which is qualified if [--external-tokens] is used *) "token", (* NOT [tctoken], which is qualified if [--external-tokens] is used *)
TokenType.ttoken TokenType.ttoken
] ]
...@@ -109,29 +131,29 @@ let incremental_api grammar () = ...@@ -109,29 +131,29 @@ let incremental_api grammar () =
let inspection_api grammar () = let inspection_api grammar () =
let a = "a" in
IIComment "The inspection API." :: IIComment "The inspection API." ::
IIModule (inspection, MTSigEnd ( IIModule (inspection, MTSigEnd (
(* Define the types [terminal], [nonterminal], [symbol], [xsymbol]. *)
TokenType.tokengadtdef grammar @ TokenType.tokengadtdef grammar @
NonterminalType.nonterminalgadtdef grammar @ NonterminalType.nonterminalgadtdef grammar @
SymbolType.symbolgadtdef() @ SymbolType.symbolgadtdef() @
SymbolType.xsymboldef() @ SymbolType.xsymboldef() @
IIComment "This function maps a state to its incoming symbol." :: (* Include the signature that lists the inspection functions, with
IIValDecls [ appropriate type instantiations. *)
let ty =
arrow (TypApp (interpreter ^ ".lr1state", [ TypVar "a" ]))
(TypApp ("symbol", [ TypVar "a" ]))
in
(* TEMPORARY code sharing with tableBackend *)
"symbol", type2scheme ty
] ::
IIComment "The inspection functions." ::
IIInclude ( IIInclude (
with_types WKDestructive with_types WKDestructive
"MenhirLib.IncrementalEngine.INSPECTION" [ "MenhirLib.IncrementalEngine.INSPECTION" [
SymbolType.tcxsymbol, SymbolType.txsymbol; [ a ], "lr1state", tlr1state (TypVar a);
"production", TypApp ("MenhirInterpreter.production", []) [], "production", TypApp ("MenhirInterpreter.production", []);
[ a ], SymbolType.tcsymbolgadt, SymbolType.tsymbolgadt (TypVar a);
[], SymbolType.tcxsymbol, SymbolType.txsymbol;
] ]
) :: ) ::
......
...@@ -18,6 +18,12 @@ val interpreter: string ...@@ -18,6 +18,12 @@ val interpreter: string
val result: IL.typ -> IL.typ 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. *) (* The name of the sub-module that contains the incremental entry points. *)
val incremental: string val incremental: string
......
...@@ -677,16 +677,16 @@ let with_kind f = function ...@@ -677,16 +677,16 @@ let with_kind f = function
let rec module_type f = function let rec module_type f = function
| MTNamedModuleType s -> | MTNamedModuleType s ->
output_string f s output_string f s
| MTWithType (mt, name, wk, t) -> | MTWithType (mt, params, name, wk, t) ->
fprintf f "%a%a" fprintf f "%a%a"
module_type mt module_type mt
(indent 2 with_type) (name, wk, t) (indent 2 with_type) (params, name, wk, t)
| MTSigEnd i -> | MTSigEnd i ->
sigend f i sigend f i
and with_type f (name, wk, t) = and with_type f (params, name, wk, t) =
fprintf f "with type %s %a %a" fprintf f "with type %a %a %a"
name typ (TypApp (name, List.map (fun v -> TypVar v) params))
with_kind wk with_kind wk
typ t typ t
......
(* The symbol GADT is the union of the terminal and nonterminal GADTs. *) (* The symbol GADT is the union of the terminal and nonterminal GADTs. *)
val tcsymbolgadt: string
val tsymbolgadt: IL.typ -> IL.typ val tsymbolgadt: IL.typ -> IL.typ
(* The conventional names of the data constructors. *) (* The conventional names of the data constructors. *)
......
...@@ -65,9 +65,6 @@ let entry = ...@@ -65,9 +65,6 @@ let entry =
let start = let start =
interpreter ^ ".start" interpreter ^ ".start"
let lr1state =
interpreter ^ ".lr1state"
let basics = let basics =
"Basics" (* name of an internal sub-module *) "Basics" (* name of an internal sub-module *)
...@@ -776,16 +773,13 @@ let esymbol (symbol : Symbol.t) : expr = ...@@ -776,16 +773,13 @@ let esymbol (symbol : Symbol.t) : expr =
let xsymbol (symbol : Symbol.t) : expr = let xsymbol (symbol : Symbol.t) : expr =
EData (dataX, [ esymbol symbol ]) 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] (* Produce a function [symbol] that maps a state of type ['a lr1state]
(represented as an integer value) to a value of type ['a symbol]. *) (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 () = { let incoming_symbol_def () = {
valpublic = true; valpublic = true;
valpat = PVar "symbol"; valpat = PVar "symbol";
...@@ -912,6 +906,7 @@ let program = ...@@ -912,6 +906,7 @@ let program =
SIModuleDef (more, MStruct ( SIModuleDef (more, MStruct (
interface_to_structure ( interface_to_structure (
lr1state_redef ::
tokengadtdef grammar @ tokengadtdef grammar @
nonterminalgadtdef grammar @ nonterminalgadtdef grammar @
symbolgadtdef() @ symbolgadtdef() @
...@@ -921,13 +916,10 @@ let program = ...@@ -921,13 +916,10 @@ let program =
SIInclude (MVar more) :: SIInclude (MVar more) ::
SIValDefs (false, [
incoming_symbol_def()
]) ::
SIInclude (MApp (MVar make_inspection, MStruct [ SIInclude (MApp (MVar make_inspection, MStruct [
SIInclude (MVar more); SIInclude (MVar more);
SIValDefs (false, [ SIValDefs (false, [
incoming_symbol_def();
production_defs() production_defs()
]) ])
])) :: ])) ::
......
...@@ -121,8 +121,14 @@ end ...@@ -121,8 +121,14 @@ end
module type INSPECTION_TABLES = sig module type INSPECTION_TABLES = sig
type 'a lr1state
type 'a symbol
type xsymbol 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 (* The definition (i.e. left-hand side and right-hand side) of every
(non-start) production. *) (non-start) production. *)
......
...@@ -171,6 +171,9 @@ end) ...@@ -171,6 +171,9 @@ end)
module MakeInspection (T : TableFormat.INSPECTION_TABLES) = struct module MakeInspection (T : TableFormat.INSPECTION_TABLES) = struct
let symbol =
T.symbol
let production_def prod = let production_def prod =
assert (0 <= prod && prod < Array.length T.production_defs); assert (0 <= prod && prod < Array.length T.production_defs);
match T.production_defs.(prod) with match T.production_defs.(prod) with
......
...@@ -24,6 +24,8 @@ module Make (T : TableFormat.TABLES) ...@@ -24,6 +24,8 @@ module Make (T : TableFormat.TABLES)
module MakeInspection (T : TableFormat.INSPECTION_TABLES) module MakeInspection (T : TableFormat.INSPECTION_TABLES)
: IncrementalEngine.INSPECTION : 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 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