gen_xml.ml

   1 (** XML generation *)
   2
   3 open ExtList
   4 open ExtString
   5 open Operators
   6 open Printf
   7
   8 open Stmt
   9 open Gen
  10 open Sql
  11
  12 type xml = | Node of (string * (string * string) list * xml list)
  13            | Comment of string
  14
  15 let xml_escape s =
  16   let b = Buffer.create 10 in
  17   let add s = Buffer.add_string b s in
  18   String.iter (function
  19   | '&' -> add "&amp;"
  20   | '"' -> add "&quot;"
  21   | '\n' -> add "&#x0A;"
  22   | '\r' -> ()
  23   | '<' -> add "&lt;"
  24   | '>' -> add "&gt;"
  25   | c -> Buffer.add_char b c) s;
  26   Buffer.contents b
  27
  28 let xml_to_string xml =
  29   let b = Buffer.create 1000 in
  30   let rec iter spaces = function
  31     | Node (name,attrs,children) ->
  32         bprintf b "\n%s<%s" spaces name;
  33         List.iter (fun (n,v) -> bprintf b " %s=\"%s\"" n (xml_escape v)) attrs;
  34         begin match children with
  35         | [] -> bprintf b "/>"
  36         | _ -> bprintf b ">"; List.iter (iter (spaces ^ " ")) children; bprintf b "\n%s</%s>" spaces name
  37         end
  38     | Comment text -> bprintf b "\n<!-- %s -->" (Gen_caml.replace_all ~str:text ~sub:"--" ~by:"&mdash;")
  39   in
  40   iter "" xml;
  41   Buffer.contents b
  42
  43 (*
  44 let _ =
  45   Node ("test",["name","d\"s&quot;ds"],[]) >> xml_to_string >> print_endline
  46 *)
  47
  48 let comment (x,_) fmt = Printf.ksprintf (fun s -> x := Comment s :: !x) fmt
  49 let empty_line _ = ()
  50
  51 let value n t = Node ("value",["name",n; "type",t;],[])
  52
  53 let param_type_to_string t = Option.map_default Type.to_string "Any" t
  54 let params_to_values = List.mapi (fun i (n,t) -> value (param_name_to_string n i) (param_type_to_string t))
  55
  56 let schema_to_values = List.map (fun attr -> value attr.RA.name (Type.to_string attr.RA.domain))
  57
  58 type t = xml list ref * xml list ref
  59
  60 let start () = ref [], ref []
  61
  62 let generate_code (x,_) index stmt =
  63   let name = choose_name stmt.props stmt.kind index in
  64   let input = Node ("in",[],params_to_values stmt.params) in
  65   let output = Node ("out",[],schema_to_values stmt.schema) in
  66   let sql = get_sql stmt in
  67   x := Node ("stmt",["name",name; "sql",sql;],[input; output]) :: !x
  68
  69 let start_output (x,pre) = pre := !x; x := []
  70
  71 let finish_output (x,pre) =
  72   print_endline "<?xml version=\"1.0\"?>";
  73   List.iter (fun z -> z >> xml_to_string >> print_endline) (List.rev !pre);
  74   Node ("sqlgg",[],List.rev !x) >> xml_to_string >> print_endline;
  75   x := [];
  76   pre := []
  77
  78 let generate out name stmts =
  79   start_output out;
  80   Enum.iteri (generate_code out) stmts;
  81   finish_output out
  82