gen_caml.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 let inline_values = String.concat " "
  13
  14 let quote = String.replace_chars (function '\n' -> "\\n\\\n" | '\r' -> "" | '"' -> "\\\"" | c -> String.make 1 c)
  15 let quote s = "\"" ^ quote s ^ "\""
  16
  17 let rec replace_all ~str ~sub ~by =
  18   match String.replace ~str ~sub ~by with
  19   | (true,s) -> replace_all ~str:s ~sub ~by
  20   | (false,s) -> s
  21
  22 let quote_comment_inline str =
  23   let str = replace_all ~str ~sub:"*)" ~by:"* )" in
  24   replace_all ~str ~sub:"(*" ~by:"( *"
  25
  26 let make_comment str = "(* " ^ (quote_comment_inline str) ^ " *)"
  27 let comment () fmt = Printf.kprintf (indent_endline & make_comment) fmt
  28
  29 let empty_line () = print_newline ()
  30
  31 let get_column attr index =
  32   output "(T.get_column_%s stmt %u)"
  33     (Type.to_string attr.RA.domain)
  34     index
  35
  36 let param_type_to_string t = Option.map_default Type.to_string "Any" t
  37
  38 let set_param index param =
  39   let (id,t) = param in
  40   output "T.set_param_%s stmt %u %s;"
  41     (param_type_to_string t)
  42     index
  43     (param_name_to_string id index)
  44
  45 let output_schema_binder index schema =
  46   let name = "invoke_callback" in
  47   output "let %s stmt =" name;
  48   inc_indent ();
  49   output "callback";
  50   inc_indent ();
  51   List.iteri (fun index attr -> get_column attr index) schema;
  52   dec_indent ();
  53   dec_indent ();
  54   output "in";
  55   name
  56
  57 let output_schema_binder index schema =
  58   match schema with
  59   | [] -> None
  60   | _ -> Some (output_schema_binder index schema)
  61
  62 let params_to_values = List.mapi (fun i (n,_) -> param_name_to_string n i)
  63 let params_to_values = List.unique & params_to_values
  64
  65 let output_params_binder index params =
  66   output "let set_params stmt =";
  67   inc_indent ();
  68   List.iteri set_param params;
  69   output "()";
  70   dec_indent ();
  71   output "in";
  72   "set_params"
  73
  74 let output_params_binder index params =
  75   match params with
  76   | [] -> "(fun _ -> ())"
  77   | _ -> output_params_binder index params
  78
  79 let prepend prefix = function s -> prefix ^ s
  80
  81 type t = unit
  82
  83 let start () = ()
  84
  85 let generate_code () index schema params kind props =
  86   let name = choose_name props kind index >> String.uncapitalize in
  87   let values = params_to_values params >> List.map (prepend "~") >> inline_values in
  88   let all_params = match schema with [] -> values | _ -> "callback " ^ values in
  89   output "let %s db %s =" name all_params;
  90   inc_indent ();
  91   let sql = quote (get_sql props kind params) in
  92   let schema_binder_name = output_schema_binder index schema in
  93   let params_binder_name = output_params_binder index params in
  94   begin match schema_binder_name with
  95   | None ->
  96       output "T.execute db %s %s" sql params_binder_name
  97   | Some schema_binder_name ->
  98       output "T.select db %s %s %s" sql schema_binder_name params_binder_name
  99   end;
 100   dec_indent ();
 101   empty_line ()
 102
 103 let start_output () name =
 104   output "module %s (T : Sqlgg_traits.M) = struct" (String.capitalize name);
 105   empty_line ();
 106   inc_indent ()
 107
 108 let finish_output () name =
 109   dec_indent ();
 110   output "end (* module %s *)" (String.capitalize name)
 111