interface.ml 4.52 KB
Newer Older
1
2
3
4
open UnparameterizedSyntax
open IL
open CodeBits

5
6
7
(* -------------------------------------------------------------------------- *)

(* The [Error] exception. *)
8
9
10
11
12
13

let excname =
  "Error"

let excdef = {
  excname = excname;
14
  exceq = (if Settings.fixedexc then Some "Parsing.Parse_error" else None);
15
16
}

17
18
(* -------------------------------------------------------------------------- *)

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

21
let entrytypescheme grammar symbol =
22
  let typ = TypTextual (ocamltype_of_start_symbol grammar symbol) in
23
  type2scheme (marrow [ arrow tlexbuf TokenType.ttoken; tlexbuf ] typ)
24

25
26
(* -------------------------------------------------------------------------- *)

27
28
29
30
31
32
33
34
35
36
(* 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"

let result t =
  TypApp (interpreter ^ ".result", [ t ])

37
38
(* -------------------------------------------------------------------------- *)

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

41
42
let incremental =
  "Incremental"
43
44
45

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

46
let entrytypescheme_incremental grammar symbol =
47
  let t = TypTextual (ocamltype_of_start_symbol grammar symbol) in
48
49
  type2scheme (marrow [ tunit ] (result t))

50
(* -------------------------------------------------------------------------- *)
51

52
53
54
55
56
57
58
(* The name of the sub-module that contains the inspection API. *)

let inspection =
  "Inspection"

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

59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
(* 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 []
  ) ::

  []

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

(* The incremental API. *)

let incremental_api grammar () =
83

84
85
86
  IIComment "The incremental API." ::
  IIModule (
    interpreter,
87
88
89
90
91
92
    with_types WKDestructive
      "MenhirLib.IncrementalEngine.INCREMENTAL_ENGINE"
      [
        "token", (* NOT [tctoken], which is qualified if [--external-tokens] is used *)
        TokenType.ttoken
      ]
93
94
95
  ) ::

  IIComment "The entry point(s) to the incremental API." ::
96
97
98
99
100
101
102
  IIModule (incremental, MTSigEnd [
    IIValDecls (
      StringSet.fold (fun symbol decls ->
        (symbol, entrytypescheme_incremental grammar symbol) :: decls
      ) grammar.start_symbols []
    )
  ]) ::
103
104
105
106
107
108
109
110
111

  []

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

(* The inspection API. *)

let inspection_api grammar () =

112
113
114
115
116
117
  IIComment "The inspection API." ::
  IIModule (inspection, MTSigEnd (

    TokenType.tokengadtdef grammar @
    NonterminalType.nonterminalgadtdef grammar @
    SymbolType.symbolgadtdef() @
118
    SymbolType.xsymboldef() @
119
120
121
122
123
124
125
126
127
128

    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
    ] ::
129

130
131
132
    IIInclude (
      with_types WKDestructive
        "MenhirLib.IncrementalEngine.INSPECTION" [
133
134
          SymbolType.tcxsymbol, SymbolType.txsymbol;
          "production", TypApp ("MenhirInterpreter.production", [])
135
136
137
        ]
    ) ::

138
    []
139

140
  )) ::
141
142
143
144
145
146
147
148
149
150
151
  []

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

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

let interface grammar = [
  IIFunctor (grammar.parameters,
    monolithic_api grammar @
    listiflazy Settings.table (incremental_api grammar) @
    listiflazy Settings.inspection (inspection_api grammar)
152
  )
153
]
154

155
156
(* -------------------------------------------------------------------------- *)

157
158
(* Writing the interface to a file. *)

159
let write grammar () =
160
  assert (Settings.token_type_mode <> Settings.TokenTypeOnly);
161
162
163
164
165
166
  let mli = open_out (Settings.base ^ ".mli") in
  let module P = Printer.Make (struct
    let f = mli
    let locate_stretches = None
    let raw_stretch_action = false
  end) in
167
  P.interface (interface grammar);
168
169
  close_out mli