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 module L = struct
  37   let as_lang_type = Type.to_string
  38   let as_api_type = as_lang_type
  39 end
  40
  41 module T = Translate(L)
  42
  43 open L
  44 open T
  45
  46 let set_param index param =
  47   let (id,t) = param in
  48   output "T.set_param_%s stmt %u %s;"
  49     (param_type_to_string t)
  50     index
  51     (param_name_to_string id index)
  52
  53 let output_schema_binder index schema =
  54   let name = "invoke_callback" in
  55   output "let %s stmt =" name;
  56   inc_indent ();
  57   output "callback";
  58   inc_indent ();
  59   List.iteri (fun index attr -> get_column attr index) schema;
  60   dec_indent ();
  61   dec_indent ();
  62   output "in";
  63   name
  64
  65 let output_schema_binder index schema =
  66   match schema with
  67   | [] -> None
  68   | _ -> Some (output_schema_binder index schema)
  69
  70 let params_to_values = List.map fst & params_to_values
  71
  72 let output_params_binder index params =
  73   output "let set_params stmt =";
  74   inc_indent ();
  75   List.iteri set_param params;
  76   output "()";
  77   dec_indent ();
  78   output "in";
  79   "set_params"
  80
  81 let output_params_binder index params =
  82   match params with
  83   | [] -> "(fun _ -> ())"
  84   | _ -> output_params_binder index params
  85
  86 let prepend prefix = function s -> prefix ^ s
  87
  88 type t = unit
  89
  90 let start () = ()
  91
  92 let generate_stmt index stmt =
  93   let name = choose_name stmt.props stmt.kind index >> String.uncapitalize in
  94   let values = params_to_values stmt.params >> List.map (prepend "~") >> inline_values in
  95   let all_params = match stmt.schema with [] -> values | _ -> "callback " ^ values in
  96   output "let %s db %s =" name all_params;
  97   inc_indent ();
  98   let sql = quote (get_sql stmt) in
  99   let schema_binder_name = output_schema_binder index stmt.schema in
 100   let params_binder_name = output_params_binder index stmt.params in
 101   begin match schema_binder_name with
 102   | None ->
 103       output "T.execute db %s %s" sql params_binder_name
 104   | Some schema_binder_name ->
 105       output "T.select db %s %s %s" sql schema_binder_name params_binder_name
 106   end;
 107   dec_indent ();
 108   empty_line ()
 109
 110 let generate () name stmts =
 111   output "module %s (T : Sqlgg_traits.M) = struct" (String.capitalize name);
 112   empty_line ();
 113   inc_indent ();
 114   Enum.iteri generate_stmt stmts;
 115   dec_indent ();
 116   output "end (* module %s *)" (String.capitalize name)
 117