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   | SingleText _ -> ()
 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 | SingleText _ -> `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 (fun index v -> set_var index v) 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       | SingleText _ -> 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 make_sql l =
 265   let b = Buffer.create 100 in
 266   let rec loop app = function
 267     | [] -> ()
 268     | Static "" :: tl when app -> loop app tl
 269     | Static s :: tl ->
 270       if app then bprintf b " ^ ";
 271       Buffer.add_string b (quote s);
 272       loop true tl
 273     | Dynamic (name, ctors) :: tl ->
 274       if app then bprintf b " ^ ";
 275       bprintf b "(match %s with" (make_param_name 0 name);
 276       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);
 277       bprintf b ")";
 278       loop true tl
 279   in
 280   Buffer.add_string b "(";
 281   loop false l;
 282   Buffer.add_string b ")";
 283   Buffer.contents b
 284
 285 let in_var_module label = function
 286   | Sql.Type.Tuple _ | Any | Unit _ as typ -> failwith @@ sprintf "invalid IN var type %s in @%s" (Sql.Type.show typ) label
 287   | typ -> Sql.Type.to_string typ
 288
 289 let gen_in_substitution var =
 290   if Option.is_none var.id.label then failwith "empty label in IN param";
 291   match var.typ with
 292   | Sql.Type.Unit _ | Int | Text | Blob | Float | Bool | Datetime | Decimal | Any | Tuple (Any | Tuple _) as typ ->
 293     failwith @@ sprintf "invalid inferred IN var type %s (%s)" (Sql.Type.show typ) (Option.get var.id.label)
 294   | Tuple typ ->
 295     sprintf {code| "(" ^ String.concat ", " (List.map T.Types.%s.to_literal %s) ^ ")"|code}
 296       (in_var_module (Option.get var.id.label) typ)
 297       (Option.get var.id.label)
 298
 299 let generate_stmt style index stmt =
 300   let name = choose_name stmt.props stmt.kind index |> String.uncapitalize in
 301   let subst = Props.get_all stmt.props "subst" in
 302   let inputs = (subst @ names_of_vars stmt.vars) |> List.map (prepend "~") |> inline_values in
 303   let insubst =
 304     List.filter_map
 305       (function
 306         | Single _ | Choice _ -> None
 307         | SingleText p -> Some (`InVar p))
 308       stmt.vars
 309   in
 310   let subst = List.map (fun x -> `Var x) subst @ insubst in
 311   match style, is_callback stmt with
 312   | (`List | `Fold), false -> ()
 313   | _ ->
 314   let all_inputs = inputs ^ (if style = `List || is_callback stmt then " callback" else "") ^ (if style = `Fold then " acc" else "") in
 315   output "let %s db %s =" name all_inputs;
 316   inc_indent ();
 317   let sql = make_sql @@ get_sql stmt in
 318   let sql = match subst with
 319   | [] -> sql
 320   | vars ->
 321     output "let __sqlgg_sql =";
 322     output "  let replace_all ~str ~sub ~by =";
 323     output "    let rec loop str = match ExtString.String.replace ~str ~sub ~by with";
 324     output "    | true, str -> loop str";
 325     output "    | false, s -> s";
 326     output "    in loop str";
 327     output "  in";
 328     output "  let sql = %s in" sql;
 329     List.iter begin function
 330       | `Var var ->
 331         output "  let sql = replace_all ~str:sql ~sub:(\"%%%%%s%%%%\") ~by:%s in" var var;
 332       | `InVar var ->
 333         output "  let sql = replace_all ~str:sql ~sub:(\"@@_sqlgg_%s@@\") ~by:(%s) in"
 334           (match var.id.label with None -> failwith "IN var with no label" | Some label -> label)
 335           (gen_in_substitution var);
 336     end vars;
 337     output "  sql";
 338     output "in";
 339     "__sqlgg_sql"
 340   in
 341   let (func,callback) = output_schema_binder index stmt.schema stmt.kind in
 342   let params_binder_name = output_params_binder index stmt.vars in
 343   if style = `Fold then output "let r_acc = ref acc in";
 344   if style = `List then output "let r_acc = ref [] in";
 345   let (bind, callback) =
 346     match style with
 347     | `Fold -> "IO.(>>=) (", sprintf "(fun x -> r_acc := %s x !r_acc))" callback
 348     | `List -> "IO.(>>=) (", sprintf "(fun x -> r_acc := %s x :: !r_acc))" callback
 349     | `Direct -> "", callback (* or empty string *)
 350   in
 351   output "%sT.%s db %s %s %s" bind func sql params_binder_name callback;
 352   if style = `Fold then output "(fun () -> IO.return !r_acc)";
 353   if style = `List then output "(fun () -> IO.return (List.rev !r_acc))";
 354   dec_indent ();
 355   empty_line ()
 356
 357 let generate ~gen_io name stmts =
 358 (*
 359   let types =
 360     String.concat " and " (List.map (fun s -> sprintf "%s = T.%s" s s) ["num";"text";"any"])
 361   in
 362 *)
 363   let (traits, io) =
 364     match gen_io with
 365     | true -> "Sqlgg_traits.M_io", "T.IO"
 366     | false -> "Sqlgg_traits.M", "Sqlgg_io.Blocking"
 367   in
 368   output "module %s (T : %s) = struct" (String.capitalize name) traits;
 369   empty_line ();
 370   inc_indent ();
 371   output "module IO = %s" io;
 372   empty_line ();
 373   List.iteri (generate_stmt `Direct) stmts;
 374   output "module Fold = struct";
 375   inc_indent ();
 376   List.iteri (generate_stmt `Fold) stmts;
 377   dec_indent ();
 378   output "end (* module Fold *)";
 379   output "";
 380   output "module List = struct";
 381   inc_indent ();
 382   List.iteri (generate_stmt `List) stmts;
 383   dec_indent ();
 384   output "end (* module List *)";
 385   dec_indent ();
 386   output "end (* module %s *)" (String.capitalize name)
 387
 388 module Generator_base = struct
 389
 390   type t = unit
 391
 392   let start () = ()
 393
 394   let comment = comment
 395
 396   let empty_line = empty_line
 397 end
 398
 399 module Generator = struct
 400   include Generator_base
 401   let generate () name stmts = generate ~gen_io:false name stmts
 402 end
 403
 404 module Generator_io = struct
 405   include Generator_base
 406   let generate () name stmts = generate ~gen_io:true name stmts
 407 end