Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

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