src/gen_xml.ml

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