src/gen_caml.ml

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