interface.ml 5.9 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13
(******************************************************************************)
(*                                                                            *)
(*                                   Menhir                                   *)
(*                                                                            *)
(*                       François Pottier, Inria Paris                        *)
(*              Yann Régis-Gianas, PPS, Université Paris Diderot              *)
(*                                                                            *)
(*  Copyright Inria. All rights reserved. This file is distributed under the  *)
(*  terms of the GNU General Public License version 2, as described in the    *)
(*  file LICENSE.                                                             *)
(*                                                                            *)
(******************************************************************************)

14
open BasicSyntax
15 16 17
open IL
open CodeBits

18 19 20
(* -------------------------------------------------------------------------- *)

(* The [Error] exception. *)
21 22 23 24 25 26

let excname =
  "Error"

let excdef = {
  excname = excname;
27
  exceq = (if Settings.fixedexc then Some "Parsing.Parse_error" else None);
28 29
}

30 31
(* -------------------------------------------------------------------------- *)

32
(* The type of the monolithic entry point for the start symbol [symbol]. *)
33

34
let entrytypescheme grammar symbol =
35
  let typ = TypTextual (ocamltype_of_start_symbol grammar symbol) in
36
  type2scheme (marrow [ arrow tlexbuf TokenType.ttoken; tlexbuf ] typ)
37

38 39
(* -------------------------------------------------------------------------- *)

40 41 42 43 44 45 46
(* When the table back-end is active, the generated parser contains,
   as a sub-module, an application of [Engine.Make]. This sub-module
   is named as follows. *)

let interpreter =
  "MenhirInterpreter"

47 48
let checkpoint t =
  TypApp (interpreter ^ ".checkpoint", [ t ])
49

50
let lr1state =
51
  "lr1state"
52 53 54 55

let tlr1state a : typ =
  TypApp (lr1state, [a])

56 57
(* -------------------------------------------------------------------------- *)

58
(* The name of the sub-module that contains the incremental entry points. *)
59

60 61
let incremental =
  "Incremental"
62 63 64

(* The type of the incremental entry point for the start symbol [symbol]. *)

65
let entrytypescheme_incremental grammar symbol =
66
  let t = TypTextual (ocamltype_of_start_symbol grammar symbol) in
67
  type2scheme (marrow [ tposition ] (checkpoint t))
68

69
(* -------------------------------------------------------------------------- *)
70

71 72 73 74 75 76 77
(* The name of the sub-module that contains the inspection API. *)

let inspection =
  "Inspection"

(* -------------------------------------------------------------------------- *)

78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98
(* The monolithic (traditional) API: the type [token], the exception [Error],
   and the parser's entry points. *)

let monolithic_api grammar =

  TokenType.tokentypedef grammar @

  IIComment "This exception is raised by the monolithic API functions." ::
  IIExcDecls [ excdef ] ::

  IIComment "The monolithic API." ::
  IIValDecls (
    StringSet.fold (fun symbol decls ->
      (Misc.normalize symbol, entrytypescheme grammar symbol) :: decls
    ) grammar.start_symbols []
  ) ::

  []

(* -------------------------------------------------------------------------- *)

99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119
(* The inspection API. *)

let inspection_api grammar () =

  let a = "a" in

  (* Define the types [terminal] and [nonterminal]. *)

  TokenType.tokengadtdef grammar @
  NonterminalType.nonterminalgadtdef grammar @

  (* Include the signature that lists the inspection functions, with
     appropriate type instantiations. *)

  IIComment "The inspection API." ::
  IIInclude (
    with_types WKDestructive
      "MenhirLib.IncrementalEngine.INSPECTION" [
        [ a ], "lr1state", tlr1state (TypVar a);
        [], "production", TypApp ("production", []);
        [ a ], TokenType.tctokengadt, TokenType.ttokengadt (TypVar a);
120
        [ a ], NonterminalType.tcnonterminalgadt, NonterminalType.tnonterminalgadt (TypVar a);
121
        [ a ], "env", TypApp ("env", [ TypVar a ]);
122 123 124 125 126 127 128
      ]
  ) ::

  []

(* -------------------------------------------------------------------------- *)

129 130
(* The incremental API. *)

POTTIER Francois's avatar
POTTIER Francois committed
131
let incremental_engine () : module_type =
132
  with_types WKNonDestructive
POTTIER Francois's avatar
POTTIER Francois committed
133 134 135 136 137 138
    "MenhirLib.IncrementalEngine.INCREMENTAL_ENGINE"
    [
      [],
      "token", (* NOT [tctoken], which is qualified if [--external-tokens] is used *)
      TokenType.ttoken
    ]
139

POTTIER Francois's avatar
POTTIER Francois committed
140
let incremental_entry_points grammar : interface =
141 142

  IIComment "The entry point(s) to the incremental API." ::
143 144 145 146 147 148 149
  IIModule (incremental, MTSigEnd [
    IIValDecls (
      StringSet.fold (fun symbol decls ->
        (symbol, entrytypescheme_incremental grammar symbol) :: decls
      ) grammar.start_symbols []
    )
  ]) ::
150 151 152

  []

POTTIER Francois's avatar
POTTIER Francois committed
153 154 155 156 157 158 159
let incremental_api grammar () : interface =

  IIModule (
    interpreter,
    MTSigEnd (
      IIComment "The incremental API." ::
      IIInclude (incremental_engine()) ::
160
      listiflazy Settings.inspection (inspection_api grammar)
POTTIER Francois's avatar
POTTIER Francois committed
161 162 163
    )
  ) ::

164
  (* The entry points must come after the incremental API, because
165
     their type refers to the type [checkpoint]. *)
POTTIER Francois's avatar
POTTIER Francois committed
166 167
  incremental_entry_points grammar

168 169 170 171 172 173 174
(* -------------------------------------------------------------------------- *)

(* The complete interface of the generated parser. *)

let interface grammar = [
  IIFunctor (grammar.parameters,
    monolithic_api grammar @
175
    listiflazy Settings.table (incremental_api grammar)
176
  )
177
]
178

179 180
(* -------------------------------------------------------------------------- *)

181 182
(* Writing the interface to a file. *)

183
let write grammar () =
POTTIER Francois's avatar
POTTIER Francois committed
184 185
  (* We have a dependency on [TokenType], which takes care of the case
     where [token_type_mode] is [TokenTypeOnly]. *)
186
  assert (Settings.token_type_mode <> Settings.TokenTypeOnly);
187 188 189 190 191
  let mli = open_out (Settings.base ^ ".mli") in
  let module P = Printer.Make (struct
    let f = mli
    let locate_stretches = None
  end) in
192
  P.interface (interface grammar);
193
  close_out mli