src/gen_caml.ml

   1 (* OCaml code generation *)
   2
   3 open ExtLib
   4 open Prelude
   5 open Printf
   6
   7 open Stmt
   8 open Gen
   9 open Sql
  10
  11 let inline_values = String.concat " "
  12
  13 let quote = String.replace_chars (function '\n' -> "\\n\\\n" | '\r' -> "" | '"' -> "\\\"" | c -> String.make 1 c)
  14 let quote s = "\"" ^ quote s ^ "\""
  15
  16 let rec replace_all ~str ~sub ~by =
  17   match String.replace ~str ~sub ~by with
  18   | (true,s) -> replace_all ~str:s ~sub ~by
  19   | (false,s) -> s
  20
  21 let quote_comment_inline str =
  22   let str = replace_all ~str ~sub:"*)" ~by:"* )" in
  23   replace_all ~str ~sub:"(*" ~by:"( *"
  24
  25 let make_comment str = "(* " ^ (quote_comment_inline str) ^ " *)"
  26 let comment () fmt = Printf.kprintf (indent_endline $ make_comment) fmt
  27
  28 let empty_line () = print_newline ()
  29
  30 module L = struct
  31   let as_lang_type = function
  32   | Type.Blob -> Type.to_string Type.Text
  33   | t -> Type.to_string t
  34
  35   let as_api_type = as_lang_type
  36 end
  37
  38 let get_column index attr =
  39   sprintf "(T.get_column_%s stmt %u)"
  40     (L.as_lang_type attr.RA.domain)
  41     index
  42
  43 module T = Translate(L)
  44
  45 open L
  46 open T
  47
  48 let output_schema_binder _ schema =
  49   let name = "invoke_callback" in
  50   output "let %s stmt =" name;
  51   indented (fun () ->
  52     output "callback";
  53     indented (fun () ->
  54       List.iteri (fun i a -> output "%s" (get_column i a)) schema));
  55   output "in";
  56   name
  57
  58 let output_select1_cb _ schema =
  59   let name = "get_row" in
  60   output "let %s stmt =" name;
  61   indented (fun () ->
  62     List.mapi get_column schema >> String.concat ", " >> indent_endline);
  63   output "in";
  64   name
  65
  66 let output_schema_binder index schema kind =
  67   match schema with
  68   | [] -> "execute",""
  69   | _ -> match kind with
  70          | Select true -> "select1", output_select1_cb index schema
  71          | _ -> "select",output_schema_binder index schema
  72
  73 let is_callback stmt =
  74   match stmt.schema, stmt.kind with
  75   | [],_ -> false
  76   | _,Select true -> false
  77   | _ -> true
  78
  79 let params_to_values = List.map fst $ params_to_values
  80
  81 let set_param index param =
  82   let (id,t) = param in
  83   output "T.set_param_%s p %u %s;"
  84     (param_type_to_string t)
  85     index
  86     (param_name_to_string id index)
  87
  88 let output_params_binder _ params =
  89   output "let set_params stmt =";
  90   inc_indent ();
  91   output "let p = T.start_params stmt %u in" (List.length params);
  92   List.iteri set_param params;
  93   output "T.finish_params p";
  94   dec_indent ();
  95   output "in";
  96   "set_params"
  97
  98 let output_params_binder index params =
  99   match params with
 100   | [] -> "T.no_params"
 101   | _ -> output_params_binder index params
 102
 103 let prepend prefix = function s -> prefix ^ s
 104
 105 type t = unit
 106
 107 let start () = ()
 108
 109 let generate_stmt fold index stmt =
 110   let name = choose_name stmt.props stmt.kind index >> String.uncapitalize in
 111   let subst = Props.get stmt.props "subst" in
 112   let values = ((match subst with None -> [] | Some x -> [x]) @ params_to_values stmt.params) >> List.map (prepend "~") >> inline_values in
 113   let fold = fold && is_callback stmt in
 114   let all_params = values ^ (if is_callback stmt then " callback" else "") ^ (if fold then " acc" else "") in
 115   output "let %s db %s =" name all_params;
 116   inc_indent ();
 117   let sql = quote (get_sql stmt) in
 118   let sql = match subst with
 119   | None -> sql
 120   | Some var ->
 121     output "let __sqlgg_sql =";
 122     output "  let replace_all ~str ~sub ~by =";
 123     output "    let rec loop str = match ExtString.String.replace ~str ~sub ~by with";
 124     output "    | true, str -> loop str";
 125     output "    | false, s -> s";
 126     output "    in loop str";
 127     output "  in";
 128     output "  let sql = %s in" sql;
 129     output "  replace_all ~str:sql ~sub:(\"%%%%%s%%%%\") ~by:%s" var var;
 130     output "in";
 131     "__sqlgg_sql"
 132   in
 133   let (func,callback) = output_schema_binder index stmt.schema stmt.kind in
 134   let params_binder_name = output_params_binder index stmt.params in
 135   if fold then output "let r_acc = ref acc in";
 136   output "T.%s db %s %s %s" func sql params_binder_name
 137     (if fold then "(fun x -> r_acc := " ^ callback ^ " x !r_acc);" else callback);
 138   if fold then output "!r_acc";
 139   dec_indent ();
 140   empty_line ()
 141
 142 let generate () name stmts =
 143 (*
 144   let types =
 145     String.concat " and " (List.map (fun s -> sprintf "%s = T.%s" s s) ["num";"text";"any"])
 146   in
 147 *)
 148   output "module %s (T : Sqlgg_traits.M) = struct" (String.capitalize name);
 149   empty_line ();
 150   inc_indent ();
 151   Enum.iteri (generate_stmt false) (Enum.clone stmts);
 152   output "module Fold = struct";
 153   inc_indent ();
 154   Enum.iteri (generate_stmt true) (Enum.clone stmts);
 155   dec_indent ();
 156   output "end (* module Fold *)";
 157   dec_indent ();
 158   output "end (* module %s *)" (String.capitalize name)
 159