Commits

camlspotter  committed 60013e6

update

  • Participants
  • Parent commits 9e3d16f

Comments (0)

Files changed (9)

File lib/OMakefile

     lwt
     js_of_ocaml
 
+OCAMLDEPFLAGS= -syntax camlp4o -package lwt,js_of_ocaml.syntax
+OCAMLPPFLAGS= -syntax camlp4o -package lwt,js_of_ocaml.syntax
+
 FILES[] =
     std
     base
+
+    monad
+    xlist
+    option
+
+    URL
     xUnsafe
     http
+    gVisualization
+    gMaps
     google
 
 MyOCamlPackage(xJs, $(FILES), $(EMPTY), $(EMPTY))
+open Base
+
+let encode s =
+  let len = String.length s in
+  let b = Buffer.create & len * 2 in
+  for i = 0 to len - 1 do
+    match String.unsafe_get s i with
+    | 'a'..'z' | 'A'..'Z' | '0'..'9' | '-' | '.' | '_' | '~' as c -> Buffer.add_char b c
+    | c -> Buffer.add_string b & Printf.sprintf "%%%02x" (Char.code c)
+  done;
+  Buffer.contents b
+
+let make_query kvs =
+  String.concat "&" 
+  & List.map (fun (k,v) ->
+      let b = Buffer.create 100 in
+      Buffer.add_string b & encode k; 
+      Buffer.add_char b '=';
+      Buffer.add_string b & encode v;
+      Buffer.contents b) kvs
+
 
 let alert s = ignore (U.fun_call (U.variable "alert") [| U.inject (string s) |])
 let alertf fmt  = Printf.ksprintf alert fmt
+
+external (&) : ('a -> 'b) -> 'a -> 'b = "%apply"
+external (|>) : 'a -> ('a -> 'b) -> 'b =  "%revapply"
+let ( *< ) f g x = f (g x)
+let ( *> ) f g x = g (f x)
+
+let load_script url =
+  let document = Dom_html.window##document in
+  let script = document##createElement (!$ "script") in
+  script##setAttribute (!$ "type", !$ "text/javascript");
+  script##setAttribute (!$ "src", !$ url);
+  Dom.appendChild document##body script
+
+let set_onload f = 
+  Dom_html.window##onload <- Dom.handler (fun _ -> f (); _false)

File lib/base.mli

 
 val alertf : ('a, unit, string, unit) format4 -> 'a
 (** JS alert function, printf style *)
+
+external (&) : ('a -> 'b) -> 'a -> 'b = "%apply"
+external (|>) : 'a -> ('a -> 'b) -> 'b =  "%revapply"
+val ( *> ) : ('c -> 'a) -> ('a -> 'b) -> 'c -> 'b
+val ( *< ) : ('a -> 'b) -> ('c -> 'a) -> 'c -> 'b
+
+val load_script : string -> unit
+(** Append <script type="text/javascript" src="URL"/>
+    in <body>, so that the script specified by the URL loaded and executed.
+    I believe this [load_script] must be called in <head>
+    for the proper execution of the script specified by the URL. 
+*)
+
+val set_onload : (unit -> unit) -> unit

File lib/gMaps.ml

+open Js
+
+open Std
+
+module MapTypeId : sig
+  type t = HYBIRD | ROADMAP | SATELLITE | TERRAIN
+  val to_js : t -> Unsafe.any
+end = struct
+  type t = HYBIRD | ROADMAP | SATELLITE | TERRAIN
+  let to_js = function
+    | HYBIRD    -> Unsafe.variable "google.maps.MapTypeId.HYBRID"
+    | ROADMAP   -> Unsafe.variable "google.maps.MapTypeId.ROADMAP"
+    | SATELLITE -> Unsafe.variable "google.maps.MapTypeId.SATELLITE"
+    | TERRAIN   -> Unsafe.variable "google.maps.MapTypeId.TERRAIN"
+end
+
+module LatLng = struct
+  class type t = object
+  end
+end 
+
+module MapOptions : sig
+  type t
+  type elt
+  val center : LatLng.t Js.t -> elt
+  val zoom : int -> elt
+  val mapTypeId : MapTypeId.t -> elt
+  val ( ** ) : elt -> elt -> elt
+  val options : elt -> t
+end = struct
+  type t
+  type elt = (string * Unsafe.any) list -> (string * Unsafe.any) list
+  let ( ** ) = ( *< )
+  let center    (v : LatLng.t Js.t) st = ("center"   , Unsafe.inject v) :: st
+  let zoom      (v : int)           st = ("zoom"     , Unsafe.inject v) :: st
+  let mapTypeId (v : MapTypeId.t)   st = ("mapTypeId", Unsafe.inject & MapTypeId.to_js v) :: st 
+
+  let options f : t = f [] |> Array.of_list |> Unsafe.obj
+end
+
+module Map = struct
+
+  class type t= object
+  end
+end
+
+module MarkerOptions : sig
+  type t
+  type elt
+  val position : LatLng.t Js.t -> elt
+  val map : Map.t Js.t -> elt
+  val title : js_string Js.t -> elt
+  val ( ** ) : elt -> elt -> elt
+  val options : elt -> t
+end = struct
+  type t
+  type elt = (string * Unsafe.any) list -> (string * Unsafe.any) list
+  let ( ** ) = ( *< )
+  let position (v : LatLng.t Js.t)  st = ("position" , Unsafe.inject v)   :: st
+  let map      (v : Map.t Js.t)     st = ("map"      , Unsafe.inject v)   :: st
+  let title    (v : js_string Js.t) st = ("title"    , Unsafe.inject & v) :: st 
+
+  let options f : t = f [] |> Array.of_list |> Unsafe.obj
+end
+
+module Marker = struct
+  class type t = object
+  end
+end
+
+class type t = object
+  method _LatLng : (float -> float -> LatLng.t Js.t) constr readonly_prop
+  method _Map : (Dom_html.element Js.t -> MapOptions.t -> Map.t Js.t) constr readonly_prop
+  method _Marker : (MarkerOptions.t -> Marker.t Js.t) constr readonly_prop
+end
+
+let load ?sensor ?callback key = 
+  let q = 
+    URL.make_query 
+    & List.filter_map (fun (k,v) ->
+        Option.map ~f:(fun v -> (k, v)) v)
+        [ "key", Some key;
+          "sensor", Option.map (function true -> "true" | false -> "false") sensor;
+          "callback", Option.map id]
+  in
+  Base.load_script (Printf.sprintf "http://maps.googleapis.com/maps/api/js?%s" q);
+

File lib/gVisualization.ml

+open Js
+open Std
+
+module DataTable = struct
+  class type t = object
+    method addColumn_withID : string_t (* type. Either "string", "number", "boolean", "date", "datetime" or "timeofday" *)
+                              -> string_t (* label *)
+                              -> string_t (* id *)
+                              -> unit meth
+
+    method addColumn : string_t (* type. Either "string", "number", "boolean", "date", "datetime" or "timeofday" *)
+                       -> string_t (* label *)
+                       -> unit meth
+
+    method addRows : 'a Js.t array_t array_t -> unit meth
+  end
+end
+
+module Chart = struct
+  class type t = object
+    method draw : DataTable.t Js.t -> 'options Js.t(* ? *) -> unit meth
+  end
+end
+
+(* Does not work: google.visualization is undefined
+   Use readonly_props
+      let cls = Unsafe.variable "google.visualization.DataTable"
+      let create () : dataTable Js.t = Unsafe.new_obj cls [| |]
+*)
+
+module Visualization = struct
+
+  class type t = object
+    (* methods and props begin with a Capital letter is prefixed with '_' in OCaml *)
+
+    (*
+      method _DataTable : dataTable Js.t readonly_prop 
+      (* Simple, but no jsnew interface.
+         for new, Unsafe.new_obj google##visualization##_DataTable_ [| |]
+      *)
+    *)
+
+    method _DataTable : DataTable.t Js.t constr readonly_prop 
+    method _PieChart : (Dom_html.element Js.t -> Chart.t Js.t) constr readonly_prop
+    method _BarChart : (Dom_html.element Js.t -> Chart.t Js.t) constr readonly_prop
+    method _ScatterChart : (Dom_html.element Js.t -> Chart.t Js.t) constr readonly_prop
+  end
+end
+
+include Visualization

File lib/google.ml

 open Js
 open Std
 
-module DataTable = struct
-  class type t = object
-    method addColumn_withID : string_t (* type. Either "string", "number", "boolean", "date", "datetime" or "timeofday" *)
-                              -> string_t (* label *)
-                              -> string_t (* id *)
-                              -> unit meth
-
-    method addColumn : string_t (* type. Either "string", "number", "boolean", "date", "datetime" or "timeofday" *)
-                       -> string_t (* label *)
-                       -> unit meth
-
-    method addRows : 'a Js.t array_t array_t -> unit meth
-  end
-end
-
-module Chart = struct
-  class type t = object
-    method draw : DataTable.t Js.t -> 'options Js.t(* ? *) -> unit meth
-  end
-end
-
-(* Does not work: google.visualization is undefined
-   Use readonly_props
-      let cls = Unsafe.variable "google.visualization.DataTable"
-      let create () : dataTable Js.t = Unsafe.new_obj cls [| |]
-*)
-
-module Visualization = struct
-
-  class type t = object
-    (* methods and props begin with a Capital letter is prefixed with '_' in OCaml *)
-
-    (*
-      method _DataTable : dataTable Js.t readonly_prop 
-      (* Simple, but no jsnew interface.
-         for new, Unsafe.new_obj google##visualization##_DataTable_ [| |]
-      *)
-    *)
-
-    method _DataTable : DataTable.t Js.t constr readonly_prop 
-    method _PieChart : (Dom_html.element Js.t -> Chart.t Js.t) constr readonly_prop
-    method _BarChart : (Dom_html.element Js.t -> Chart.t Js.t) constr readonly_prop
-    method _ScatterChart : (Dom_html.element Js.t -> Chart.t Js.t) constr readonly_prop
-  end
-end
-
 class type t = object
   method load : string_t (* name *) -> string_t (* version *) -> 'option Js.t (* option *) -> unit meth
   method setOnLoadCallback : (unit -> unit) (* ? *) -> unit meth
-  method visualization : Visualization.t Js.t readonly_prop
+
+  method visualization : GVisualization.t Js.t readonly_prop
+  method maps          : GMaps.t          Js.t readonly_prop
 end
 
-let google : t Js.t = Unsafe.variable "google"
+let get_google : unit -> t Js.t = fun () -> Unsafe.variable "google"
+(** The variable "google" may not exist when API loading is delayed *)
 
 
+

File lib/google.mli

 open Js
 open Std
 
-module DataTable : sig
-
-  class type t = object
-    method addColumn_withID : string_t (* type. Either "string", "number", "boolean", "date", "datetime" or "timeofday" *)
-                              -> string_t (* label *)
-                              -> string_t (* id *)
-                              -> unit meth
-
-    method addColumn : string_t (* type. Either "string", "number", "boolean", "date", "datetime" or "timeofday" *)
-                       -> string_t (* label *)
-                       -> unit meth
-
-    method addRows : 'a Js.t array_t array_t -> unit meth
-  end
-
-end
-
-module Chart : sig
-
-  class type t = object
-    method draw : DataTable.t Js.t -> 'options Js.t(* ? *) -> unit meth
-  end
-
-end
-
-module Visualization : sig
-
-  class type t = object
-    method _DataTable : DataTable.t Js.t constr readonly_prop 
-    method _PieChart : (Dom_html.element Js.t -> Chart.t Js.t) constr readonly_prop
-    method _BarChart : (Dom_html.element Js.t -> Chart.t Js.t) constr readonly_prop
-    method _ScatterChart : (Dom_html.element Js.t -> Chart.t Js.t) constr readonly_prop
-  end
-
-end
-
 class type t = object
   method load : string_t (* name *) -> string_t (* version *) -> 'option Js.t (* option *) -> unit meth
   method setOnLoadCallback : (unit -> unit) (* ? *) -> unit meth
-  method visualization : Visualization.t Js.t readonly_prop
+
+  method visualization : GVisualization.t Js.t readonly_prop
+  method maps          : GMaps.t          Js.t readonly_prop
 end
 
-val google : t Js.t
+val get_google : unit -> t Js.t
 
 
   include Unsafe
   include XUnsafe
 end
+
+module List = struct
+  include List
+  include Xlist
+end