From facc2e90bf3934ac213bf1683c4dc0097955f592 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fran=C3=A7ois=20Pottier?= Date: Fri, 2 Jan 2015 21:35:26 +0100 Subject: [PATCH] Cleanup in the generation of the .ml and .mli files. Things are reasonably clean now. --- src/IL.mli | 2 +- src/IncrementalEngine.ml | 8 +++++++- src/codeBits.ml | 4 ++-- src/codeBits.mli | 2 +- src/interface.ml | 44 ++++++++++++++++++++++++++++++---------- src/interface.mli | 6 ++++++ src/printer.ml | 10 ++++----- src/symbolType.mli | 1 + src/tableBackend.ml | 20 ++++++------------ src/tableFormat.ml | 6 ++++++ src/tableInterpreter.ml | 3 +++ src/tableInterpreter.mli | 4 +++- 12 files changed, 74 insertions(+), 36 deletions(-) diff --git a/src/IL.mli b/src/IL.mli index 71814764..ba9cfcbd 100644 --- a/src/IL.mli +++ b/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 = diff --git a/src/IncrementalEngine.ml b/src/IncrementalEngine.ml index a67886a9..bfcd5e74 100644 --- a/src/IncrementalEngine.ml +++ b/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 diff --git a/src/codeBits.ml b/src/codeBits.ml index 57bdb57f..9fe2b469 100644 --- a/src/codeBits.ml +++ b/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 diff --git a/src/codeBits.mli b/src/codeBits.mli index 4de9e715..4af85af1 100644 --- a/src/codeBits.mli +++ b/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 diff --git a/src/interface.ml b/src/interface.ml index ab7c92a1..b059c0db 100644 --- a/src/interface.ml +++ b/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; ] ) :: diff --git a/src/interface.mli b/src/interface.mli index f437d507..cb71ce45 100644 --- a/src/interface.mli +++ b/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 diff --git a/src/printer.ml b/src/printer.ml index 699e6bcf..0001cfff 100644 --- a/src/printer.ml +++ b/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 diff --git a/src/symbolType.mli b/src/symbolType.mli index 8d711d52..d019db8c 100644 --- a/src/symbolType.mli +++ b/src/symbolType.mli @@ -1,5 +1,6 @@ (* 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. *) diff --git a/src/tableBackend.ml b/src/tableBackend.ml index 3351f358..066ff901 100644 --- a/src/tableBackend.ml +++ b/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() ]) ])) :: diff --git a/src/tableFormat.ml b/src/tableFormat.ml index ec5b8b6b..7c69ec2f 100644 --- a/src/tableFormat.ml +++ b/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. *) diff --git a/src/tableInterpreter.ml b/src/tableInterpreter.ml index 1a48fe9f..b26509b0 100644 --- a/src/tableInterpreter.ml +++ b/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 diff --git a/src/tableInterpreter.mli b/src/tableInterpreter.mli index a665ce25..2eeb7ae0 100644 --- a/src/tableInterpreter.mli +++ b/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 -- GitLab