forked from MLstate/opalang
-
Notifications
You must be signed in to change notification settings - Fork 0
/
bslIncludeFormats.ml
195 lines (162 loc) · 6.42 KB
/
bslIncludeFormats.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
(*
Copyright © 2011 MLstate
This file is part of OPA.
OPA is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.
OPA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
more details.
You should have received a copy of the GNU Affero General Public License
along with OPA. If not, see <http://www.gnu.org/licenses/>.
*)
(**
Inclusion format for opa files during the bslregister process.
@author Mathieu Barbin
@author Mehdi Bouaziz
*)
(**
This module has no mli because it would duplicate the type definitions.
This module implements the inclusion format feature for macro
production of bypass and external types definitions in an opa file,
from definitions registred in bypass files.
Example:
{[
##include opa-function bslpervasives
]}
Is expanded as :
{[
`+` = %%bslpervasives.add_int%% : int, int -> int
`-` = %%bslpervasives.sub_int%% : int, int -> int
etc...
]}
*)
(** {6 Types of format} *)
(**
It looks like scary, but don't worry, you don't need to manipulate this
type directly, the types are exported just so that the parser and BslLib
can build them.
For a high level manipulation of inclusion formats, cf module [IFormat]
*)
type fmt_fvalue = string * string * string
type fmt_fprinter = fmt_fvalue -> string
type fmt_sep = string option
type 'a mfmt_elt = [ `Mfmt_name | `Mfmt_const of string | `Mfmt_iter of 'a]
type mfmt_iter = mfmt option * fmt_fprinter * fmt_sep (* None means #rec *)
and mfmt = [ `Mfmt_name | `Mfmt_const of string | `Mfmt_iter of mfmt_iter ] list
type ffmt = fmt_fprinter * fmt_sep
type fmt = Mfmt of mfmt | Ffmt of ffmt | Fmt_const of string
(** {6 High level API} *)
(**
The IFormat has a local table for storing format definitions.
It works together with the [BslRegisterParser], via the
[BslRegisterParserState] interface.
*)
module IFormat :
sig
(** {6 Error report} *)
(**
IFormat is a generic lib, so the errors does not uses OManager.
*)
type error
exception Exception of error
val pp_error : error LangPrint.pprinter
val pp_show_format : Format.formatter -> unit -> unit
val add : string -> fmt -> unit
val find_opt : string -> fmt option
val reset : unit -> unit
val empty : fmt
val fmt_fprinter_empty : fmt_fprinter
val fmt_sep_empty : fmt_sep
val mfmt_empty : mfmt
val mfmt_of_fmt : fmt -> mfmt
val fprinter_opt_of_fmt : fmt -> fmt_fprinter option
val concat : fmt -> fmt -> fmt
val opt_list_to_iter : fmt option list -> mfmt_iter
end =
struct
type error =
| FormatTypeClash of string * string
| MoreThanOne of string
exception Exception of error
let format_type_clash t1 t2 = raise (Exception (FormatTypeClash (t1, t2)))
let more_than_one s = raise (Exception (MoreThanOne s))
let pp_error fmt = function
| FormatTypeClash (t1, t2) ->
Format.fprintf fmt "Format type clash, cannot concat a format(%s)@ and a format(%s)@\n" t1 t2
| MoreThanOne kind ->
Format.fprintf fmt "More than one @{<bright>format(%s)@} in this iteration block" kind
let tbl = Hashtbl.create 1
let pp_show_format fmt () =
Hashtbl.iter (fun name _ -> Format.fprintf fmt "+ %s@\n" name) tbl
let add name fmt =
(* #<< debug dddformat (sprintf "Adding format <%s> in my env" name); >>#; *)
Hashtbl.add tbl name fmt
let find_opt name = try Some(Hashtbl.find tbl name) with Not_found -> None
let reset () =
(* #<< debug dddformat "Reseting my format-env"; >>#; *)
Hashtbl.clear tbl
let empty = Fmt_const ""
let fmt_fprinter_empty = ((fun _ -> "") : fmt_fprinter)
let fmt_sep_empty = (None : fmt_sep)
let mfmt_empty = ([] : mfmt)
let mfmt_of_fmt = function
| Mfmt mfmt -> mfmt
| Ffmt (fprinter, sep) -> [`Mfmt_iter(Some mfmt_empty, fprinter, sep)]
| Fmt_const str -> [`Mfmt_const str]
let fprinter_opt_of_fmt = function
| Mfmt _ -> None
| Ffmt (fprinter, _) -> Some fprinter
| Fmt_const str -> Some (fun _ -> str)
let concat =
fun fmt1 fmt2 -> match fmt1, fmt2 with
| Mfmt mfmt1, Mfmt mfmt2 -> Mfmt (mfmt1 @ mfmt2)
| Mfmt mfmt, Fmt_const str -> Mfmt (mfmt @ [`Mfmt_const str])
| Mfmt _, Ffmt _ -> format_type_clash "module" "function"
| Ffmt _, Mfmt _ -> format_type_clash "function" "module"
| Ffmt (fprinter1, sep1), Ffmt (fprinter2, sep2) ->
let fprinter = fun v -> (fprinter1 v) ^ (fprinter2 v) in
let sep = match sep1, sep2 with
| None, None -> None
| Some s, None
| None, Some s -> Some s
| Some _, Some _ ->
(* Mathieu Mon Aug 16 21:09:37 CEST 2010
After the refactoring of libbsl, I have no idea in what case this can happen.
TODO:(who find a example causing this assert false)
add a corresponding error message
*)
assert false
in
Ffmt (fprinter, sep)
| Ffmt (fprinter, sep), Fmt_const str ->
let fprinter = fun v -> (fprinter v) ^ str in
Ffmt (fprinter, sep)
| Fmt_const str, Mfmt mfmt -> Mfmt ((`Mfmt_const str)::mfmt)
| Fmt_const str, Ffmt (fprinter, sep) ->
let fprinter = fun v -> str ^ (fprinter v) in
Ffmt (fprinter, sep)
| Fmt_const str1, Fmt_const str2 -> Fmt_const (str1 ^ str2)
let opt_list_to_iter fmt_opt_list =
let mfmt_opt_list, fmt_opt_list =
List.partition
(fun fmt_opt -> match fmt_opt with Some Mfmt _ -> true | None -> true | _ -> false) fmt_opt_list in
let mfmt_opt = match mfmt_opt_list with
| [] -> Some mfmt_empty
| [None] -> None
| [Some Mfmt mfmt] -> Some mfmt
| _ -> more_than_one "module"
in
let ffmt_list, const_list =
List.partition (fun fmt_opt -> match fmt_opt with Some Ffmt _ -> true | _ -> false) fmt_opt_list in
let fprinter, sep = match ffmt_list, const_list with
| [], [] -> fmt_fprinter_empty, fmt_sep_empty
| [], [Some Fmt_const sep] -> fmt_fprinter_empty, Some sep
| [Some Ffmt ffmt], [] -> ffmt
| [Some Ffmt (fprinter, _)], [Some Fmt_const sep] -> fprinter, Some sep
| _::_::_, _ -> more_than_one "function"
| _, _ -> more_than_one "separator"
in
(mfmt_opt, fprinter, sep)
end