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 get_column attr index =
  30   output "(T.get_column_%s stmt %u)"
  31     (Type.to_string attr.RA.domain)
  32     index
  33
  34 let param_type_to_string t = Option.map_default Type.to_string "Any" t
  35
  36 let set_param index param =
  37   let (id,t) = param in
  38   output "T.set_param_%s stmt %u %s;"
  39     (param_type_to_string t)
  40     index
  41     (param_name_to_string id index)
  42
  43 let output_scheme_binder index scheme =
  44   let name = "invoke_callback" in
  45   output "let %s stmt =" name;
  46   inc_indent ();
  47   output "callback";
  48   inc_indent ();
  49   List.iteri (fun index attr -> get_column attr index) scheme;
  50   dec_indent ();
  51   dec_indent ();
  52   output "in";
  53   name
  54
  55 let output_scheme_binder index scheme =
  56   match scheme with
  57   | [] -> None
  58   | _ -> Some (output_scheme_binder index scheme)
  59
  60 let params_to_values = List.mapi (fun i (n,_) -> param_name_to_string n i)
  61 let params_to_values = List.unique & params_to_values
  62
  63 let output_params_binder index params =
  64   output "let set_params stmt =";
  65   inc_indent ();
  66   List.iteri set_param params;
  67   output "()";
  68   dec_indent ();
  69   output "in";
  70   "set_params"
  71
  72 let output_params_binder index params =
  73   match params with
  74   | [] -> "(fun _ -> ())"
  75   | _ -> output_params_binder index params
  76
  77 let prepend prefix = function s -> prefix ^ s
  78
  79 let generate_code index scheme params kind props =
  80   let name = choose_name props kind index >> String.uncapitalize in
  81   let values = params_to_values params >> List.map (prepend "~") >> inline_values in
  82   let all_params = match scheme with [] -> values | _ -> "callback " ^ values in
  83   output "let %s db %s =" name all_params;
  84   inc_indent ();
  85   let sql = quote (get_sql props kind params) in
  86   let scheme_binder_name = output_scheme_binder index scheme in
  87   let params_binder_name = output_params_binder index params in
  88   begin match scheme_binder_name with
  89   | None ->
  90       output "T.execute db %s %s" sql params_binder_name
  91   | Some scheme_binder_name ->
  92       output "T.select db %s %s %s" sql scheme_binder_name params_binder_name
  93   end;
  94   dec_indent ();
  95   empty_line ()
  96
  97 let start_output () =
  98   output "module Sqlgg (T : Sqlgg_traits.M) = struct";
  99   empty_line ();
 100   inc_indent ()
 101
 102 let finish_output () =
 103   dec_indent ();
 104   output "end (* module Sqlgg *)"
 105