src/Tools/WWW_Find/xhtml.ML

filter function on streams

(*  Title:      Tools/WWW_Find/xhtml.ML
    Author:     Timothy Bourke, NICTA

Rudimentary XHTML construction.
*)

signature XHTML =
sig
  type attribute
  type common_atts = { id : string option,
                       class : string option };
  val noid : common_atts;
  val id : string -> common_atts;
  val class : string -> common_atts;

  type tag

  val doctype_xhtml1_0_strict: string;

  val att: string -> string -> attribute
  val bool_att: string * bool -> attribute list

  val tag: string -> attribute list -> tag list -> tag
  val tag': string -> common_atts -> tag list -> tag
  val text: string -> tag
  val raw_text: string -> tag

  val add_attributes: attribute list -> tag -> tag
  val append: tag -> tag list -> tag

  val show: tag -> string list

  val write: (string -> unit) -> tag -> unit
  val write_enclosed: (string -> unit) -> tag -> ((string -> unit) -> unit) -> unit

  val html: { lang : string } -> tag list -> tag
  val head: { title : string, stylesheet_href : string } -> tag list -> tag
  val body: common_atts -> tag list -> tag
  val divele: common_atts -> tag list -> tag
  val span: common_atts * string -> tag
  val span': common_atts -> tag list -> tag

  val pre: common_atts -> string -> tag

  val table: common_atts -> tag list -> tag
  val thead: common_atts -> tag list -> tag
  val tbody: common_atts -> tag list -> tag
  val tr: tag list -> tag
  val th: common_atts * string -> tag
  val th': common_atts -> tag list -> tag
  val td: common_atts * string -> tag
  val td': common_atts -> tag list -> tag
  val td'': common_atts * { colspan : int option, rowspan : int option }
           -> tag list -> tag

  val p: common_atts * string -> tag
  val p': common_atts * tag list -> tag
  val h: common_atts * int * string -> tag
  val strong: string -> tag
  val em: string -> tag
  val a: { href : string, text : string } -> tag

  val ul: common_atts * tag list -> tag
  val ol: common_atts * tag list -> tag
  val dl: common_atts * (string * tag) list -> tag

  val alternate_class: { class0 : string, class1 : string }
                      -> tag list -> tag list

  val form: common_atts * { method : string, action : string }
            -> tag list -> tag

  datatype input_type =
      TextInput of { value: string option, maxlength: int option }
    | Password of int option
    | Checkbox of { checked : bool, value : string option }
    | Radio of { checked : bool, value : string option }
    | Submit
    | Reset
    | Hidden
    | Image of { src : string, alt : string }
    | File of { accept : string }
    | Button;

  val input: common_atts * { name : string, itype : input_type } -> tag
  val select: common_atts * { name : string, value : string option }
              -> string list -> tag
  val label: common_atts * { for: string } * string -> tag

  val reset_button: common_atts -> tag
  val submit_button: common_atts -> tag

  datatype event =
    (* global *)
      OnClick
    | OnDblClick
    | OnMouseDown
    | OnMouseUp
    | OnMouseOver
    | OnMouseMove
    | OnMouseOut
    | OnKeyPress
    | OnKeyDown
    | OnKeyUp
      (* anchor/label/input/select/textarea/button/area *)
    | OnFocus
    | OnBlur
      (* form *)
    | OnSubmit
    | OnReset
      (* input/textarea *)
    | OnSelect
      (* input/select/textarea *)
    | OnChange
      (* body *)
    | OnLoad
    | OnUnload;

  val script: common_atts * { script_type: string, src: string } -> tag
  val add_script: event * string -> tag -> tag
end;

structure Xhtml : XHTML =
struct

type attribute = string * string;
type common_atts = {
    id : string option,
    class : string option
  };
val noid = { id = NONE, class = NONE };
fun id s = { id = SOME s, class = NONE };
fun class s = { id = NONE, class = SOME s };

fun from_common { id = NONE,   class = NONE } = []
  | from_common { id = SOME i, class = NONE } = [("id", i)]
  | from_common { id = NONE,   class = SOME c } = [("class", c)]
  | from_common { id = SOME i, class = SOME c } = [("id", i), ("class", c)];

val update_atts =
  AList.join (op = : string * string -> bool) (fn _ => snd);

datatype tag = Tag of (string * attribute list * tag list)
             | Text of string
             | RawText of string;

fun is_text (Tag _) = false
  | is_text (Text _) = true
  | is_text (RawText _) = true;

fun is_tag (Tag _) = true
  | is_tag (Text _) = false
  | is_tag (RawText _) = false;

val att = pair;

fun bool_att (nm, true) = [(nm, nm)]
  | bool_att (nm, false) = [];

fun tag name atts inner = Tag (name, atts, inner);
fun tag' name common_atts inner = Tag (name, from_common common_atts, inner);
fun text t = Text t;
fun raw_text t = RawText t;

fun add_attributes atts' (Tag (nm, atts, inner)) =
      Tag (nm, update_atts (atts, atts'), inner)
  | add_attributes _ t = t;

fun append (Tag (nm, atts, inner)) inner' = Tag (nm, atts, inner @ inner')
  | append _ _ = raise Fail "cannot append to a text element";

fun show_att (n, v) = implode [" ", n, "=\"", XML.text v, "\""];

fun show_text (Text t) = XML.text t
  | show_text (RawText t) = t
  | show_text _ = raise Fail "Bad call to show_text.";

fun show (Text t) = [XML.text t]
  | show (RawText t) = [t]
  | show (Tag (nm, atts, inner)) =
  (["<", nm] @ map show_att atts
   @
   (if length inner = 0
    then ["/>"]
    else flat (
      [[">"]]
      @
      map show inner
      @
      [["</", nm, ">"]]
  )));

fun write pr =
  let
    fun f (Text t) = (pr o XML.text) t
      | f (RawText t) = pr t
      | f (Tag (nm, atts, inner)) = (
          pr "<";
          pr nm;
          app (pr o show_att) atts;
          if length inner = 0
          then pr "/>"
          else (
            pr ">";
            app f inner;
            pr ("</" ^ nm ^ ">")
          ))
  in f end;

(* Print all opening tags down into the tree until a branch of degree > 1 is
   found, in which case print everything before the last tag, which is then
   opened. *)
fun write_open pr =
  let
    fun f (Text t) = (pr o XML.text) t
      | f (RawText t) = pr t
      | f (Tag (nm, atts, [])) =
          (pr "<"; pr nm; app (pr o show_att) atts; pr ">")
      | f (Tag (nm, atts, xs)) =
           (pr "<"; pr nm; app (pr o show_att) atts; pr ">";
            (case take_suffix is_text xs of
               ([], _) => ()
             | (b, _) =>
                 let val (xs, x) = split_last b;
                 in app (write pr) xs; f x end));
  in f end;

(* Print matching closing tags for write_open. *)
fun write_close pr =
  let
    fun close nm = pr ("</" ^ nm ^ ">");
    val pr_text = app (pr o show_text);

    fun f (Text t) = ()
      | f (RawText t) = ()
      | f (Tag (nm, _, [])) = close nm
      | f (Tag (nm, _, xs)) =
           (case take_suffix is_text xs of
              ([], text) => pr_text text
            | (b, text) =>
                let val (xs, x) = split_last b;
                in f x; close nm; pr_text text end);
  in f end;

fun write_enclosed pr template content =
  (write_open pr template; content pr; write_close pr template)

fun html { lang } tags = Tag ("html",
                              [("xmlns", "http://www.w3.org/1999/xhtml"),
                               ("xml:lang", lang)],
                              tags);

fun head { title, stylesheet_href } inner = let
    val link =
      Tag ("link",
        [("rel", "stylesheet"),
         ("type", "text/css"),
         ("href", stylesheet_href)], []);
    val title = Tag ("title", [], [Text title]);
    val charset = Tag ("meta",
        [("http-equiv", "Content-type"),
         ("content", "text/html; charset=UTF-8")], []);
  in Tag ("head", [], link::title::charset::inner) end;

fun body common_atts tags = Tag ("body", from_common common_atts, tags);

fun divele common_atts tags = Tag ("div", from_common common_atts, tags);
fun span (common_atts, t) = Tag ("span", from_common common_atts, [Text t]);
fun span' common_atts tags = Tag ("span", from_common common_atts, tags);

fun pre common_atts rt = Tag ("pre", from_common common_atts, [RawText rt]);

fun ostr_att (nm, NONE) = []
  | ostr_att (nm, SOME s) = [(nm, s)];
val oint_att = ostr_att o apsnd (Option.map string_of_int);

val table = tag' "table";
val thead = tag' "thead";
val tbody = tag' "tbody";
val tr = tag "tr" [];
fun th (common_atts, t) = Tag ("th", from_common common_atts, [Text t]);
fun th' common_atts tags = Tag ("th", from_common common_atts, tags);
fun td (common_atts, t) = Tag ("td", from_common common_atts, [Text t]);
fun td' common_atts tags = Tag ("td", from_common common_atts, tags);
fun td'' (common_atts, { colspan, rowspan }) tags =
  Tag ("td",
    from_common common_atts
    @ oint_att ("colspan", colspan)
    @ oint_att ("rowspan", rowspan),
    tags);

fun p (common_atts, t) = Tag ("p", from_common common_atts, [Text t]);
fun p' (common_atts, tags) = Tag ("p", from_common common_atts, tags);

fun h (common_atts, i, text) =
  Tag ("h" ^ string_of_int i, from_common common_atts, [Text text]);

fun strong t = Tag ("strong", [], [Text t]);
fun em t = Tag ("em", [], [Text t]);
fun a { href, text } = Tag ("a", [("href", href)], [Text text]);

fun to_li tag = Tag ("li", [], [tag]);
fun ul (common_atts, lis) = Tag ("ul", from_common common_atts, map to_li lis);
fun ol (common_atts, lis) = Tag ("ol", from_common common_atts, map to_li lis);

fun to_dtdd (nm, tag) = [Tag ("dt", [], [Text nm]),
                         Tag ("dd", [], [tag])];
fun dl (common_atts, dtdds) =
  Tag ("dl", from_common common_atts, maps to_dtdd dtdds);
            
fun alternate_class { class0, class1 } rows = let
    fun f ((true, xs), x) = (false, add_attributes [("class", class0)] x :: xs)
      | f ((false, xs), x) = (true, add_attributes [("class", class1)] x :: xs);
  in Library.foldl f ((true, []), rows) |> snd |> rev end;

fun form (common_atts as { id, ... }, { method, action }) tags =
  Tag ("form",
    [("method", method),
     ("action", action)]
    @ from_common common_atts, tags);

datatype input_type =
    TextInput of { value: string option, maxlength: int option }
  | Password of int option
  | Checkbox of { checked : bool, value : string option }
  | Radio of { checked : bool, value : string option }
  | Submit
  | Reset
  | Hidden
  | Image of { src : string, alt : string }
  | File of { accept : string }
  | Button;

fun from_checked { checked = false, value = NONE }   = []
  | from_checked { checked = true,  value = NONE }   = [("checked", "checked")]
  | from_checked { checked = false, value = SOME v } = [("value", v)]
  | from_checked { checked = true,  value = SOME v } =
      [("checked", "checked"), ("value", v)];

fun input_atts (TextInput { value, maxlength }) =
      ("type", "text")
       :: ostr_att ("value", value)
        @ oint_att ("maxlength", maxlength)
  | input_atts (Password NONE) = [("type", "password")]
  | input_atts (Password (SOME i)) =
      [("type", "password"), ("maxlength", string_of_int i)]
  | input_atts (Checkbox checked) =
      ("type", "checkbox") :: from_checked checked
  | input_atts (Radio checked) = ("type", "radio") :: from_checked checked
  | input_atts Submit = [("type", "submit")]
  | input_atts Reset = [("type", "reset")]
  | input_atts Hidden = [("type", "hidden")]
  | input_atts (Image { src, alt }) =
      [("type", "image"), ("src", src), ("alt", alt)]
  | input_atts (File { accept }) = [("type", "file"), ("accept", accept)]
  | input_atts Button = [("type", "button")];

fun input (common_atts, { name, itype }) =
  Tag ("input",
       input_atts itype @ [("name", name)] @ from_common common_atts,
       []);

fun reset_button common_atts =
  Tag ("input", input_atts Reset @ from_common common_atts, []);

fun submit_button common_atts =
  Tag ("input", input_atts Submit @ from_common common_atts, []);


fun select (common_atts, { name, value }) options =
  let
    fun is_selected t =
      (case value of
         NONE => []
       | SOME s => if t = s then bool_att ("selected", true) else []);
    fun to_option t = Tag ("option", is_selected t, [Text t]);
  in
    Tag ("select",
      ("name", name) :: from_common common_atts,
      map to_option options)
  end;

fun label (common_atts, { for }, text) =
  Tag ("label", ("for", for) :: from_common common_atts, [Text text]);

datatype event =
    OnClick
  | OnDblClick
  | OnMouseDown
  | OnMouseUp
  | OnMouseOver
  | OnMouseMove
  | OnMouseOut
  | OnKeyPress
  | OnKeyDown
  | OnKeyUp
  | OnFocus
  | OnBlur
  | OnSubmit
  | OnReset
  | OnSelect
  | OnChange
  | OnLoad
  | OnUnload;

fun event_to_str OnClick = "onclick"
  | event_to_str OnDblClick = "ondblclick"
  | event_to_str OnMouseDown = "onmousedown"
  | event_to_str OnMouseUp = "onmouseup"
  | event_to_str OnMouseOver = "onmouseover"
  | event_to_str OnMouseMove = "onmousemove"
  | event_to_str OnMouseOut = "onmouseout"
  | event_to_str OnKeyPress = "onkeypress"
  | event_to_str OnKeyDown = "onkeydown"
  | event_to_str OnKeyUp = "onkeyup"
  | event_to_str OnFocus = "onfocus"
  | event_to_str OnBlur = "onblur"
  | event_to_str OnSubmit = "onsubmit"
  | event_to_str OnReset = "onreset"
  | event_to_str OnSelect = "onselect"
  | event_to_str OnChange = "onchange"
  | event_to_str OnLoad = "onload"
  | event_to_str OnUnload = "onunload";

fun script (common_atts, {script_type, src}) =
  Tag ("script",
    ("type", script_type)
    :: ("src", src)
    :: from_common common_atts, [text ""]);

fun add_script (evty, script) (Tag (name, atts, inner))
      = Tag (name, AList.update (op =) (event_to_str evty, script) atts, inner)
  | add_script _ t = t;


val doctype_xhtml1_0_strict =
  "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \
  \\"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">\n";

end;