Make use of ocaml's type system

src/tea_html.ml

@@ -1,5 +1,12 @@
+type 'msg t = 'msg Vdom.t
+type 'msg prop = 'msg Vdom.property
+
+type 'msg createNode = ?key:string -> ?unique:string ->
+  'msg prop list -> 'msg t list -> 'msg t
+
 open Vdom
 
+
 module Cmds = Tea_html_cmds
 
 (* let map lift vdom =
@@ -172,7 +179,7 @@ let onInputOpt ?(key="") msg =
     (fun ev ->
        match Js.Undefined.to_opt ev##target with
        | None -> None
-       | Some target -> match Js.Undefined.to_opt target##value with
+       | Some target -> match Js.Undefined.to_opt (Web_node.getValue target) with
          | None -> None
          | Some value -> msg value
     )
@@ -184,7 +191,7 @@ let onChangeOpt ?(key="") msg =
   (fun ev ->
        match Js.Undefined.to_opt ev##target with
        | None -> None
-       | Some target -> match Js.Undefined.to_opt target##value with
+       | Some target -> match Js.Undefined.to_opt (Web_node.getValue target) with
          | None -> None
          | Some value -> msg value
     )
@@ -208,7 +215,7 @@ let onCheckOpt ?(key="") msg =
     (fun ev ->
        match Js.Undefined.to_opt ev##target with
        | None -> None
-       | Some target -> match Js.Undefined.to_opt target##checked with
+       | Some target -> match Web_node.getChecked target |> Js.Undefined.to_opt with
          | None -> None
          | Some value -> msg value
     )

src/tea_html.mli

@@ -0,0 +1,123 @@
+type 'msg t = 'msg Vdom.t
+type 'msg prop = 'msg Vdom.property
+
+(* Nodes *)
+
+val noNode : 'msg t
+val text : string -> 'msg t
+
+type 'msg createNode = ?key:string -> ?unique:string ->
+  'msg prop list -> 'msg t list -> 'msg t
+
+(* TODO: needed? *)
+val node : ?namespace:string -> string -> 'msg createNode
+
+val lazy1 : string -> ( unit -> 'msg t) -> 'msg t
+
+(* HTML Elements *)
+
+val br : 'msg prop list -> 'msg t
+
+val br'        : 'msg createNode
+val div        : 'msg createNode
+val span       : 'msg createNode
+val p          : 'msg createNode
+val pre        : 'msg createNode
+val a          : 'msg createNode
+val section    : 'msg createNode
+val header     : 'msg createNode
+val footer     : 'msg createNode
+val h1         : 'msg createNode
+val h2         : 'msg createNode
+val h3         : 'msg createNode
+val h4         : 'msg createNode
+val h5         : 'msg createNode
+val h6         : 'msg createNode
+val i          : 'msg createNode
+val strong     : 'msg createNode
+val button     : 'msg createNode
+val input'     : 'msg createNode
+val textarea   : 'msg createNode
+val label      : 'msg createNode
+val ul         : 'msg createNode
+val ol         : 'msg createNode
+val li         : 'msg createNode
+val table      : 'msg createNode
+val thead      : 'msg createNode
+val tfoot      : 'msg createNode
+val tbody      : 'msg createNode
+val th         : 'msg createNode
+val tr         : 'msg createNode
+val td         : 'msg createNode
+val progress   : 'msg createNode
+val img        : 'msg createNode
+val select     : 'msg createNode
+val option'    : 'msg createNode
+val form       : 'msg createNode
+val nav        : 'msg createNode
+val main       : 'msg createNode
+val aside      : 'msg createNode
+val article    : 'msg createNode
+val details    : 'msg createNode
+val figcaption : 'msg createNode
+val figure     : 'msg createNode
+val mark       : 'msg createNode
+val summary    : 'msg createNode
+val time       : 'msg createNode
+
+(* Properties *)
+
+val noProp : 'msg prop
+val id : string -> 'msg prop
+
+(* `href` is actually an attribute, not a property, but need it here for Elm compat... *)
+val href : string -> 'msg prop
+
+(* `src` is actually an attribute, not a property, but need it here for Elm compat... *)
+val src : string -> 'msg prop
+
+val class' : string -> 'msg prop
+(* val classList : (string * bool) list -> 'msg prop *)
+val type' : string -> 'msg prop
+val style : string -> string -> 'msg prop
+val styles : (string * string) list -> 'msg prop
+val placeholder : string -> 'msg prop
+val autofocus : bool -> 'msg prop
+val value : string -> 'msg prop
+val name : string -> 'msg prop
+val checked : bool -> 'msg prop
+val for' : string -> 'msg prop
+val hidden : bool -> 'msg prop
+val target : string -> 'msg prop
+val action : string -> 'msg prop
+val method' : string -> 'msg prop
+
+(* Events *)
+
+(* TODO: should this be exposed? *)
+val onCB : string -> string -> (Web.Node.event -> 'msg option) -> 'msg prop
+val onMsg : string -> 'msg -> 'msg prop
+
+val onInput : ?key:string -> (string -> 'msg) -> 'msg prop
+val onChange : ?key:string -> (string -> 'msg) -> 'msg prop
+val onClick : 'msg -> 'msg prop
+val onDoubleClick : 'msg -> 'msg prop
+val onBlur : 'msg -> 'msg prop
+val onFocus : 'msg -> 'msg prop
+val onCheck : ?key:string -> (bool -> 'msg) -> 'msg prop
+val onMouseDown : 'msg -> 'msg prop
+val onMouseUp : 'msg -> 'msg prop
+val onMouseEnter : 'msg -> 'msg prop
+val onMouseLeave : 'msg -> 'msg prop
+val onMouseOver : 'msg -> 'msg prop
+val onMouseOut : 'msg -> 'msg prop
+
+module Attributes : sig
+  val max : string -> 'msg prop
+  val min : string -> 'msg prop
+  val step : string -> 'msg prop
+  val disabled : bool -> 'msg prop
+  val selected : bool -> 'msg prop
+  val acceptCharset : string -> 'msg prop
+  val rel : string -> 'msg prop
+end

src/tea_html_cmds.mli

@@ -0,0 +1 @@
+val focus : string -> 'a Tea_cmd.t

src/tea_navigation.ml

@@ -1,13 +1,3 @@
-
-type ('flags, 'model, 'msg) navigationProgram =
-  { init : 'flags -> Web.Location.location -> 'model * 'msg Tea_cmd.t
-  ; update : 'model -> 'msg -> 'model * 'msg Tea_cmd.t
-  ; view : 'model -> 'msg Vdom.t
-  ; subscriptions : 'model -> 'msg Tea_sub.t
-  ; shutdown : 'model -> 'msg Tea_cmd.t
-  }
-
-
 let getLocation () =
   Web.Location.asRecord (Web.Document.location ())
 
@@ -63,22 +53,34 @@ let newUrl url =
       ()
     )
 
-
-let navigationProgram locationToMessage stuff =
-    let init flag =
-      stuff.init flag (getLocation ()) in
-
-    let subscriptions model =
-      Tea_sub.batch
-        [ subscribe locationToMessage
-        ; stuff.subscriptions model
-        ] in
-
-    let open! Tea_app in
-    program
-      { init = init
-      ; update = stuff.update
-      ; view = stuff.view
-      ; subscriptions = subscriptions
-      ; shutdown = stuff.shutdown
-      }
+module type NavigationProgram = sig
+  type flags
+  type model
+  type msg
+  val init : flags -> Web.Location.location -> model * msg Tea_cmd.t
+  val update : model -> msg -> model * msg Tea_cmd.t
+  val view : model -> msg Vdom.t
+  val subscriptions : model -> msg Tea_sub.t
+  val shutdown : model -> msg Tea_cmd.t
+  val locationHandler : Web.Location.location -> msg
+end
+
+module ToProgram (M : NavigationProgram) : Tea_app.Program = struct
+  type msg = M.msg
+  type model = M.model
+  type flags = M.flags
+  let subscriptions model = Tea_sub.batch
+        [ subscribe M.locationHandler
+        ; M.subscriptions model
+        ]
+
+  let init flags =
+    M.init flags (getLocation ())
+
+  let update = M.update
+  let view = M.view
+  let shutdown = M.shutdown
+end
+
+module MakeNavigationProgram( M: NavigationProgram ) =
+  Tea_app.Make(ToProgram(M))

src/vdom.mli

@@ -0,0 +1,109 @@
+(* https://github.com/Matt-Esch/virtual-dom/blob/master/docs/vnode.md *)
+
+type 'msg applicationCallbacks = {
+  enqueue : 'msg -> unit;
+}
+
+(* Attributes are not properties *)
+(* https://developer.mozilla.org/en-US/docs/Web/HTML/Attributes *)
+
+type 'msg eventHandler =
+  | EventHandlerCallback of string * (Web.Node.event -> 'msg option)
+  | EventHandlerMsg of 'msg
+
+type 'msg eventCache =
+  { handler : Web.Node.event_cb
+  ; cb : (Web.Node.event -> 'msg option) ref
+  }
+
+type 'msg property =
+  | NoProp
+  | RawProp of string * string (* TODO:  This last string needs to be made something more generic, maybe a function... *)
+  (* Attribute (namespace, key, value) *)
+  | Attribute of string * string * string
+  | Data of string * string
+  (* Event (name, userkey, callback) *)
+  | Event of string * 'msg eventHandler * 'msg eventCache option ref
+  (* | Event of string * (Web.Event.t -> 'msg) *)
+  | Style of (string * string) list
+
+type 'msg properties = 'msg property list
+
+type 'msg t =
+  | CommentNode of string
+  | Text of string
+  (* Node (namespace, tagName, key, unique, properties, children)  *)
+  | Node of string * string * string * string * 'msg properties * 'msg t list
+  (* | ArrayNode of string * string * string * string * 'msg property array * 'msg t array *)
+  (* LazyGen (key, fnGenerator) *)
+  | LazyGen of string * (unit -> 'msg t) * 'msg t ref
+  (* Tagger (toString, toDom, toVNodes) *)
+(* | Tagger of (unit -> string) * ('msg applicationCallbacks ref -> Web.Node.t -> Web.Node.t -> int ->  'msg t list -> Web.Node.t) * (unit -> 'msg t) *)
+  (* Tagger (tagger, vdom) *)
+  | Tagger of ('msg applicationCallbacks ref -> 'msg applicationCallbacks ref) * 'msg t
+  (*  *)
+  (* | Tagger of (('a -> 'msg) -> 'a t -> 'msg t) *)
+  (* Custom (key, cbAdd, cbRemove, cbChange, properties, children) *)
+  (* | Custom of string * (unit -> Web.Node.t) * (Web.Node.t -> unit) * *)
+
+
+(* Nodes *)
+
+val noNode : 'msg t
+
+val comment : string -> 'msg t
+
+val text : string -> 'msg t
+
+val fullnode : string -> string -> string -> string
+  -> 'msg properties -> 'msg t list -> 'msg t
+
+val node : ?namespace:string -> string -> ?key:string -> ?unique:string
+  -> 'msg properties -> 'msg t list -> 'msg t
+
+val lazyGen : string -> (unit -> 'msg t) -> 'msg t
+
+(* Properties *)
+
+val noProp : 'msg property
+
+val prop : string -> string -> 'msg property
+
+val onCB : string -> string -> (Web.Node.event -> 'msg option) ->
+  'msg property
+
+val onMsg : string -> 'msg -> 'msg property
+
+val attribute : string -> string -> string -> 'msg property
+
+val data : string -> string -> 'msg property
+
+val style : string -> string -> 'msg property
+
+val styles : (string * string) list -> 'msg property
+
+(* Accessors *)
+
+val renderToHtmlString : 'msg t -> string
+
+(* Patching / Diffing *)
+
+val eventHandler_Register :
+  'msg applicationCallbacks ref ->
+    Web.Node.t ->
+      string ->
+        'msg eventHandler ->
+          'msg eventCache option
+
+val eventHandler_Unregister : Web.Node.t -> string
+  -> 'msg eventCache option -> 'msg option
+
+
+val patchVNodesIntoElement : 'msg applicationCallbacks ref ->
+  Web.Node.t -> 'msg t list -> 'msg t list -> 'msg t list
+
+(* TODO: rename mapCallbacks *)
+val wrapCallbacks : ('a -> 'b) -> 'b applicationCallbacks ref ->
+  'a applicationCallbacks ref
+
+val map : ('a -> 'b) -> 'a t -> 'b t

src/web_node.ml

@@ -35,6 +35,8 @@ type event = t Web_event.t
 
 type event_cb = t Web_event.cb
 
+let getValue t = t##value
+let getChecked t = t##checked
 
 external getProp_asEventListener : t -> 'key -> t Web_event.cb Js.undefined = "" [@@bs.get_index]
 
@@ -66,7 +68,7 @@ let removeChild n child = n##removeChild child
 
 let insertBefore n child refNode = n##insertBefore child refNode
 
-let remove n child = n##remove child
+let remove n = n##remove ()
 
 let setAttributeNS n namespace key value = n##setAttributeNS namespace key value