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 open Gen_caml.L
  54 open Gen_caml.T
  55
  56 let params_to_values = List.map (fun (n,t) -> value n t) & all_params_to_values
  57 let schema_to_values = List.map (fun (n,t) -> value n t) & schema_to_values
  58
  59 type t = xml list ref * xml list ref
  60
  61 let start () = ref [], ref []
  62
  63 let generate_code (x,_) index stmt =
  64   let name = choose_name stmt.props stmt.kind index in
  65   let input = Node ("in",[],params_to_values stmt.params) in
  66   let output = Node ("out",[],schema_to_values stmt.schema) in
  67   let sql = get_sql stmt in
  68   x := Node ("stmt",["name",name; "sql",sql;],[input; output]) :: !x
  69
  70 let start_output (x,pre) = pre := !x; x := []
  71
  72 let finish_output (x,pre) =
  73   print_endline "<?xml version=\"1.0\"?>";
  74   List.iter (fun z -> z >> xml_to_string >> print_endline) (List.rev !pre);
  75   Node ("sqlgg",[],List.rev !x) >> xml_to_string >> print_endline;
  76   x := [];
  77   pre := []
  78
  79 let generate out name stmts =
  80   start_output out;
  81   Enum.iteri (generate_code out) stmts;
  82   finish_output out
  83