/tryocaml/js_of_ocaml-patched/lib/js.ml
OCaml | 353 lines | 282 code | 44 blank | 27 comment | 26 complexity | 384ec191b1f7262ca6c39d221c4e76c5 MD5 | raw file
Possible License(s): GPL-2.0
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" [||])))