gen_xml.ml

   1 (* OCaml code 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 indent = ref 0 in *)
  31   let rec fold = function
  32     | Node (name,attrs,children) ->
  33         bprintf b "\n<%s" name;
  34         List.iter (fun (n,v) -> bprintf b " %s=\"%s\"" n (xml_escape v)) attrs;
  35         begin match children with
  36         | [] -> bprintf b "/>"
  37         | _ -> bprintf b ">"; List.iter fold children; bprintf b "</%s>" name
  38         end
  39     | Comment text -> bprintf b "\n<!-- %s -->" (Gen_caml.replace_all ~str:text ~sub:"--" ~by:"&mdash;")
  40   in
  41   fold xml;
  42   Buffer.contents b
  43
  44 (*
  45 let _ =
  46   Node ("test",["name","d\"s&quot;ds"],[]) >> xml_to_string >> print_endline
  47 *)
  48
  49 let comment (x,_) fmt = Printf.ksprintf (fun s -> x := Comment s :: !x) fmt
  50 let empty_line _ = ()
  51
  52 let value n t = Node ("value",["name",n; "type",t;],[])
  53
  54 let param_type_to_string t = Option.map_default Type.to_string "Any" t
  55 let params_to_values = List.mapi (fun i (n,t) -> value (param_name_to_string n i) (param_type_to_string t))
  56 let params_to_values = List.unique & params_to_values
  57
  58 let scheme_to_values = List.map (fun attr -> value attr.RA.name (Type.to_string attr.RA.domain))
  59
  60 type t = xml list ref * xml list ref
  61
  62 let start () = ref [], ref []
  63
  64 let generate_code (x,_) index scheme params kind props =
  65   let name = choose_name props kind index in
  66   let input = Node ("in",[],params_to_values params) in
  67   let output = Node ("out",[],scheme_to_values scheme) in
  68   let sql = get_sql props kind params in
  69   x := Node ("stmt",["name",name; "sql",sql;],[input; output]) :: !x
  70
  71 let start_output (x,pre) _ = pre := !x; x := []
  72
  73 let finish_output (x,pre) _ =
  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