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 t -> sprintf "delete_%s_%u" (String.concat "_" @@ List.map fix t) index
  63   | Alter t -> sprintf "alter_%s_%u" (String.concat "_" @@ List.map fix t) index
  64   | Drop t -> sprintf "drop_%s" (fix t)
  65   | Select _  -> sprintf "select_%u" index
  66   | CreateRoutine s -> sprintf "create_routine_%s" (fix' s)
  67   | Other -> sprintf "statement_%u" index
  68   in
  69   make_name props name
  70
  71 type sql = Static of string | Dynamic of (Sql.param_id * (Sql.param_id * Sql.var list option * sql list) list) | SubstIn of Sql.param
  72
  73 let substitute_vars s vars subst_param =
  74   let rec loop acc i parami vars =
  75     match vars with
  76     | [] -> acc, i
  77     | Sql.Single param :: tl ->
  78       let (i1,i2) = param.id.pos in
  79       assert (i2 > i1);
  80       assert (i1 > i);
  81       let acc, parami =
  82         match subst_param with
  83         | None -> Static (String.slice ~first:i ~last:i2 s) :: acc, parami
  84         | Some subst ->
  85           Static (subst parami param) ::
  86           Static (String.slice ~first:i ~last:i1 s) ::
  87           acc,
  88           parami + 1
  89       in
  90       loop acc i2 parami tl
  91     | SingleIn param :: tl ->
  92       let (i1,i2) = param.id.pos in
  93       assert (i2 > i1);
  94       assert (i1 > i);
  95       let acc = SubstIn param :: Static (String.slice ~first:i ~last:i1 s) :: acc in
  96       loop acc i2 parami tl
  97     | Choice (name,ctors) :: tl ->
  98       let dyn = ctors |> List.map begin function
  99         | Sql.Simple (ctor,args) ->
 100           let (c1,c2) = ctor.pos in
 101           assert ((c2 = 0 && c1 = 1) || c2 > c1);
 102           assert (c1 > i);
 103           let pieces =
 104             match args with
 105             | None -> [Static ""]
 106             | Some l ->
 107               let (acc,last) = loop [] c1 0 l in
 108               List.rev (Static (String.slice ~first:last ~last:c2 s) :: acc)
 109           in
 110           ctor, args, pieces
 111         | Verbatim (n,v) -> { label = Some n; pos = (0,0) }, Some [], [Static v]
 112         end
 113       in
 114       let (i1,i2) = name.pos in
 115       assert (i2 > i1);
 116       assert (i1 > i);
 117       let acc = Dynamic (name, dyn) :: Static (String.slice ~first:i ~last:i1 s) :: acc in
 118       loop acc i2 parami tl
 119   in
 120   let (acc,last) = loop [] 0 0 vars in
 121   let acc = List.rev (Static (String.slice ~first:last s) :: acc) in
 122   let rec squash acc = function
 123   | [] -> List.rev acc
 124   | Static s1 :: Static s2 :: tl -> squash acc (Static (s1 ^ s2) :: tl)
 125   | x::xs -> squash (x::acc) xs
 126   in
 127   squash [] acc
 128
 129 let subst_named index p = "@" ^ (show_param_name p index)
 130 let subst_oracle index p = ":" ^ (show_param_name p index)
 131 let subst_postgresql index _ = "$" ^ string_of_int (index + 1)
 132 let subst_unnamed _ _ = "?"
 133
 134 let get_sql stmt =
 135   let sql = Props.get stmt.props "sql" |> Option.get in
 136   let subst =
 137     match !params_mode with
 138     | None -> None
 139     | Some subst ->
 140       Some (match subst with
 141       | Named -> subst_named
 142       | Unnamed -> subst_unnamed
 143       | Oracle -> subst_oracle
 144       | PostgreSQL -> subst_postgresql)
 145   in
 146   substitute_vars sql stmt.vars subst
 147
 148 let get_sql_string_only stmt =
 149   match get_sql stmt with
 150   | Static s :: [] -> s
 151   | _ -> fail "dynamic choices not supported for this language"
 152
 153 let time_string () =
 154   let module U = Unix in
 155   let t = U.time () |> U.gmtime in
 156   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
 157
 158 module type LangTypes = sig
 159
 160 val as_api_type : Sql.Type.t -> string
 161 val as_lang_type : Sql.Type.t -> string
 162
 163 end
 164
 165 let is_param_nullable param =
 166   let open Sql in
 167   match param.attr with None -> false | Some attr -> Constraints.mem Null attr.extra || Constraints.mem Autoincrement attr.extra
 168
 169 let is_attr_nullable attr =
 170   let open Sql in
 171   Constraints.mem Null attr.extra
 172
 173 type value = { vname : string; vtyp : string; nullable : bool; }
 174
 175 module Translate(T : LangTypes) = struct
 176
 177 let show_param_type p = T.as_api_type p.Sql.typ
 178 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 })
 179 (* let schema_to_string = G.Values.to_string $ schema_to_values  *)
 180 let all_params_to_values l =
 181   l |> List.mapi (fun i p -> { vname = show_param_name p i; vtyp = T.as_lang_type p.typ; nullable = is_param_nullable p; })
 182   |> List.unique ~cmp:(fun v1 v2 -> String.equal v1.vname v2.vname)
 183 (* rev unique rev -- to preserve ordering with respect to first occurrences *)
 184 let values_of_params = List.rev $ List.unique ~cmp:(=) $ List.rev $ all_params_to_values
 185 let names_of_vars l =
 186   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
 187
 188 let params_only =
 189   List.filter_map
 190     (function
 191       | Sql.Single p -> Some p
 192       | SingleIn _ -> None
 193       | Choice _ -> fail "dynamic choices not supported for this host language")
 194
 195 let inparams_only =
 196   List.filter_map
 197     (function
 198       | Sql.SingleIn p -> Some p
 199       | _ -> None)
 200
 201 end
 202
 203 module type Generator = sig
 204   type t
 205   val generate : t -> string -> stmt list -> unit
 206   val start : unit -> t
 207   val comment : t -> ('a,unit,string,unit) format4 -> 'a
 208   val empty_line : t -> unit
 209 end
 210
 211 module Make(S : Generator) = struct
 212
 213 let generate_header out mode =
 214   S.comment out "DO NOT EDIT MANUALLY";
 215   S.comment out "";
 216   let time_str =
 217     match mode with
 218     | `Full -> " on " ^ time_string ()
 219     | `Without_timestamp -> ""
 220   in
 221   S.comment out "generated by sqlgg %s%s" Sqlgg_config.version time_str;
 222   S.empty_line out
 223
 224 let process name stmts =
 225   let out = S.start () in
 226   Option.may (generate_header out) !Sqlgg_config.gen_header;
 227   S.generate out name stmts
 228
 229 end