src/gen_xml.ml

   1 (** XML generation *)
   2
   3 open Printf
   4 open ExtLib
   5 open Sqlgg
   6 open Prelude
   7
   8 open Stmt
   9 open Gen
  10
  11 type xml = | Node of (string * (string * string) list * xml list)
  12            | Comment of string
  13
  14 let xml_escape s =
  15   let b = Buffer.create 10 in
  16   let add s = Buffer.add_string b s in
  17   String.iter (function
  18   | '&' -> add "&amp;"
  19   | '"' -> add "&quot;"
  20   | '\n' -> add "&#x0A;"
  21   | '\r' -> ()
  22   | '<' -> add "&lt;"
  23   | '>' -> add "&gt;"
  24   | c -> Buffer.add_char b c) s;
  25   Buffer.contents b
  26
  27 let xml_to_string xml =
  28   let b = Buffer.create 1000 in
  29   let rec iter spaces = function
  30     | Node (name,attrs,children) ->
  31         bprintf b "\n%s<%s" spaces name;
  32         List.iter (fun (n,v) -> bprintf b " %s=\"%s\"" n (xml_escape v)) attrs;
  33         begin match children with
  34         | [] -> bprintf b "/>"
  35         | _ -> bprintf b ">"; List.iter (iter (spaces ^ " ")) children; bprintf b "\n%s</%s>" spaces name
  36         end
  37     | Comment text -> bprintf b "\n<!-- %s -->" (Gen_caml.replace_all ~str:text ~sub:"--" ~by:"&mdash;")
  38   in
  39   iter "" xml;
  40   Buffer.contents b
  41
  42 (*
  43 let _ =
  44   Node ("test",["name","d\"s&quot;ds"],[]) |> xml_to_string |> print_endline
  45 *)
  46
  47 let comment (x,_) fmt = Printf.ksprintf (fun s -> x := Comment s :: !x) fmt
  48 let empty_line _ = ()
  49
  50 let value ?(inparam=false) v = Node ("value",(["name",v.vname; "type",v.vtyp] @ if inparam then ["set","true"] else [] @ if v.nullable then ["nullable","true"] else []),[])
  51
  52 (* open Gen_caml.L *)
  53 open Gen_caml.T
  54
  55 let params_to_values = List.map value $ all_params_to_values
  56 let inparams_to_values = List.map (value ~inparam:true) $ all_params_to_values
  57 let schema_to_values = List.map value $ schema_to_values
  58
  59 type t = xml list ref * xml list ref
  60
  61 let start () = ref [], ref []
  62
  63 let get_sql_string stmt =
  64   let map i = function
  65   | Static s -> s
  66   | SubstIn param -> "@@" ^ show_param_name param i (* TODO join text and prepared params earlier for single indexing *)
  67   | Dynamic _ -> fail "dynamic choice not supported for xml output"
  68   in
  69   String.concat "" @@ List.mapi map @@ get_sql stmt
  70
  71 let generate_code (x,_) index stmt =
  72   let name = choose_name stmt.props stmt.kind index in
  73   let input = Node ("in",[], (params_to_values @@ params_only stmt.vars) @ (inparams_to_values @@ inparams_only stmt.vars)) in
  74   let output = Node ("out",[],schema_to_values stmt.schema) in
  75   let sql = get_sql_string stmt in
  76   let attrs =
  77     match stmt.kind with
  78     | Select `Nat      -> ["kind", "select"; "cardinality", "n"]
  79     | Select `Zero_one -> ["kind", "select"; "cardinality", "0,1"]
  80     | Select `One      -> ["kind", "select"; "cardinality", "1"]
  81     | Insert (_, t)    -> ["kind", "insert"; "target", Sql.show_table_name t; "cardinality", "0"]
  82     | Create t         -> ["kind", "create"; "target", Sql.show_table_name t; "cardinality", "0"]
  83     | CreateIndex t    -> ["kind", "create_index"; "target",t;"cardinality","0"]
  84     | Update None      -> ["kind", "update"; "cardinality", "0"]
  85     | Update (Some t)  -> ["kind", "update"; "target", Sql.show_table_name t; "cardinality", "0"]
  86     | Delete t         -> ["kind", "delete"; "target", String.concat "," @@ List.map Sql.show_table_name t; "cardinality", "0"]
  87     | Alter t          -> ["kind", "alter"; "target", String.concat "," @@ List.map Sql.show_table_name t; "cardinality", "0"]
  88     | Drop t           -> ["kind", "drop"; "target", Sql.show_table_name t; "cardinality", "0"]
  89     | CreateRoutine s  -> ["kind", "create_routine"; "target", s]
  90     | Other            -> ["kind", "other"]
  91   in
  92   let nodes = [ input; output] in
  93   x := Node ("stmt", ("name",name)::("sql",sql)::("category",show_category @@ category_of_stmt_kind stmt.kind)::attrs, nodes) :: !x
  94
  95 let generate_table (x,_) (name,schema) =
  96   x := Node ("table", ["name",Sql.show_table_name name], [Node ("schema",[],schema_to_values schema)]) :: !x
  97
  98 let start_output (x,pre) = pre := !x; x := []
  99
 100 let finish_output (x,pre) =
 101   print_endline "<?xml version=\"1.0\"?>";
 102   List.iter (fun z -> z |> xml_to_string |> print_endline) (List.rev !pre);
 103   Node ("sqlgg",[],List.rev !x) |> xml_to_string |> print_endline;
 104   x := [];
 105   pre := []
 106
 107 let generate out _ stmts =
 108   start_output out;
 109   List.iteri (generate_code out) stmts;
 110   List.iter (generate_table out) (Tables.all ());
 111   finish_output out