Source file dom.ml

(* Js_of_ocaml library
 * http://www.ocsigen.org/js_of_ocaml/
 * Copyright (C) 2010 Jérôme Vouillon
 * Laboratoire PPS - CNRS Université Paris Diderot
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, with linking exception;
 * either version 2.1 of the License, or (at your option) any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 *)

open Js
open! Import

class type ['node] nodeList = object
  method item : int -> 'node t opt meth

  method length : int readonly_prop
end

let list_of_nodeList (nodeList : 'a nodeList t) =
  let length = nodeList##.length in
  let rec add_item acc i =
    if i < length
    then
      match Opt.to_option (nodeList##item i) with
      | None -> add_item acc (i + 1)
      | Some e -> add_item (e :: acc) (i + 1)
    else List.rev acc
  in
  add_item [] 0

type nodeType =
  | OTHER
  (* Will not happen *)
  | ELEMENT
  | ATTRIBUTE
  | TEXT
  | CDATA_SECTION
  | ENTITY_REFERENCE
  | ENTITY
  | PROCESSING_INSTRUCTION
  | COMMENT
  | DOCUMENT
  | DOCUMENT_TYPE
  | DOCUMENT_FRAGMENT
  | NOTATION

module DocumentPosition = struct
  type t = int

  type mask = int

  let disconnected = 0x01

  let preceding = 0x02

  let following = 0x04

  let contains = 0x08

  let contained_by = 0x10

  let implementation_specific = 0x20

  let has t mask = t land mask = mask

  let add x y = x lor y

  let ( + ) = add
end

class type node = object
  method nodeName : js_string t readonly_prop

  method nodeValue : js_string t opt readonly_prop

  method nodeType : nodeType readonly_prop

  method parentNode : node t opt prop

  method childNodes : node nodeList t prop

  method firstChild : node t opt prop

  method lastChild : node t opt prop

  method previousSibling : node t opt prop

  method nextSibling : node t opt prop

  method namespaceURI : js_string t opt prop

  method insertBefore : node t -> node t opt -> node t meth

  method replaceChild : node t -> node t -> node t meth

  method removeChild : node t -> node t meth

  method appendChild : node t -> node t meth

  method hasChildNodes : bool t meth

  method cloneNode : bool t -> node t meth

  method compareDocumentPosition : node t -> DocumentPosition.t meth

  method lookupNamespaceURI : js_string t -> js_string t opt meth

  method lookupPrefix : js_string t -> js_string t opt meth
end

let appendChild (p : #node t) (n : #node t) = ignore (p##appendChild (n :> node t))

let removeChild (p : #node t) (n : #node t) = ignore (p##removeChild (n :> node t))

let replaceChild (p : #node t) (n : #node t) (o : #node t) =
  ignore (p##replaceChild (n :> node t) (o :> node t))

let insertBefore (p : #node t) (n : #node t) (o : #node t opt) =
  ignore (p##insertBefore (n :> node t) (o :> node t opt))

(** Specification of [Attr] objects. *)
class type attr = object
  inherit node

  method name : js_string t readonly_prop

  method specified : bool t readonly_prop

  method value : js_string t prop

  method ownerElement : element t prop
end

(** Specification of [NamedNodeMap] objects. *)
and ['node] namedNodeMap = object
  method getNamedItem : js_string t -> 'node t opt meth

  method setNamedItem : 'node t -> 'node t opt meth

  method removeNamedItem : js_string t -> 'node t opt meth

  method item : int -> 'node t opt meth

  method length : int readonly_prop
end

(** Specification of [Element] objects. *)
and element = object
  inherit node

  method tagName : js_string t readonly_prop

  method getAttribute : js_string t -> js_string t opt meth

  method setAttribute : js_string t -> js_string t -> unit meth

  method removeAttribute : js_string t -> unit meth

  method hasAttribute : js_string t -> bool t meth

  method getAttributeNS : js_string t -> js_string t -> js_string t opt meth

  method setAttributeNS : js_string t -> js_string t -> js_string t -> unit meth

  method removeAttributeNS : js_string t -> js_string t -> unit meth

  method hasAttributeNS : js_string t -> js_string t -> bool t meth

  method getAttributeNode : js_string t -> attr t opt meth

  method setAttributeNode : attr t -> attr t opt meth

  method removeAttributeNode : attr t -> attr t meth

  method getAttributeNodeNS : js_string t -> js_string t -> attr t opt meth

  method setAttributeNodeNS : attr t -> attr t opt meth

  method getElementsByTagName : js_string t -> element nodeList t meth

  method attributes : attr namedNodeMap t readonly_prop
end

class type characterData = object
  inherit node

  method data : js_string t prop

  method length : int readonly_prop

  method subjs_stringData : int -> int -> js_string t meth

  method appendData : js_string t -> unit meth

  method insertData : int -> js_string t -> unit meth

  method deleteData : int -> int -> unit meth

  method replaceData : int -> int -> js_string t -> unit meth
end

class type comment = characterData

class type text = characterData

class type documentFragment = node

class type ['element] document = object
  inherit node

  method documentElement : 'element t readonly_prop

  method createDocumentFragment : documentFragment t meth

  method createElement : js_string t -> 'element t meth

  method createElementNS : js_string t -> js_string t -> 'element t meth

  method createTextNode : js_string t -> text t meth

  method createAttribute : js_string t -> attr t meth

  method createComment : js_string t -> comment t meth

  method getElementById : js_string t -> 'element t opt meth

  method getElementsByTagName : js_string t -> 'element nodeList t meth

  method importNode : element t -> bool t -> 'element t meth

  method adoptNode : element t -> 'element t meth
end

type node_type =
  | Element of element t
  | Attr of attr t
  | Text of text t
  | Other of node t

let nodeType e =
  match e##.nodeType with
  | ELEMENT -> Element (Js.Unsafe.coerce e)
  | ATTRIBUTE -> Attr (Js.Unsafe.coerce e)
  | CDATA_SECTION | TEXT -> Text (Js.Unsafe.coerce e)
  | _ -> Other (e :> node t)

module CoerceTo = struct
  let cast (e : #node Js.t) t =
    if e##.nodeType == t then Js.some (Js.Unsafe.coerce e) else Js.null

  let element e : element Js.t Js.opt = cast e ELEMENT

  let text e : text Js.t Js.opt =
    if e##.nodeType == TEXT || e##.nodeType == CDATA_SECTION
    then Js.some (Js.Unsafe.coerce e)
    else Js.null

  let attr e : attr Js.t Js.opt = cast e ATTRIBUTE
end

type ('a, 'b) event_listener = ('a, 'b -> bool t) meth_callback opt
(** The type of event listener functions.  The first type parameter
      ['a] is the type of the target object; the second parameter
      ['b] is the type of the event object. *)

class type ['a] event = object
  method _type : js_string t readonly_prop

  method target : 'a t opt readonly_prop

  method currentTarget : 'a t opt readonly_prop

  method preventDefault : unit meth

  (* Legacy methods *)
  method srcElement : 'a t opt readonly_prop
end

class type ['a, 'b] customEvent = object
  inherit ['a] event

  method detail : 'b Js.opt Js.readonly_prop
end

let no_handler : ('a, 'b) event_listener = Js.null

(* The function preventDefault must be called explicitly when
   using addEventListener... *)
let handler f =
  Js.some
    (Js.Unsafe.callback (fun e ->
         let res = f e in
         if not (Js.to_bool res) then e##preventDefault;
         res))

let full_handler f =
  Js.some
    (Js.Unsafe.meth_callback (fun this e ->
         let res = f this e in
         if not (Js.to_bool res) then e##preventDefault;
         res))

let invoke_handler (f : ('a, 'b) event_listener) (this : 'a) (event : 'b) : bool t =
  Js.Unsafe.call f this [| Js.Unsafe.inject event |]

let eventTarget (e : (< .. > as 'a) #event t) : 'a t =
  Opt.get e##.target (fun () -> Opt.get e##.srcElement (fun () -> raise Not_found))

module Event = struct
  type 'a typ = Js.js_string Js.t

  let make s = Js.string s
end

type event_listener_id = unit -> unit

class type event_listener_options = object
  method capture : bool t writeonly_prop

  method once : bool t writeonly_prop

  method passive : bool t writeonly_prop
end

let addEventListenerWithOptions (e : < .. > t) typ ?capture ?once ?passive h =
  if not (Js.Optdef.test (Js.Unsafe.coerce e)##.addEventListener)
  then
    let ev = (Js.string "on")##concat typ in
    let callback e = Js.Unsafe.call (h, e, [||]) in
    let () = (Js.Unsafe.coerce e)##attachEvent ev callback in
    fun () -> (Js.Unsafe.coerce e)##detachEvent ev callback
  else
    let opts : event_listener_options t = Js.Unsafe.obj [||] in
    let iter t f =
      match t with
      | None -> ()
      | Some b -> f b
    in
    iter capture (fun b -> opts##.capture := b);
    iter once (fun b -> opts##.once := b);
    iter passive (fun b -> opts##.passive := b);
    let () = (Js.Unsafe.coerce e)##addEventListener typ h opts in
    fun () -> (Js.Unsafe.coerce e)##removeEventListener typ h opts

let addEventListener (e : < .. > t) typ h capt =
  addEventListenerWithOptions e typ ~capture:capt h

let removeEventListener id = id ()

let preventDefault ev = ev##preventDefault

let createCustomEvent ?bubbles ?cancelable ?detail typ =
  let opt_iter f = function
    | None -> ()
    | Some x -> f x
  in
  let opts = Unsafe.obj [||] in
  opt_iter (fun x -> opts##.bubbles := bool x) bubbles;
  opt_iter (fun x -> opts##.cancelable := bool x) cancelable;
  opt_iter (fun x -> opts##.detail := some x) detail;
  let constr :
      (   ('a, 'b) #customEvent Js.t Event.typ
       -> < detail : 'b opt prop > t
       -> ('a, 'b) customEvent t)
      constr =
    Unsafe.global##._CustomEvent
  in
  new%js constr typ opts

class type stringList = object
  method item : int -> js_string t opt meth

  method length : int readonly_prop

  method contains : js_string t -> bool t meth
end