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   let attrs =
  67     match stmt.kind with
  68     | Select `Nat      -> ["kind", "select"; "cardinality", "n"]
  69     | Select `Zero_one -> ["kind", "select"; "cardinality", "0,1"]
  70     | Select `One      -> ["kind", "select"; "cardinality", "1"]
  71     | Insert (_, t)    -> ["kind", "insert"; "target", t; "cardinality", "0"]
  72     | Create t         -> ["kind", "create"; "target", t; "cardinality", "0"]
  73     | CreateIndex t    -> ["kind", "create_index"; "target",t;"cardinality","0"]
  74     | Update None      -> ["kind", "update"; "cardinality", "0"]
  75     | Update (Some t)  -> ["kind", "update"; "target", t; "cardinality", "0"]
  76     | Delete t         -> ["kind", "delete"; "target", t; "cardinality", "0"]
  77     | Alter t          -> ["kind", "alter"; "target", t; "cardinality", "0"]
  78     | Drop t           -> ["kind", "drop"; "target", t; "cardinality", "0"]
  79     | Other            -> [] in
  80   x := Node ("stmt", ("name",name)::("sql",sql)::attrs, [input; output]) :: !x
  81
  82 let start_output (x,pre) = pre := !x; x := []
  83
  84 let finish_output (x,pre) =
  85   print_endline "<?xml version=\"1.0\"?>";
  86   List.iter (fun z -> z |> xml_to_string |> print_endline) (List.rev !pre);
  87   Node ("sqlgg",[],List.rev !x) |> xml_to_string |> print_endline;
  88   x := [];
  89   pre := []
  90
  91 let generate out _ stmts =
  92   start_output out;
  93   List.iteri (generate_code out) stmts;
  94   finish_output out