src/gen_caml.ml

   1 (* OCaml code generation *)
   2
   3 open Printf
   4 open ExtLib
   5 open Sqlgg
   6 open Prelude
   7
   8 open Gen
   9 open Sql
  10
  11 module Name = struct
  12
  13 (* http://caml.inria.fr/pub/docs/manual-ocaml-4.07/manual049.html *)
  14 let reserved = [
  15 "and";
  16 "as";
  17 "asr";
  18 "assert";
  19 "begin";
  20 "class";
  21 "constraint";
  22 "do";
  23 "done";
  24 "downto";
  25 "else";
  26 "end";
  27 "exception";
  28 "external";
  29 "false";
  30 "for";
  31 "fun";
  32 "function";
  33 "functor";
  34 "if";
  35 "in";
  36 "include";
  37 "inherit";
  38 "initializer";
  39 "land";
  40 "lazy";
  41 "let";
  42 "lor";
  43 "lsl";
  44 "lsr";
  45 "lxor";
  46 "match";
  47 "method";
  48 "mod";
  49 "module";
  50 "mutable";
  51 "new";
  52 "nonrec";
  53 "object";
  54 "of";
  55 "open!";
  56 "open";
  57 "or";
  58 "private";
  59 "rec";
  60 "sig";
  61 "struct";
  62 "then";
  63 "to";
  64 "true";
  65 "try";
  66 "type";
  67 "val";
  68 "virtual";
  69 "when";
  70 "while";
  71 "with";
  72 ]
  73
  74 let ident ~prefix name =
  75   assert (prefix <> "");
  76   match name with
  77   | "" -> prefix
  78   | _ ->
  79   if List.mem name reserved then
  80     name ^ "_"
  81   else
  82     let name = String.map (function ('a'..'z' | 'A'..'Z' | '0'..'9' as c) -> c | _ -> '_') name in
  83     match name.[0] with
  84     | '0'..'9' | '_' -> prefix ^ name
  85     | _ -> String.uncapitalize_ascii name
  86
  87 let idents ~prefix l =
  88   let rec choose acc base n =
  89     let name = sprintf "%s%d" base n in
  90     if List.mem name acc then choose acc base (n+1) else name
  91   in
  92   let rec loop acc = function
  93   | [] -> List.rev acc
  94   | x::xs ->
  95     let x = ident ~prefix x in
  96     let x = if List.mem x acc then choose acc x 0 else x in
  97     loop (x::acc) xs
  98   in
  99   loop [] l
 100
 101 end
 102
 103 let inline_values = String.concat " "
 104
 105 let quote = String.replace_chars (function '\n' -> "\\n\\\n" | '\r' -> "" | '"' -> "\\\"" | c -> String.make 1 c)
 106 let quote s = "\"" ^ quote s ^ "\""
 107
 108 let rec replace_all ~str ~sub ~by =
 109   match String.replace ~str ~sub ~by with
 110   | (true,s) -> replace_all ~str:s ~sub ~by
 111   | (false,s) -> s
 112
 113 let quote_comment_inline str =
 114   let str = replace_all ~str ~sub:"*)" ~by:"* )" in
 115   replace_all ~str ~sub:"(*" ~by:"( *"
 116
 117 let make_comment str = "(* " ^ (quote_comment_inline str) ^ " *)"
 118 let comment () fmt = Printf.kprintf (indent_endline $ make_comment) fmt
 119
 120 let empty_line () = print_newline ()
 121
 122 module L = struct
 123   let as_lang_type = function
 124   | Type.Blob -> Type.to_string Type.Text
 125   | t -> Type.to_string t
 126
 127   let as_api_type = as_lang_type
 128 end
 129
 130 let get_column index attr =
 131   sprintf "(T.get_column_%s%s stmt %u)"
 132     (L.as_lang_type attr.domain)
 133     (if is_attr_nullable attr then "_nullable" else "")
 134     index
 135
 136 module T = Translate(L)
 137
 138 (* open L *)
 139 open T
 140
 141 let output_schema_binder _ schema =
 142   let name = "invoke_callback" in
 143   output "let %s stmt =" name;
 144   let args = Name.idents ~prefix:"r" (List.map (fun a -> a.name) schema) in
 145   let values = List.mapi get_column schema in
 146   indented (fun () ->
 147     output "callback";
 148     indented (fun () -> List.iter2 (output "~%s:%s") args values));
 149   output "in";
 150   name
 151
 152 let output_select1_cb _ schema =
 153   let name = "get_row" in
 154   output "let %s stmt =" name;
 155   indented (fun () ->
 156     List.mapi get_column schema |> String.concat ", " |> indent_endline);
 157   output "in";
 158   name
 159
 160 let output_schema_binder index schema kind =
 161   match schema with
 162   | [] -> "execute",""
 163   | _ -> match kind with
 164          | Stmt.Select `Zero_one -> "select_one_maybe", output_select1_cb index schema
 165          | Select `One -> "select_one", output_select1_cb index schema
 166          | _ -> "select",output_schema_binder index schema
 167
 168 let is_callback stmt =
 169   match stmt.schema, stmt.kind with
 170   | [],_ -> false
 171   | _, Stmt.Select (`Zero_one | `One) -> false
 172   | _ -> true
 173
 174 let list_separate f l =
 175   let a = ref [] in
 176   let b = ref [] in
 177   List.iter (fun x -> match f x with `Left x -> tuck a x | `Right x -> tuck b x) l;
 178   List.rev !a, List.rev !b
 179
 180 let make_variant_name i name =
 181   "`" ^ match name with
 182   | None -> sprintf "V_%d" i
 183   | Some n -> String.capitalize_ascii n
 184
 185 let vname n = make_variant_name 0 (Some n)
 186
 187 let match_variant_wildcard i name args =
 188   sprintf "%s%s" (make_variant_name i name) (match args with Some [] | None -> "" | Some _ -> " _")
 189
 190 let set_param index param =
 191   let nullable = is_param_nullable param in
 192   let pname = show_param_name param index in
 193   let ptype = show_param_type param in
 194   if nullable then
 195     output "begin match %s with None -> T.set_param_null p | Some v -> T.set_param_%s p v end;" pname ptype
 196   else
 197     output "T.set_param_%s p %s;" ptype pname
 198
 199 let rec set_var index var =
 200   match var with
 201   | Single p -> set_param index p
 202   | SingleIn _ -> ()
 203   | Choice (name,ctors) ->
 204     output "begin match %s with " (make_param_name index name);
 205     ctors |> List.iteri begin fun i ctor ->
 206       match ctor with
 207       | Simple (param,args) ->
 208         output "| %s%s -> %s"
 209           (make_variant_name i param.label)
 210           (match args with Some [] | None -> "" | Some l -> " ("^String.concat "," (names_of_vars l)^")")
 211           (match args with Some [] | None -> "()" | Some _ -> "");
 212         inc_indent ();
 213         List.iter (set_var index) (Option.default [] args);
 214         dec_indent ()
 215       | Verbatim (n,_) -> output "| %s -> ()" (vname n)
 216     end;
 217     output "end;"
 218
 219 let rec eval_count_params vars =
 220   let (static,choices) = list_separate (function Single _ -> `Left true | SingleIn _ -> `Left false | Choice (name,c) -> `Right (name, c)) vars in
 221   string_of_int (List.length @@ List.filter (fun x -> x) static) ^
 222   match choices with
 223   | [] -> ""
 224   | _ ->
 225   choices |> List.mapi begin fun i (name,ctors) ->
 226     sprintf " + (match %s with " (make_param_name i name) ^
 227     (ctors |> List.mapi (fun i ctor ->
 228       match ctor with
 229       | Verbatim (n,_) -> sprintf "%s -> 0" (vname n)
 230       | Simple (param,args) -> sprintf "%s -> %s" (match_variant_wildcard i param.label args) (eval_count_params @@ Option.default [] args)) |> String.concat " | ")
 231     ^ ")"
 232   end |> String.concat ""
 233
 234 let output_params_binder _ vars =
 235   output "let set_params stmt =";
 236   inc_indent ();
 237   output "let p = T.start_params stmt (%s) in" (eval_count_params vars);
 238   List.iteri set_var vars;
 239   output "T.finish_params p";
 240   dec_indent ();
 241   output "in";
 242   "set_params"
 243
 244 let rec exclude_in_vars l =
 245   List.filter_map
 246     (function
 247       | SingleIn _ -> None
 248       | Single _ as v -> Some v
 249       | Choice (param_id, ctors) ->
 250         Some (Choice (param_id, List.map exclude_in_vars_in_constructors ctors)))
 251     l
 252
 253 and exclude_in_vars_in_constructors = function
 254   | Verbatim _ as ctor -> ctor
 255   | Simple (param_id, vars) -> Simple (param_id, Option.map exclude_in_vars vars)
 256
 257 let output_params_binder index vars =
 258   match exclude_in_vars vars with
 259   | [] -> "T.no_params"
 260   | vars -> output_params_binder index vars
 261
 262 let prepend prefix = function s -> prefix ^ s
 263
 264 let in_var_module _label typ = Sql.Type.to_string typ
 265
 266 let gen_in_substitution var =
 267   if Option.is_none var.id.label then failwith "empty label in IN param";
 268   sprintf {code| "(" ^ String.concat ", " (List.map T.Types.%s.to_literal %s) ^ ")"|code}
 269     (in_var_module (Option.get var.id.label) var.typ)
 270     (Option.get var.id.label)
 271
 272 let make_sql l =
 273   let b = Buffer.create 100 in
 274   let rec loop app = function
 275     | [] -> ()
 276     | Static "" :: tl when app -> loop app tl
 277     | Static s :: tl ->
 278       if app then bprintf b " ^ ";
 279       Buffer.add_string b (quote s);
 280       loop true tl
 281     | SubstIn param :: tl ->
 282       if app then bprintf b " ^ ";
 283       Buffer.add_string b (gen_in_substitution param);
 284       loop true tl
 285     | Dynamic (name, ctors) :: tl ->
 286       if app then bprintf b " ^ ";
 287       bprintf b "(match %s with" (make_param_name 0 name);
 288       ctors |> List.iteri (fun i (name,args,l) -> bprintf b " %s%s -> " (if i = 0 then "" else "| ") (match_variant_wildcard i name.label args); loop false l);
 289       bprintf b ")";
 290       loop true tl
 291   in
 292   Buffer.add_string b "(";
 293   loop false l;
 294   Buffer.add_string b ")";
 295   Buffer.contents b
 296
 297 let generate_stmt style index stmt =
 298   let name = choose_name stmt.props stmt.kind index |> String.uncapitalize in
 299   let subst = Props.get_all stmt.props "subst" in
 300   let inputs = (subst @ names_of_vars stmt.vars) |> List.map (prepend "~") |> inline_values in
 301   match style, is_callback stmt with
 302   | (`List | `Fold), false -> ()
 303   | _ ->
 304   let all_inputs = inputs ^ (if style = `List || is_callback stmt then " callback" else "") ^ (if style = `Fold then " acc" else "") in
 305   output "let %s db %s =" name all_inputs;
 306   inc_indent ();
 307   let sql = make_sql @@ get_sql stmt in
 308   let sql = match subst with
 309   | [] -> sql
 310   | vars ->
 311     output "let __sqlgg_sql =";
 312     output "  let replace_all ~str ~sub ~by =";
 313     output "    let rec loop str = match ExtString.String.replace ~str ~sub ~by with";
 314     output "    | true, str -> loop str";
 315     output "    | false, s -> s";
 316     output "    in loop str";
 317     output "  in";
 318     output "  let sql = %s in" sql;
 319     List.iter (fun var -> output "  let sql = replace_all ~str:sql ~sub:(\"%%%%%s%%%%\") ~by:%s in" var var) vars;
 320     output "  sql";
 321     output "in";
 322     "__sqlgg_sql"
 323   in
 324   let (func,callback) = output_schema_binder index stmt.schema stmt.kind in
 325   let params_binder_name = output_params_binder index stmt.vars in
 326   if style = `Fold then output "let r_acc = ref acc in";
 327   if style = `List then output "let r_acc = ref [] in";
 328   let (bind, callback) =
 329     match style with
 330     | `Fold -> "IO.(>>=) (", sprintf "(fun x -> r_acc := %s x !r_acc))" callback
 331     | `List -> "IO.(>>=) (", sprintf "(fun x -> r_acc := %s x :: !r_acc))" callback
 332     | `Direct -> "", callback (* or empty string *)
 333   in
 334   output "%sT.%s db %s %s %s" bind func sql params_binder_name callback;
 335   if style = `Fold then output "(fun () -> IO.return !r_acc)";
 336   if style = `List then output "(fun () -> IO.return (List.rev !r_acc))";
 337   dec_indent ();
 338   empty_line ()
 339
 340 let generate ~gen_io name stmts =
 341 (*
 342   let types =
 343     String.concat " and " (List.map (fun s -> sprintf "%s = T.%s" s s) ["num";"text";"any"])
 344   in
 345 *)
 346   let (traits, io) =
 347     match gen_io with
 348     | true -> "Sqlgg_traits.M_io", "T.IO"
 349     | false -> "Sqlgg_traits.M", "Sqlgg_io.Blocking"
 350   in
 351   output "module %s (T : %s) = struct" (String.capitalize name) traits;
 352   empty_line ();
 353   inc_indent ();
 354   output "module IO = %s" io;
 355   empty_line ();
 356   List.iteri (generate_stmt `Direct) stmts;
 357   output "module Fold = struct";
 358   inc_indent ();
 359   List.iteri (generate_stmt `Fold) stmts;
 360   dec_indent ();
 361   output "end (* module Fold *)";
 362   output "";
 363   output "module List = struct";
 364   inc_indent ();
 365   List.iteri (generate_stmt `List) stmts;
 366   dec_indent ();
 367   output "end (* module List *)";
 368   dec_indent ();
 369   output "end (* module %s *)" (String.capitalize name)
 370
 371 module Generator_base = struct
 372
 373   type t = unit
 374
 375   let start () = ()
 376
 377   let comment = comment
 378
 379   let empty_line = empty_line
 380 end
 381
 382 module Generator = struct
 383   include Generator_base
 384   let generate () name stmts = generate ~gen_io:false name stmts
 385 end
 386
 387 module Generator_io = struct
 388   include Generator_base
 389   let generate () name stmts = generate ~gen_io:true name stmts
 390 end