Source file xml.ml

open! Core

type xml = Xml_light.Xml.xml

module type Xmlable = sig
  type t
  val xsd : xml list
  val to_xml : t -> xml list
  val of_xml : xml -> t
end

let to_string xml = Xml_light.Xml.to_string xml
let to_string_fmt xml = Xml_light.Xml.to_string_fmt xml
let to_human_string xml = Xml_light.Xml.to_human_string xml

module Parser_state = struct
  type t = Xml_light.XmlParser.t
  let make = Xml_light.XmlParser.make
end

let stateful_of_string = Xml_light.Xml.parse_string_with

let of_file file = Xml_light.Xml.parse_file file

let create_node ~tag ~body = Xml_light.Xml.Element (tag, [], body)

let create_data body = Xml_light.Xml.PCData body

let tag xml =
  match xml with
  | Xml_light.Xml.PCData _ -> None
  | Xml_light.Xml.Element (tag, _, _) -> Some tag

let attributes xml =
  match xml with
  | Xml_light.Xml.PCData _ -> []
  | Xml_light.Xml.Element (_, attrs, _) -> attrs

let children xml =
  match xml with
  | Xml_light.Xml.PCData _ -> []
  | Xml_light.Xml.Element (_, _, children) -> children

let child xml my_tag =
  List.find ~f:(fun xml -> (Some my_tag) = (tag xml)) (children xml)

let rec contents xml =
  match xml with
  | Xml_light.Xml.PCData str -> Some str
  | Xml_light.Xml.Element (_, _, [element]) -> contents element
  | Xml_light.Xml.Element _ -> None

let kind xml =
  match xml with
  | Xml_light.Xml.PCData _
  | Xml_light.Xml.Element (_, _, [Xml_light.Xml.PCData _]) -> `Leaf
  | Xml_light.Xml.Element _  -> `Internal

let xml_data string = Xml_light.Xml.PCData string

exception Unexpected_xml of (xml * string)

exception Illegal_atom of xml

let check_extra_fields xml fields =
  let fail got =
    let fields = String.concat ~sep:";" fields in
    let msg = Printf.sprintf "record expected with fields [%s] but got %S" fields got in
    raise (Unexpected_xml (xml, msg))
  in
  match xml with
  | Xml_light.Xml.PCData _ -> fail "PCData"
  | Xml_light.Xml.Element (_, _, children) ->
    let iter child =
      match child with
      | Xml_light.Xml.PCData _ -> fail "PCData"
      | Xml_light.Xml.Element (tag, _, _) ->
        if not (List.mem fields tag ~equal:String.equal) then fail tag
    in
    List.iter ~f:iter children

module Restriction = struct
  module Format = struct
    type t =
      [ `string
      | `decimal
      | `date
      | `time
      | `datetime
      | `integer ]

    exception Illegal_format

    let to_string = function
      | `time     -> "xs:time"
      | `string   -> "xs:string"
      | `decimal  -> "xs:decimal"
      | `date     -> "xs:date"
      | `datetime -> "xs:dateTime"
      | `integer  -> "xs:integer"

    let of_string = function
      | "xs:time"     -> `time
      | "xs:string"   -> `string
      | "xs:decimal"  -> `decimal
      | "xs:date"     -> `date
      | "xs:dateTime" -> `datetime
      | "xs:integer"  -> `integer
      | _             -> raise Illegal_format
  end

  type t = xml

  let simple_type ~restrictions ~format =
    let restriction =
      Xml_light.Xml.Element ("xs:restriction", ["base", Format.to_string format],
        restrictions)
    in
    [ Xml_light.Xml.Element ("xs:simpleType", [], [restriction]) ]

  let restriction kind value =
    Xml_light.Xml.Element ("xs:" ^ kind, ["value", value], [])

  let enumeration string =
    restriction "enumeration" string

  exception Illegal_restriction

  let not_negative str n =
    if n < 0 then raise Illegal_restriction
    else restriction str (string_of_int n)

  let fraction_digits n =
    not_negative "fractionDigits" n

  let length n =
    not_negative "length" n

  let max_exclusive n =
    restriction "maxExclusive" (string_of_int n)

  let min_exclusive n =
    restriction "minExclusive" (string_of_int n)

  let max_inclusive n =
    restriction "maxInclusive" (string_of_int n)

  let min_inclusive n =
    restriction "minInclusive" (string_of_int n)

  let max_length n =
    not_negative "maxLength" n

  let min_length n =
    not_negative "minLength" n

  let pattern str =
    restriction "pattern" str

  let total_digits n =
    not_negative "totalDigits" n

end

module type Atom = sig
  type t
  val of_string  : string -> t
  val to_string  : t -> string
  val xsd_format : Restriction.Format.t
  val xsd_restrictions : Restriction.t list
end

let to_xml ~to_string v =
  [Xml_light.Xml.PCData (to_string v)]

let of_xml ~of_string xml =
  match xml with
  | Xml_light.Xml.Element (_, [], []) -> of_string ""
  | Xml_light.Xml.Element (_, [], [Xml_light.Xml.PCData str])
  | Xml_light.Xml.PCData str -> of_string str
  | Xml_light.Xml.Element _ -> raise (Unexpected_xml (xml, "noname"))

module Make (Atom : Atom) : Xmlable with type t = Atom.t = struct
  type t = Atom.t
  let xsd =
    Restriction.simple_type
      ~restrictions:Atom.xsd_restrictions ~format:Atom.xsd_format
  let to_xml = to_xml ~to_string:Atom.to_string
  let of_xml = of_xml ~of_string:Atom.of_string
end

let wrap xsd =
  Xml_light.Xml.Element ("xs:schema", ["xmlns:xs","http://www.w3.org/2001/XMLSchema"],
    [xsd])

(** All the conversion functions *)
(*let atom_conversion f xml =
  match xml with
  | Xml_light.Xml.Element (_, [], [Xml_light.Xml.PCData string])
  | Xml_light.Xml.PCData string -> f string
  | Xml_light.Xml.Element _ -> raise (Illegal_atom xml)*)

let get_child name xml =
  try
    let children = Xml_light.Xml.children xml in
    match List.find ~f:(fun t -> name = Xml_light.Xml.tag t) children with
    | Some res -> res
    | None ->
      let msg =
        Printf.sprintf "Expected to find an entry %S but it was not present" name
      in
      raise (Unexpected_xml (xml, msg))
  with
  | Xml_light.Xml.Not_element xml -> raise (Unexpected_xml (xml, name))

type 'a of_xml = xml -> 'a

let of_xml_conversion of_str xml =
  match xml with
  | Xml_light.Xml.Element (_, [], []) -> of_str ""
  | Xml_light.Xml.Element (_, [], [Xml_light.Xml.PCData str])
  | Xml_light.Xml.PCData str -> of_str str
  | Xml_light.Xml.Element _ -> raise (Unexpected_xml (xml, ""))


let unit_of_xml xml =
  of_xml_conversion (fun _ -> ()) xml

let bool_of_xml xml =
  of_xml_conversion (fun str ->
    let str = String.uppercase str in
    if not (str = "TRUE" || str = "FALSE") then
      failwith
        (Printf.sprintf
          "Xml conversion: Illegal boolean %s (should be TRUE or FALSE)." str)
    else str = "TRUE") xml

let string_of_xml xml =
  of_xml_conversion (fun x -> x) xml

let char_of_xml xml =
  let f str = String.get str 0 in
  of_xml_conversion f xml

let int_of_xml xml =
  of_xml_conversion int_of_string xml

let float_of_xml xml =
  of_xml_conversion float_of_string xml

let int32_of_xml xml =
  of_xml_conversion Int32.of_string xml

let int64_of_xml xml =
  of_xml_conversion Int64.of_string xml

let nativeint_of_xml xml =
  of_xml_conversion Nativeint.of_string xml

let big_int_of_xml xml =
  of_xml_conversion Big_int.big_int_of_string xml

let nat_of_xml xml =
  of_xml_conversion Nat.nat_of_string xml

let num_of_xml xml =
  of_xml_conversion Num.num_of_string xml

let ratio_of_xml xml =
  of_xml_conversion Ratio.ratio_of_string xml

let recursive_of_xml name a__of_xml xml =
  let me = get_child name xml in
  a__of_xml me

let list_of_xml ?tag a__of_xml xml =
  match tag with
  | None -> (match xml with
    | Xml_light.Xml.Element (_, _, contents) ->
      List.map ~f:a__of_xml contents
    | Xml_light.Xml.PCData _ -> raise (Unexpected_xml (xml, "")))
  | Some tag ->
    match child xml tag with
    | None -> []
    | Some child ->
      match child with
      | Xml_light.Xml.Element (_, _, contents) ->
        List.map ~f:a__of_xml contents
      | Xml_light.Xml.PCData _ -> raise (Unexpected_xml (xml, ""))

let option_of_xml ~tag a__of_xml xml =
  match child xml tag with
  | None -> None
  | Some child -> Some (a__of_xml child)

let lazy_t_of_xml a__of_xml xml =
  Lazy.from_val (a__of_xml xml)

let ref_of_xml a__of_xml xml =
  ref (a__of_xml xml)

let array_of_xml ~tag a__of_xml xml =
  let lst = list_of_xml ~tag a__of_xml xml in
  Array.of_list lst

let conversion to_string t =
  [ Xml_light.Xml.PCData (to_string t) ]

let conversion_sexp sexp_of_t t =
  let to_string t = Sexplib.Sexp.to_string (sexp_of_t t) in
  conversion to_string t

type 'a to_xml = 'a -> xml list

let xml_of_unit () =
  conversion (fun () -> "") ()

let xml_of_bool t =
  conversion (function true -> "TRUE" | false -> "FALSE") t

let xml_of_string t =
  conversion (fun x -> x) t

let xml_of_char t =
  let f char = String.make 1 char in
  conversion f t

let xml_of_int t =
  conversion string_of_int t

let xml_of_float t =
  conversion_sexp Sexplib.Conv.sexp_of_float t

let xml_of_int32 t =
  conversion Int32.to_string t

let xml_of_int64 t =
  conversion Int64.to_string t

let xml_of_nativeint t =
  conversion Nativeint.to_string t

let xml_of_big_int t =
  conversion Big_int.string_of_big_int t

let xml_of_nat t =
  conversion Nat.string_of_nat t

let xml_of_num t =
  conversion Num.string_of_num t

let xml_of_ratio t =
  conversion Ratio.string_of_ratio t

let xml_of_list ~tag xml_of__a t =
  [ create_node ~tag ~body:(List.map ~f:(fun t -> create_node ~tag ~body:(xml_of__a t)) t) ]

let xml_of_option ~tag xml_of__a t =
  match t with
  | None -> []
  | Some t -> [create_node ~tag ~body:(xml_of__a t)]

let xml_of_lazy_t xml_of__a t =
  xml_of__a (Lazy.force_val t)

let xml_of_ref xml_of__a t =
  xml_of__a (!t)

let xml_of_array ~tag xml_of__a t = xml_of_list ~tag xml_of__a (Array.to_list t)

let xsd_conversion base =
  [Xml_light.Xml.Element ("xs:simpleType", [],
    [Xml_light.Xml.Element ("xs:restriction", ["base", "xs:" ^ base], [])])]

type to_xsd = xml list

let xsd_of_unit =
  xsd_conversion "string"

let xsd_of_string =
  xsd_conversion "string"

let xsd_of_char =
  xsd_conversion "string"

let xsd_of_int =
  xsd_conversion "integer"

let xsd_of_float =
  xsd_conversion "decimal"

let xsd_of_int32 =
  xsd_conversion "integer"

let xsd_of_bool =
  let restriction =
    let lst = ["TRUE"; "FALSE"; "true"; "false"; "True"; "False"] in
    Xml_light.Xml.Element ("xs:restriction",
      ["base", Restriction.Format.to_string `string],
      (List.map ~f:Restriction.enumeration lst))
  in
  [Xml_light.Xml.Element ("xs:simpleType", [], [restriction])]

let xsd_of_int64 =
  xsd_conversion "integer"

let xsd_of_nativeint =
  xsd_conversion "integer"

let xsd_of_big_int =
  xsd_conversion "integer"

let complex_type contents =
  Xml_light.Xml.Element ("xs:complexType", [],
    [Xml_light.Xml.Element ("xs:sequence", [], contents)])

let decomplexify xml =
  match xml with
  | [Xml_light.Xml.Element ("xs:complexType", [],
    [Xml_light.Xml.Element ("xs:sequence", [], [contents])])] -> contents
  | _ -> failwith "Not a complex_type"

let decomplexify_opt xml =
  try Some (decomplexify xml)
  with _ -> None

let decomplexify_list xml =
  match xml with
  | [Xml_light.Xml.Element ("xs:complexType", [],
    [Xml_light.Xml.Element ("xs:sequence", [], contents)])] -> Some contents
  | _ -> None

let type_of_simple xml =
  match xml with
  | [Xml_light.Xml.Element ("xs:simpleType", [],
    [Xml_light.Xml.Element ("xs:restriction", ["base", t], children)])] ->
      (match children with
      | [] -> t
      | _ -> (* enumeration values *) if "xs:string" = t then "xs:bool" else
        failwith "Enumeration isn't representing a bool, Bad type")
  | _ -> failwith "Not a simple type"


let xsd_element ?(attr=[]) ~name contents =
  Xml_light.Xml.Element ("xs:element", ("name", name) :: attr, contents)

let xml_element ?(attr=[]) ~name contents =
  Xml_light.Xml.Element (name, attr, contents)

let xsd_of_list' ~attr field_name xsd_of__a =
  let elements =
    [complex_type [xsd_element ~attr ~name:field_name xsd_of__a]]
  in
  [complex_type [xsd_element ~attr:[ "minOccurs", "0"; "maxOccurs", "1" ] ~name:field_name elements]]

let xsd_of_list field_name xsd_of__a =
  let attr = [ "minOccurs", "0"; "maxOccurs", "unbounded" ] in
  xsd_of_list' ~attr field_name xsd_of__a

let xsd_of_array = xsd_of_list

let xsd_of_nat =
  xsd_conversion "integer"

let xsd_of_num =
  xsd_conversion "decimal"

let xsd_of_ratio =
  xsd_conversion "decimal"

let xsd_of_ref xsd_of__a =
  xsd_of__a

let xsd_of_lazy_t xsd_of__a =
  xsd_of__a

let xsd_of_option field_name xsd_of__a =
  let attr = [ "minOccurs", "0"; "maxOccurs", "1" ] in
  [complex_type [xsd_element ~attr ~name:field_name xsd_of__a]]

module type X = sig
  type t
  val add_string : t -> string -> unit
end
module Write(X:X) = struct
  module Y = struct
    include X
    let string_of_char =
      let memo = Array.init 256 ~f:(fun code -> String.make 1 (Char.of_int_exn code)) in
      (fun char -> memo.(Char.to_int char))
    let add_char t char =
      add_string t (string_of_char char)
  end
  include Xml_light.Xml.Make(Y)
end