Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 274 lines (210 sloc) 7.61 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 (* CF mli *)
19
20 (* wait for refactoring *)
21 module TypeVar = QmlTypeVars
22
23 (* dependencies *)
24 module String = Base.String
25 module Format = Base.Format
26
27 (* shorthand *)
28 module B = BslTypes
29 module Q = QmlAst
30
31 (* type alias for clarty *)
32 type 'a pprinter = 'a Format.pprinter
33
34 (* === *)
35
36 (* Error within a context of type [t] *)
37 let (!!) t fmt =
38 BslTypes.pp_citation OManager.oformatter.contents t ;
39 OManager.printf "The type is : %a@\n" B.pp t ;
40 OManager.error fmt
41
42 type ('env, 'a, 'ast) generator = 'env -> 'a -> 'env * 'ast
43
44 module Opa =
45 struct
46 let pp_scope ~scope fmt =
47 let rec aux parfun fmt t =
48 match t with
49 | B.Const _
50 | B.TypeVar _
51 | B.Void _
52 | B.Bool _ ->
53 BslTypes.pp_scope ~scope fmt t
54
55 | B.Option (_, t) ->
56 Format.fprintf fmt "option(%a)" (aux false) t
57
58 | B.OpaValue (_, t) ->
59 aux parfun fmt t
60
61 | B.Fun (_, args, ret) ->
62 if parfun then Format.fprintf fmt "(%a)" (aux false) t else
63 let paren_out = true in
64 Format.fprintf fmt "%a -> %a" (Format.pp_list ",@ " (aux true)) args (aux paren_out) ret
65
66 (* all external and record types from bsl should be named *)
67
68 | B.External (_, n, vs) ->
69 LangPrint.pp_parameters (aux true) n fmt vs
70
71 in aux false fmt
72
73 let pp fmt =
74 let scope = BslTypes.TypeVarPrint.new_scope () in
75 pp_scope ~scope fmt
76
77 let pp_definition fmt ty =
78 let scope = BslTypes.TypeVarPrint.new_scope () in
79 match ty with
80 | B.External (_, name, params) ->
81 Format.fprintf fmt "type %a = external" (LangPrint.pp_parameters (pp_scope ~scope) name) params
82
83 | t -> !! t "Unexpected type for an external type definition@\n"
84
85 end
86
87 (*
88 Note for hackers:
89 For coherence of line errors, the type must fit on one line
90 *)
91 module Ocaml =
92 struct
93
94 let nopos = FilePos.nopos "BslTypesGeneration.Ocaml"
95
96 (* with zero arity fun, in ocaml we need to add a unit argument *)
97 let unit_fun args =
98 match args with
99 | [] ->
100 [B.Void nopos]
101 | _ ->
102 args
103
104 let ty_void = "unit"
105 let ty_bool = "bool"
106 let ty_option = "option"
107
108 (* Support for utilizing values via the server lib *)
109 let serverlib = "ServerLib"
110 let serverlib fmt s = Format.fprintf fmt "%s.%s" serverlib s
111
112 (* QmlAst.const_ty *)
113 let opa_char = "ty_char"
114 let opa_float = "ty_float"
115 let opa_int = "ty_int"
116 let opa_null = "ty_null"
117 let opa_string = "ty_string"
118
119 (* Rest of bsl types *)
120 let opa_void = "ty_void"
121 let opa_bool = "ty_bool"
122 let opa_option = "ty_option"
123
124 (*
125 This is more likely a transformation, which can be done in AST(TODO).
126
127 This defines the semantic of register type, since it is used to generated
128 the mli of the bsl.
129
130 BslTypesMap is structural, it is exact, and not hacky.
131 *)
132
133 let pp fmt =
134 let scope = BslTypes.TypeVarPrint.new_scope () in
135 let typevar fmt = BslTypes.TypeVarPrint.pp scope fmt in
136 (* fresh type variable (string) for any same abstract type *)
137 (*
138 let map = ref BslTypesMap.empty in
139 let index = ref (-1) in
140 let memo fmt t =
141 let v =
142 match BslTypesMap.find_opt t !map with
143 | Some v -> v
144 | None ->
145 incr(index);
146 let v = Printf.sprintf "'opa_v%d" !index in
147 map := BslTypesMap.add t v !map ;
148 v
149 in
150 Format.pp_print_string fmt v
151 in
152 *)
153 let rec opavalue parfun fmt t =
154 match t with
155 | B.Const (_, c) -> (
156 match c with
157 | Q.TyFloat -> serverlib fmt opa_float
158 | Q.TyInt -> serverlib fmt opa_int
159 | Q.TyNull -> serverlib fmt opa_null
160 | Q.TyString -> serverlib fmt opa_string
161 )
162
163 | B.TypeVar (_, v) -> typevar fmt v
164
165 | B.Void _ -> serverlib fmt opa_void
166 | B.Bool _ ->
167 serverlib fmt opa_bool
168
169 | B.Option (_, t) ->
170 Format.fprintf fmt "%a %a" (opavalue true) t serverlib opa_option
171
172 | B.OpaValue _ ->
173 !! t "Imbrications of opa[] constructors does not make any sense@\n"
174
175 | B.Fun (_, args, ret) ->
176 if parfun then Format.fprintf fmt "(%a)" (opavalue false) t else
177 let paren_out = true in
178 let args = unit_fun args in
179 Format.fprintf fmt "%a -> %a" (Format.pp_list " -> " (opavalue true)) args (opavalue paren_out) ret
180
181 (* External and Record types should be column only *)
182 | B.External (_, n, vs) -> (
183 OcamlPrint.pp_parameters (opavalue true) n fmt vs
184 )
185
186 in
187 let rec aux parfun fmt t =
188 match t with
189 | B.Const (_, c) ->
190 Format.pp_print_string fmt (QmlAst.Const.ocamlbsl_string_of_ty c)
191
192 | B.TypeVar (_, v) -> typevar fmt v
193
194 | B.Void _ ->
195 Format.pp_print_string fmt ty_void
196
197 | B.Bool _ ->
198 Format.pp_print_string fmt ty_bool
199
200 | B.Option (_, t) ->
201 Format.fprintf fmt "%a %s" (aux true) t ty_option
202
203 | B.OpaValue (_, t) -> opavalue true fmt t
204
205 | B.Fun (_, args, ret) ->
206 if parfun then Format.fprintf fmt "(%a)" (aux false) t else
207 let paren_out = true in
208 let args = unit_fun args in
209 Format.fprintf fmt "%a -> %a" (Format.pp_list " -> " (aux true)) args (aux paren_out) ret
210
211 (* all external and record types from bsl should be named *)
212 | B.External (_, n, vs) ->
213 OcamlPrint.pp_parameters (aux true) n fmt vs
214
215 in aux false fmt
216
217 let pp_definition fmt = function
218 | B.External (_, name, params) ->
219 Format.fprintf fmt "type %a" (OcamlPrint.pp_parameters pp name) params
220
221 | t -> !! t "Unexpected type for an external type definition@\n"
222
223 end
224
225 module C =
226 struct
227 (* Prototype use only - Not maintained, not supported *)
228
229 (* <!> Hard link with Pervasives of C *)
230 let ty_alphaval = "ty_alphaval"
231 let ty_void = "ty_void"
232 let ty_bool = "ty_bool"
233 let ty_opavalue = "ty_opavalue"
234
235 let pp fmt =
236 let rec aux fmt = function
237 | B.Const (_, c) ->
238 Format.pp_print_string fmt (QmlAst.Const.cbsl_string_of_ty c)
239
240 | B.TypeVar _ ->
241 Format.pp_print_string fmt ty_alphaval
242
243 | B.Void _ ->
244 Format.pp_print_string fmt ty_void
245
246 | B.Bool _ ->
247 Format.pp_print_string fmt ty_bool
248
249 (* In the prototype, option('a) is a [('a)*] *)
250 | B.Option (_, o) ->
251 Format.fprintf fmt "%a*" aux o
252
253 (* FIXME: we can probably do better *)
254 | B.OpaValue _ ->
255 Format.pp_print_string fmt ty_opavalue
256
257 | B.Fun (_, args, ret) -> (
258 match args with
259 | [] ->
260 Format.fprintf fmt "%a(%s)" aux ret ty_void
261 | _ ->
262 Format.fprintf fmt "%a(%a)" aux ret (Format.pp_list ",@ " aux) args
263 )
264 | B.External (_, name, []) ->
265 Format.pp_print_string fmt name
266
267 (* wait for LLVM to decide what we want to do *)
268 | B.External _ -> assert false
269
270 in
271 aux fmt
272
273 end
Something went wrong with that request. Please try again.