/tryocaml/js_of_ocaml-patched/lib/js.ml

  1(* Js_of_ocaml library
  2 * http://www.ocsigen.org/js_of_ocaml/
  3 * Copyright (C) 2010 Jérôme Vouillon
  4 * Laboratoire PPS - CNRS Université Paris Diderot
  5 *
  6 * This program is free software; you can redistribute it and/or modify
  7 * it under the terms of the GNU Lesser General Public License as published by
  8 * the Free Software Foundation, with linking exception;
  9 * either version 2.1 of the License, or (at your option) any later version.
 10 *
 11 * This program is distributed in the hope that it will be useful,
 12 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 13 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 14 * GNU Lesser General Public License for more details.
 15 *
 16 * You should have received a copy of the GNU Lesser General Public License
 17 * along with this program; if not, write to the Free Software
 18 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 19 *)
 20
 21type +'a t
 22
 23module Unsafe = struct
 24  external variable : string -> 'a = "caml_js_var"
 25  external constant : string -> 'a = "caml_js_const"
 26
 27  type any
 28  external inject : 'a -> any = "%identity"
 29  external coerce : _ t -> _ t = "%identity"
 30
 31  external get : 'a -> 'b -> 'c = "caml_js_get"
 32  external set : 'a -> 'b -> 'c -> unit = "caml_js_set"
 33  external call : 'a -> 'b -> any array -> 'c = "caml_js_call"
 34  external fun_call : 'a -> any array -> 'b = "caml_js_fun_call"
 35  external meth_call : 'a -> string -> any array -> 'b = "caml_js_meth_call"
 36  external new_obj : 'a -> any array -> 'b = "caml_js_new"
 37
 38  external equals : 'a -> 'b -> bool = "caml_js_equals"
 39
 40  external pure_expr : (unit -> 'a) -> 'a = "caml_js_pure_expr"
 41
 42  external eval_string : string -> 'a = "caml_js_eval_string"
 43end
 44
 45(****)
 46
 47type 'a opt = 'a
 48type 'a optdef = 'a
 49
 50let null : 'a opt = Unsafe.constant "null"
 51external some : 'a -> 'a opt = "%identity"
 52
 53let undefined : 'a optdef = Unsafe.constant "undefined"
 54external def : 'a -> 'a optdef = "%identity"
 55
 56module type OPT = sig
 57  type 'a t
 58  val empty : 'a t
 59  val return : 'a -> 'a t
 60  val map : 'a t -> ('a -> 'b) -> 'b t
 61  val bind : 'a t -> ('a -> 'b t) -> 'b t
 62  val test : 'a t -> bool
 63  val iter : 'a t -> ('a -> unit) -> unit
 64  val case : 'a t -> (unit -> 'b) -> ('a -> 'b) -> 'b
 65  val get : 'a t -> (unit -> 'a) -> 'a
 66  val option : 'a option -> 'a t
 67  val to_option : 'a t -> 'a option
 68end
 69
 70module Opt : OPT with type 'a t = 'a opt = struct
 71  type 'a t = 'a opt
 72  let empty = null
 73  let return = some
 74  let map x f = if Unsafe.equals x null then null else some (f x)
 75  let bind x f = if Unsafe.equals x null then null else f x
 76  let test x = not (Unsafe.equals x null)
 77  let iter x f = if not (Unsafe.equals x null) then f x
 78  let case x f g = if Unsafe.equals x null then f () else g x
 79  let get x f = if Unsafe.equals x null then f () else x
 80  let option x = match x with None -> empty | Some x -> return x
 81  let to_option x = case x (fun () -> None) (fun x -> Some x)
 82end
 83
 84module Optdef : OPT with type 'a t = 'a optdef = struct
 85  type 'a t = 'a opt
 86  let empty = undefined
 87  let return = def
 88  let map x f = if x == undefined then undefined else some (f x)
 89  let bind x f = if x == undefined then undefined else f x
 90  let test x = x != undefined
 91  let iter x f = if x != undefined then f x
 92  let case x f g = if x == undefined then f () else g x
 93  let get x f = if x == undefined then f () else x
 94  let option x = match x with None -> empty | Some x -> return x
 95  let to_option x = case x (fun () -> None) (fun x -> Some x)
 96end
 97
 98(****)
 99
100let coerce x f g = Opt.get (f x) (fun () -> g x)
101let coerce_opt x f g = Opt.get (Opt.bind x f) (fun () -> g x)
102
103(****)
104
105type +'a meth
106type +'a gen_prop
107type 'a readonly_prop = <get : 'a> gen_prop
108type 'a writeonly_prop = <set : 'a -> unit> gen_prop
109type 'a prop = <get : 'a; set : 'a -> unit> gen_prop
110type 'a optdef_prop = <get : 'a optdef; set : 'a -> unit> gen_prop
111type float_prop = <get : float t; set : float -> unit> gen_prop
112
113type +'a constr
114
115(****)
116
117type (-'a, +'b) meth_callback
118type 'a callback = (unit, 'a) meth_callback
119
120external wrap_callback : ('a -> 'b) -> ('c, 'a -> 'b) meth_callback = "caml_js_wrap_callback"
121external wrap_meth_callback : ('a -> 'b -> 'c) -> ('a, 'b -> 'c) meth_callback = "caml_js_wrap_meth_callback"
122
123(****)
124
125let _true = Unsafe.constant "true"
126let _false = Unsafe.constant "false"
127
128type match_result_handle
129type string_array
130
131class type js_string = object
132  method toString : js_string t meth
133  method valueOf : js_string t meth
134  method charAt : int -> js_string t meth
135  method charCodeAt : int -> float t meth (* This may return NaN... *)
136  method concat : js_string t -> js_string t meth
137  method concat_2 : js_string t -> js_string t -> js_string t meth
138  method concat_3 :
139    js_string t -> js_string t -> js_string t -> js_string t meth
140  method concat_4 :
141    js_string t -> js_string t -> js_string t -> js_string t ->
142    js_string t meth
143  method indexOf : js_string t -> int meth
144  method indexOf_from : js_string t -> int -> int meth
145  method lastIndexOf : js_string t -> int meth
146  method lastIndexOf_from : js_string t -> int -> int meth
147  method localeCompare : js_string t -> float t meth
148  method _match : regExp t -> match_result_handle t opt meth
149  method replace : regExp t -> js_string t -> js_string t meth
150  method replace_string : js_string t -> js_string t -> js_string t meth
151  method search : regExp t -> int meth
152  method slice : int -> int -> js_string t meth
153  method slice_end : int -> js_string t meth
154  method split : js_string t -> string_array t meth
155  method split_limited : js_string t -> int -> string_array t meth
156  method split_regExp : regExp t -> string_array t meth
157  method split_regExpLimited : regExp t -> int -> string_array t meth
158  method substring : int -> int -> js_string t meth
159  method substring_toEnd : int -> js_string t meth
160  method toLowerCase : js_string t meth
161  method toLocaleLowerCase : js_string t meth
162  method toUpperCase : js_string t meth
163  method toLocaleUpperCase : js_string t meth
164  method length : int readonly_prop
165end
166
167and regExp = object
168  method exec : js_string t -> match_result_handle t opt meth
169  method test : js_string t -> bool t meth
170  method toString : js_string t meth
171  method source : js_string t readonly_prop
172  method global : bool t readonly_prop
173  method ignoreCase : bool t readonly_prop
174  method multiline : bool t readonly_prop
175  method lastIndex : int prop
176end
177
178let regExp = Unsafe.variable "RegExp"
179let regExp_copy = regExp
180let regExp_withFlags = regExp
181
182class type ['a] js_array = object
183  method toString : js_string t meth
184  method toLocaleString : js_string t meth
185  method concat : 'a js_array t -> 'a js_array t meth
186  method join : js_string t -> js_string t meth
187  method pop : 'a optdef meth
188  method push : 'a -> int meth
189  method push_2 : 'a -> 'a -> int meth
190  method push_3 : 'a -> 'a -> 'a -> int meth
191  method push_4 : 'a -> 'a -> 'a -> 'a -> int meth
192  method reverse : 'a js_array t meth
193  method shift : 'a optdef meth
194  method slice : int -> int -> 'a js_array t meth
195  method slice_end : int -> 'a js_array t meth
196  method sort : ('a -> 'a -> float) callback -> 'a js_array t meth
197  method sort_asStrings : 'a js_array t meth
198  method splice : int -> int -> 'a js_array t meth
199  method splice_1 : int -> int -> 'a -> 'a js_array t meth
200  method splice_2 : int -> int -> 'a -> 'a -> 'a js_array t meth
201  method splice_3 : int -> int -> 'a -> 'a -> 'a -> 'a js_array t meth
202  method splice_4 : int -> int -> 'a -> 'a -> 'a -> 'a -> 'a js_array t meth
203  method unshift : 'a -> int meth
204  method unshift_2 : 'a -> 'a -> int meth
205  method unshift_3 : 'a -> 'a -> 'a -> int meth
206  method unshift_4 : 'a -> 'a -> 'a -> 'a -> int meth
207  method length : int prop
208end
209
210let array_constructor = Unsafe.variable "Array"
211let array_empty = array_constructor
212let array_length = array_constructor
213
214let array_get : 'a #js_array t -> int -> 'a optdef = Unsafe.get
215let array_set : 'a #js_array t -> int -> 'a -> unit = Unsafe.set
216
217class type match_result = object
218  inherit [js_string t] js_array
219  method index : int readonly_prop
220  method input : js_string t readonly_prop
221end
222
223let str_array : string_array t -> js_string t js_array t = Unsafe.coerce
224let match_result : match_result_handle t -> match_result t =
225  Unsafe.coerce
226
227class type number = object
228  method toString : js_string t meth
229  method toString_radix : int -> js_string t meth
230  method toLocaleString : js_string t meth
231  method toFixed : int -> js_string t meth
232  method toExponential : js_string t meth
233  method toExponential_digits : int -> js_string t meth
234  method toPrecision : int -> js_string meth t
235end
236
237external number_of_float : float -> number t = "caml_js_from_float"
238external float_of_number : number t -> float = "caml_js_to_float"
239
240class type date = object
241  method toString : js_string t meth
242  method toDateString : js_string t meth
243  method toTimeString : js_string t meth
244  method toLocaleString : js_string t meth
245  method toLocaleDateString : js_string t meth
246  method toLocaleTimeString : js_string t meth
247  method valueOf : float t meth
248  method getTime : float t meth
249  method getFullYear : int meth
250  method getUTCFullYear : int meth
251  method getMonth : int meth
252  method getUTCMonth : int meth
253  method getDate : int meth
254  method getUTCDate : int meth
255  method getDay : int meth
256  method getUTCDay : int meth
257  method getHours : int meth
258  method getUTCHours : int meth
259  method getMinutes : int meth
260  method getUTCMinutes : int meth
261  method getSeconds : int meth
262  method getUTCSeconds : int meth
263  method getMilliseconds : int meth
264  method getUTCMilliseconds : int meth
265  method getTimezoneOffset : int meth
266  method setTime : float -> float t meth
267  method setFullYear : int -> float t meth
268  method setUTCFullYear : int -> float t meth
269  method setMonth : int -> float t meth
270  method setUTCMonth : int -> float t meth
271  method setDate : int -> float t meth
272  method setUTCDate : int -> float t meth
273  method setDay : int -> float t meth
274  method setUTCDay : int -> float t meth
275  method setHours : int -> float t meth
276  method setUTCHours : int -> float t meth
277  method setMinutes : int -> float t meth
278  method setUTCMinutes : int -> float t meth
279  method setSeconds : int -> float t meth
280  method setUTCSeconds : int -> float t meth
281  method setMilliseconds : int -> float t meth
282  method setUTCMilliseconds : int -> float t meth
283  method toUTCString : js_string t meth
284  method toISOString : js_string t meth
285  method toJSON : 'a -> js_string t meth
286end
287
288class type date_constr = object
289  method parse : js_string t -> float t meth
290  method _UTC_month : int -> int -> float t meth
291  method _UTC_day : int -> int -> float t meth
292  method _UTC_hour : int -> int -> int -> int -> float t meth
293  method _UTC_min : int -> int -> int -> int -> int -> float t meth
294  method _UTC_sec : int -> int -> int -> int -> int -> int -> float t meth
295  method _UTC_ms :
296    int -> int -> int -> int -> int -> int -> int -> float t meth
297(*
298  method now : float t meth
299*)
300end
301
302let date_constr = Unsafe.variable "Date"
303let date : date_constr t = date_constr
304let date_now : date t constr = date_constr
305let date_fromTimeValue : (float -> date t) constr = date_constr
306let date_month : (int -> int -> date t) constr = date_constr
307let date_day : (int -> int -> int -> date t) constr = date_constr
308let date_hour : (int -> int -> int -> int -> date t) constr = date_constr
309let date_min : (int -> int -> int -> int -> int -> date t) constr = date_constr
310let date_sec : (int -> int -> int -> int -> int -> int -> date t) constr =
311  date_constr
312let date_ms :
313  (int -> int -> int -> int -> int -> int -> int -> date t) constr =
314  date_constr
315
316class type math = object
317  method random : float t meth
318end
319
320let math = Unsafe.variable "Math"
321
322let decodeURI (s : js_string t) : js_string t =
323  Unsafe.fun_call (Unsafe.variable "decodeURI") [|Unsafe.inject s|]
324let decodeURIComponent (s : js_string t) : js_string t =
325  Unsafe.fun_call (Unsafe.variable "decodeURIComponent") [|Unsafe.inject s|]
326let encodeURI (s : js_string t) : js_string t =
327  Unsafe.fun_call (Unsafe.variable "encodeURI") [|Unsafe.inject s|]
328let encodeURIComponent (s : js_string t) : js_string t =
329  Unsafe.fun_call (Unsafe.variable "encodeURIComponent") [|Unsafe.inject s|]
330let escape (s : js_string t) : js_string t =
331  Unsafe.fun_call (Unsafe.variable "escape") [|Unsafe.inject s|]
332let unescape (s : js_string t) : js_string t =
333  Unsafe.fun_call (Unsafe.variable "unescape") [|Unsafe.inject s|]
334
335external bool : bool -> bool t = "caml_js_from_bool"
336external to_bool : bool t -> bool = "caml_js_to_bool"
337external string : string -> js_string t = "caml_js_from_string"
338external to_string : js_string t -> string = "caml_js_to_string"
339external float : float -> float t = "caml_js_from_float"
340external to_float : float t -> float = "caml_js_to_float"
341external array : 'a array -> 'a js_array t = "caml_js_from_array"
342external to_array : 'a js_array t -> 'a array = "caml_js_to_array"
343external bytestring : string -> js_string t = "caml_js_from_byte_string"
344external to_bytestring : js_string t -> string = "caml_js_to_byte_string"
345
346external typeof : < .. > t -> js_string t = "caml_js_typeof"
347external instanceof : 'a -> 'b -> bool = "caml_js_instanceof"
348
349let _ =
350  Printexc.register_printer
351    (fun e ->
352       if instanceof e array_constructor then None
353       else Some (to_string (Unsafe.meth_call (Obj.magic e) "toString" [||])))