src/gen.ml

   1 (* Code generation *)
   2
   3 open Printf
   4 open ExtLib
   5 open Sqlgg
   6 open Prelude
   7 open Stmt
   8
   9 type subst_mode = | Named | Unnamed | Oracle | PostgreSQL
  10
  11 type stmt = { schema : Sql.Schema.t; vars : Sql.var list; kind : kind; props : Props.t; }
  12
  13 (** defines substitution function for parameter literals *)
  14 let params_mode = ref None
  15
  16 let (inc_indent,dec_indent,make_indent) =
  17   let v = ref 0 in
  18   (fun () -> v := !v + 2),
  19   (fun () -> v := !v - 2),
  20   (fun () -> String.make !v ' ')
  21
  22 let print_indent () = print_string (make_indent ())
  23 let indent s = print_indent (); print_string s
  24 let indent_endline s = print_indent (); print_endline s
  25 let output fmt = kprintf indent_endline fmt
  26 let output_l = List.iter indent_endline
  27 let print fmt = kprintf print_endline fmt
  28 let indented k = inc_indent (); k (); dec_indent ()
  29
  30 let name_of attr index =
  31   match attr.Sql.name with
  32   | "" -> sprintf "_%u" index
  33   | s -> s
  34
  35 let make_param_name index (p:Sql.param_id) =
  36   match p.label with
  37   | None -> sprintf "_%u" index
  38   | Some s -> s
  39
  40 let show_param_name (p:Sql.param) index = make_param_name index p.id
  41
  42 let make_name props default = Option.default default (Props.get props "name")
  43 let default_name str index = sprintf "%s_%u" str index
  44
  45 let choose_name props kind index =
  46   let safename = String.map begin function
  47   | ('a'..'z' | 'A'..'Z' | '0'..'9' | '_' as c) -> c
  48   | _ -> '_'
  49   end in
  50   let fix' s =
  51     match Props.get props "subst" with
  52     | Some x -> let (_,s) = String.replace ~str:s ~sub:("%%"^x^"%%") ~by:x in safename s
  53     | None -> safename s
  54   in
  55   let fix t = fix' @@ Sql.show_table_name t in
  56   let name = match kind with
  57   | Create t -> sprintf "create_%s" (fix t)
  58   | CreateIndex t -> sprintf "create_index_%s" (fix' t)
  59   | Update (Some t) -> sprintf "update_%s_%u" (fix t) index
  60   | Update None -> sprintf "update_%u" index
  61   | Insert (_,t) -> sprintf "insert_%s_%u" (fix t) index
  62   | Delete (Some t) -> sprintf "delete_%s_%u" (fix t) index
  63   | Delete None -> sprintf "delete_%u" index
  64   | Alter t -> sprintf "alter_%s_%u" (String.concat "_" @@ List.map fix t) index
  65   | Drop t -> sprintf "drop_%s" (fix t)
  66   | Select _  -> sprintf "select_%u" index
  67   | CreateRoutine s -> sprintf "create_routine_%s" (fix' s)
  68   | Other -> sprintf "statement_%u" index
  69   in
  70   make_name props name
  71
  72 type sql = Static of string | Dynamic of (Sql.param_id * (Sql.param_id * Sql.var list option * sql list) list) | SubstIn of Sql.param
  73
  74 let substitute_vars s vars subst_param =
  75   let rec loop acc i parami vars =
  76     match vars with
  77     | [] -> acc, i
  78     | Sql.Single param :: tl ->
  79       let (i1,i2) = param.id.pos in
  80       assert (i2 > i1);
  81       assert (i1 > i);
  82       let acc, parami =
  83         match subst_param with
  84         | None -> Static (String.slice ~first:i ~last:i2 s) :: acc, parami
  85         | Some subst ->
  86           Static (subst parami param) ::
  87           Static (String.slice ~first:i ~last:i1 s) ::
  88           acc,
  89           parami + 1
  90       in
  91       loop acc i2 parami tl
  92     | SingleIn param :: tl ->
  93       let (i1,i2) = param.id.pos in
  94       assert (i2 > i1);
  95       assert (i1 > i);
  96       let acc = SubstIn param :: Static (String.slice ~first:i ~last:i1 s) :: acc in
  97       loop acc i2 parami tl
  98     | Choice (name,ctors) :: tl ->
  99       let dyn = ctors |> List.map begin function
 100         | Sql.Simple (ctor,args) ->
 101           let (c1,c2) = ctor.pos in
 102           assert ((c2 = 0 && c1 = 1) || c2 > c1);
 103           assert (c1 > i);
 104           let pieces =
 105             match args with
 106             | None -> [Static ""]
 107             | Some l ->
 108               let (acc,last) = loop [] c1 0 l in
 109               List.rev (Static (String.slice ~first:last ~last:c2 s) :: acc)
 110           in
 111           ctor, args, pieces
 112         | Verbatim (n,v) -> { label = Some n; pos = (0,0) }, Some [], [Static v]
 113         end
 114       in
 115       let (i1,i2) = name.pos in
 116       assert (i2 > i1);
 117       assert (i1 > i);
 118       let acc = Dynamic (name, dyn) :: Static (String.slice ~first:i ~last:i1 s) :: acc in
 119       loop acc i2 parami tl
 120   in
 121   let (acc,last) = loop [] 0 0 vars in
 122   let acc = List.rev (Static (String.slice ~first:last s) :: acc) in
 123   let rec squash acc = function
 124   | [] -> List.rev acc
 125   | Static s1 :: Static s2 :: tl -> squash acc (Static (s1 ^ s2) :: tl)
 126   | x::xs -> squash (x::acc) xs
 127   in
 128   squash [] acc
 129
 130 let subst_named index p = "@" ^ (show_param_name p index)
 131 let subst_oracle index p = ":" ^ (show_param_name p index)
 132 let subst_postgresql index _ = "$" ^ string_of_int (index + 1)
 133 let subst_unnamed _ _ = "?"
 134
 135 let get_sql stmt =
 136   let sql = Props.get stmt.props "sql" |> Option.get in
 137   let subst =
 138     match !params_mode with
 139     | None -> None
 140     | Some subst ->
 141       Some (match subst with
 142       | Named -> subst_named
 143       | Unnamed -> subst_unnamed
 144       | Oracle -> subst_oracle
 145       | PostgreSQL -> subst_postgresql)
 146   in
 147   substitute_vars sql stmt.vars subst
 148
 149 let get_sql_string_only stmt =
 150   match get_sql stmt with
 151   | Static s :: [] -> s
 152   | _ -> fail "dynamic choices not supported for this language"
 153
 154 let time_string () =
 155   let module U = Unix in
 156   let t = U.time () |> U.gmtime in
 157   sprintf "%04u-%02u-%02uT%02u:%02uZ" (1900 + t.U.tm_year) (t.U.tm_mon+1) t.U.tm_mday t.U.tm_hour t.U.tm_min
 158
 159 module type LangTypes = sig
 160
 161 val as_api_type : Sql.Type.t -> string
 162 val as_lang_type : Sql.Type.t -> string
 163
 164 end
 165
 166 let is_param_nullable param =
 167   let open Sql in
 168   match param.attr with None -> false | Some attr -> Constraints.mem Null attr.extra || Constraints.mem Autoincrement attr.extra
 169
 170 let is_attr_nullable attr =
 171   let open Sql in
 172   Constraints.mem Null attr.extra
 173
 174 type value = { vname : string; vtyp : string; nullable : bool; }
 175
 176 module Translate(T : LangTypes) = struct
 177
 178 let show_param_type p = T.as_api_type p.Sql.typ
 179 let schema_to_values = List.mapi (fun i attr -> { vname = name_of attr i; vtyp = T.as_lang_type attr.Sql.domain; nullable = is_attr_nullable attr })
 180 (* let schema_to_string = G.Values.to_string $ schema_to_values  *)
 181 let all_params_to_values l =
 182   l |> List.mapi (fun i p -> { vname = show_param_name p i; vtyp = T.as_lang_type p.typ; nullable = is_param_nullable p; })
 183   |> List.unique ~cmp:(fun v1 v2 -> String.equal v1.vname v2.vname)
 184 (* rev unique rev -- to preserve ordering with respect to first occurrences *)
 185 let values_of_params = List.rev $ List.unique ~cmp:(=) $ List.rev $ all_params_to_values
 186 let names_of_vars l =
 187   l |> List.mapi (fun i v -> make_param_name i (match v with Sql.Single p | SingleIn p -> p.id | Choice (id,_) -> id)) |> List.unique ~cmp:String.equal
 188
 189 let params_only =
 190   List.filter_map
 191     (function
 192       | Sql.Single p -> Some p
 193       | SingleIn _ -> None
 194       | Choice _ -> fail "dynamic choices not supported for this host language")
 195
 196 let inparams_only =
 197   List.filter_map
 198     (function
 199       | Sql.SingleIn p -> Some p
 200       | _ -> None)
 201
 202 end
 203
 204 module type Generator = sig
 205   type t
 206   val generate : t -> string -> stmt list -> unit
 207   val start : unit -> t
 208   val comment : t -> ('a,unit,string,unit) format4 -> 'a
 209   val empty_line : t -> unit
 210 end
 211
 212 module Make(S : Generator) = struct
 213
 214 let generate_header out mode =
 215   S.comment out "DO NOT EDIT MANUALLY";
 216   S.comment out "";
 217   let time_str =
 218     match mode with
 219     | `Full -> " on " ^ time_string ()
 220     | `Without_timestamp -> ""
 221   in
 222   S.comment out "generated by sqlgg %s%s" Sqlgg_config.version time_str;
 223   S.empty_line out
 224
 225 let process name stmts =
 226   let out = S.start () in
 227   Option.may (generate_header out) !Sqlgg_config.gen_header;
 228   S.generate out name stmts
 229
 230 end