added colors to the css library and added a robust table creation fun…

…ction to the Html.Create module

lib/css.ml

@@ -15,6 +15,13 @@
  *)
 
 module Css = struct
+  type color =
+      Rgba of char * char * char * char
+    | Rgb of char * char * char
+
+  and color_fmt =
+    [ `Hex | `Rgb ]
+
   type elt =
     | Str of string
     | Fun of string * expr list
@@ -176,6 +183,52 @@ module Css = struct
           | Not_found -> raise Not_found
         )
     | _ -> err_invalid_css ()
+
+  let color_to_string ?(fmt = `Hex) c =
+    let rval = match fmt,c with
+    | `Hex,(Rgba (r,g,b,a)) ->
+        let fmt' = format_of_string "#%02x%02x%02x%02x" in
+        let r = int_of_char r
+        and g = int_of_char g
+        and b = int_of_char b
+        and a = int_of_char a in
+        Printf.sprintf fmt' r g b a
+    | `Hex,(Rgb (r,g,b)) ->
+        let fmt' = format_of_string "#%02x%02x%02x" in
+        let r = int_of_char r
+        and g = int_of_char g
+        and b = int_of_char b in
+        Printf.sprintf fmt' r g b
+    | `Rgb,(Rgba (r,g,b,a)) ->
+        let fmt' = format_of_string "rgba(%d,%d,%d,%d)" in
+        let r = int_of_char r
+        and g = int_of_char g
+        and b = int_of_char b
+        and a = int_of_char a in
+        Printf.sprintf fmt' r g b a
+    | `Rgb,(Rgb (r,g,b)) ->
+        let fmt' = format_of_string "rgb(%d,%d,%d)" in
+        let r = int_of_char r
+        and g = int_of_char g
+        and b = int_of_char b in
+        Printf.sprintf fmt' r g b
+    in rval
+
+  let color_of_string ?(fmt = `Hex) s =
+    let s = String.lowercase s in
+    let coi = char_of_int in
+    let rval = match fmt with
+      | `Hex ->
+          let fmt' = format_of_string "#%x" in
+          let x = Scanf.sscanf s fmt' (fun x -> x) in
+          let r,g,b = (x land 0xff0000) lsr 16, (x land 0xff00) lsr 8,
+                      x land 0xff in
+          Rgb(coi r, coi g, coi b)
+      | `Rgb ->
+          let fmt' = format_of_string "rgb(%d,%d,%d)" in
+          let r,g,b = Scanf.sscanf s fmt' (fun a b c -> a,b,c) in
+          Rgb(coi r, coi g, coi b)
+    in rval
 end
 
 type gradient_type = [ `Linear | `Radial ]

lib/css.mli

@@ -14,6 +14,16 @@
  * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  *)
 
+(** convenience type for manipulating colors in COW *)
+type color =
+    Rgba of char * char * char * char
+  | Rgb of char * char * char
+
+(** tags used to specify how colors are to be read from and written to strings
+ *)
+type color_fmt =
+  [ `Hex | `Rgb ]
+
 (** Single element *)
 type elt =
   | Str of string
@@ -28,6 +38,22 @@ type prop_decl =
   | Prop of string * expr list
   | Decl of expr list * prop_decl list
 
+(** [color_to_string ~fmt:f c] converts a value [c] of type [Cow.Css.color] to
+    a string using the format [f] (either [`Hex] for values such as ["#a0b0c0"]
+    or [`Rgb] for values such as ["rgb(42,42,42)"]). Uses [printf] internally.
+    *)
+val color_to_string :
+  ?fmt:color_fmt ->
+  color ->
+  string
+
+(** [color_of_string ~fmt:f s] converts a string [s] to a [Cow.Css.color] based
+    on the format [f]. Internally uses [Scanf.sscanf] for parsing. *)
+val color_of_string :
+  ?fmt:color_fmt ->
+  string ->
+  color
+
 (** Utility type used to specify the type of gradient to be
     emitted by [polygradient] *)
 type gradient_type = [ `Linear | `Radial ]

lib/html.ml

@@ -17,7 +17,7 @@
  *)
 
 type element = ('a Xml.frag as 'a) Xml.frag
-type t = Xml.t
+type t = element list
 
 type tree = [ `Data of string | `El of Xmlm.tag * 'a list ] as 'a
 
@@ -198,7 +198,23 @@ let concat els =
 let append (_to : t) (el : t) = _to @ el
 
 module Create = struct
-  type t = element list
+  module Tags = struct
+    type html_list = [ `Ol of t list | `Ul of t list ]
+
+    type table_flags =
+        Headings_fst_col
+      | Headings_fst_row
+      | Sideways
+      | Heading_color of Css.color
+      | Bg_color of Css.color
+
+    type 'a table =
+      [ `Tr of 'a table list | `Td of 'a * int * int | `Th of 'a * int * int ]
+  end
+
+  open Tags
+
+  type t = Xml.t
 
   let ul ls =
     let els =
@@ -210,4 +226,66 @@ module Create = struct
       concat (List.map (fun el -> <:html< <li>$el$</li> >>) ls)
     in <:html< <ol>$els$</ol> >>
 
+  let stylesheet css =
+    <:html< <style type="text/css">$css:css$</style> >>
+
+  let table ~row ?(flags = [Headings_fst_row]) tbl =
+    let h_fst_col = ref false in
+    let h_fst_row = ref false in
+    let hdg_c = ref (Css.color_of_string "#eDeDeD") in
+    let bg_c = ref (Css.color_of_string "#fFfFfF") in
+    let side = ref false in
+    let () = List.iter (fun tag ->
+      match tag with
+      | Headings_fst_col -> h_fst_col := true;
+      | Headings_fst_row -> h_fst_row := true;
+      | Heading_color c -> hdg_c := c;
+      | Bg_color c -> bg_c := c;
+      | Sideways -> side := true;
+      ();)
+      flags in
+    let rows = List.map row tbl in
+    let rows =
+      if !side then
+        List.mapi (fun i _ -> List.map (fun el -> List.nth el i) rows) @@ List.hd rows
+      else
+        rows in
+    let cellify rows =
+      List.map (fun r ->
+        List.map (fun el -> <:html<<td>$el$</td>&>>) r
+      ) rows in
+    let rows =
+      match !h_fst_row,!h_fst_col with
+      | false,false ->
+          cellify rows
+      | true,false ->
+          let hrow =
+            List.hd rows
+            |> List.map (fun el -> <:html<<th>$el$</th>&>>) in
+          let rest = cellify (List.tl rows) in
+          hrow :: rest
+      | false,true ->
+          List.map (fun r ->
+            let h = List.hd r in
+            let rest = List.map (fun el -> <:html<<td>$el$</td>&>>) (List.tl r) in
+            <:html<<th>$h$</th>&>> :: rest)
+            rows
+      | true,true ->
+          let hrow =
+            List.hd rows
+            |> List.map (fun el -> <:html<<th>$el$</th>&>>) in
+          let rest =
+            List.tl rows
+            |> List.map (fun r ->
+                let hcell = List.hd r in
+                let rest = List.flatten @@ cellify [List.tl r] in
+                <:html<<th>$hcell$</th>&>> :: rest)
+          in hrow :: rest
+    in
+    let rows = List.map (fun r -> let r = List.flatten r in <:html<<tr>$r$</tr>&>>) rows in
+    let rows = concat rows in
+    let hc = Css.color_to_string !hdg_c in
+    let bg = Css.color_to_string !bg_c in
+    <:html<<table>$rows$</table>&>>
+
 end

lib/html.mli

@@ -123,9 +123,67 @@ val concat : t list -> t
 val append : t -> t -> t
 
 module Create : sig
-  type t = element list
+  module Tags : sig
+    type html_list = [`Ol of t list | `Ul of t list]
+
+    type table_flags =
+        Headings_fst_col
+      | Headings_fst_row
+      | Sideways
+      | Heading_color of Css.color
+      | Bg_color of Css.color 
+
+    type 'a table =
+      [ `Tr of 'a table list | `Td of 'a * int * int | `Th of 'a * int * int ]
+  end
+
+  type t = Xml.t
 
   val ul : t list -> t
 
   val ol : t list -> t
+  (** [ul ls] converts an OCaml list of HTML elements to a valid HTML ordered
+   *  list *)
+
+  val stylesheet : Css.t -> t
+  (** [stylesheet style] converts a COW CSS type to a valid HTML stylesheet *)
+
+  val table :
+    row:('a -> t list) ->
+    ?flags:Tags.table_flags list ->
+    'a list ->
+    t
+  (** [table ~row:r ~flags:f t] produces an HTML table formatted according to
+      [f] of type [Cow.Html.Create.Tags.table_flags list]. [r] is a function to
+      transform a single row (a tuple) into a [Cow.Html.t list]. [t] is a list
+      of n-tuples representing a table where the number of rows is equal to the
+      length of the list and the number of columns is equal to [n]. See the
+      following example:
+{[
+let row = (fun (name,email) -> [ <:html<$str:name$>>; <:html<$str:email$>>]) in
+let data =
+  [ "Name","Email Address";
+    "John Christopher McAlpine","christophermcalpine@gmail.com";
+    "Somebody McElthein","johnqpublic@something.something";
+    "John Doe","johndoe@johndoe.com" ] in
+let table = Cow.Html.Create ~row data
+]}
+      which produces the HTML table
+{[
+<!DOCTYPE html>
+<table>
+  <tr>
+    <th>Name</th>                       <th>Email Address</th>
+  </tr>
+  <tr>
+    <td>John Christopher McAlpine</td>  <td>christophermcalpine@gmail.com</td>
+  </tr>
+  <tr>
+    <td>Somebody McElthein</td>         <td>johnqpublic@something.something</td>
+  </tr>
+  <tr>
+    <td>John Doe</td>                   <td>johndoe@johndoe.com</td>
+  </tr>
+</table>
+]}*)
 end