lib/sql.ml

   1 (** *)
   2
   3 open Printf
   4 open ExtLib
   5
   6 module Type =
   7 struct
   8   type t = | Int | Text | Blob | Float | Bool | Datetime | Any
   9     [@@deriving show {with_path=false}]
  10
  11   let to_string = show
  12
  13   let matches x y =
  14     match x,y with
  15     | Any, _ | _, Any -> true
  16     | _ -> x = y
  17
  18   let order x y =
  19     if x = y then
  20       `Equal
  21     else
  22       match x,y with
  23       | Any, t | t, Any -> `Order (t, Any)
  24       | Int, Float | Float, Int -> `Order (Int,Float)
  25       | Text, Blob | Blob, Text -> `Order (Text,Blob)
  26       | _ -> `No
  27
  28   let common_type f x y =
  29     match order x y with
  30     | `Equal -> Some x
  31     | `Order p -> Some (f p)
  32     | `No -> None
  33
  34   let common_supertype = common_type snd
  35   let common_subtype = common_type fst
  36
  37   type tyvar = Typ of t | Var of int
  38   let string_of_tyvar = function Typ t -> to_string t | Var i -> sprintf "'%c" (Char.chr @@ Char.code 'a' + i)
  39
  40   type func =
  41   | Group of t * bool (* 'a -> t ; bool = multi-column *)
  42   | Agg (* 'a -> 'a *)
  43   | Poly of t (* 'a -> 'a -> t *) (* = F (Typ t, [Var 0; Var 0]) *)
  44   | Ret of t (* _ -> t *)
  45   | F of tyvar * tyvar list
  46
  47   let fixed ret args = F (Typ ret, List.map (fun t -> Typ t) args)
  48
  49   let pp_func pp =
  50     let open Format in
  51   function
  52   | Agg -> fprintf pp "|'a| -> 'a"
  53   | Group (ret,multi) -> fprintf pp "|%s'a| -> %s" (if multi then "{...} as " else "") (to_string ret)
  54   | Poly ret -> fprintf pp "'a -> 'a -> %s" (to_string ret)
  55   | Ret ret -> fprintf pp "_ -> %s" (to_string ret)
  56   | F (ret, args) -> fprintf pp "%s -> %s" (String.concat " -> " @@ List.map string_of_tyvar args) (string_of_tyvar ret)
  57
  58   let string_of_func = Format.asprintf "%a" pp_func
  59
  60   let is_grouping = function
  61   | Group _ | Agg -> true
  62   | Ret _ | Poly _ | F _ -> false
  63 end
  64
  65 module Constraint =
  66 struct
  67   type conflict_algo = | Ignore | Replace | Abort | Fail | Rollback
  68     [@@deriving show {with_path=false}]
  69
  70   type t = | PrimaryKey | NotNull | Unique | Autoincrement | OnConflict of conflict_algo
  71     [@@deriving show {with_path=false}]
  72 end
  73
  74 type attr = {name : string; domain : Type.t;}
  75   [@@deriving show {with_path=false}]
  76
  77 let attr n d = {name=n;domain=d}
  78
  79 module Schema =
  80 struct
  81   type t = attr list
  82     [@@deriving show]
  83
  84   exception Error of t * string
  85
  86   (** FIXME attribute case sensitivity? *)
  87   let by_name name = function attr -> attr.name = name
  88   let find_by_name t name = List.find_all (by_name name) t
  89
  90   let find t name =
  91     match find_by_name t name with
  92     | [x] -> x
  93     | [] -> raise (Error (t,"missing attribute : " ^ name))
  94     | _ -> raise (Error (t,"duplicate attribute : " ^ name))
  95
  96   let make_unique = List.unique ~cmp:(fun a1 a2 -> a1.name = a2.name && a1.name <> "")
  97   let is_unique t = List.length (make_unique t) = List.length t
  98   let check_unique t = is_unique t || raise (Error (t,"duplicate attributes"))
  99
 100   let project names t = List.map (find t) names
 101
 102   let change_inplace t before after =
 103     List.map (fun attr ->
 104       match by_name before attr with
 105       | true -> after
 106       | false -> attr ) t
 107
 108   let cross t1 t2 = t1 @ t2
 109
 110   (** [contains t attr] tests whether schema [t] contains attribute [attr] *)
 111   let contains t attr = find t attr.name = attr
 112
 113   let check_contains t attr =
 114     if not (contains t attr) then
 115       raise (Error (t,"type mismatch for attribute " ^ attr.name))
 116
 117   let sub l a = List.filter (fun x -> not (List.mem x a)) l
 118
 119   let to_string v = v |> List.map (fun attr -> sprintf "%s %s" (Type.to_string attr.domain) attr.name) |>
 120     String.concat ", " |> sprintf "[%s]"
 121   let names t = t |> List.map (fun attr -> attr.name) |> String.concat "," |> sprintf "[%s]"
 122
 123   let natural_ t1 t2 =
 124     let (common,t1only) = List.partition (fun x -> List.mem x t2) t1 in
 125     if 0 = List.length common then failwith "natural'";
 126     let t2only = sub t2 common in
 127     common @ t1only @ t2only
 128
 129   let natural t1 t2 =
 130     try natural_ t1 t2 with
 131     | _ -> raise (Error (t1,"no common attributes for natural join of " ^
 132                              (names t1) ^ " and " ^ (names t2)))
 133
 134   let join_using l t1 t2 =
 135     let common = List.map (find t1) l in
 136     List.iter (check_contains t2) common;
 137     common @ sub t1 common @ sub t2 common
 138
 139   let check_types t1 t2 =
 140     List.iter2 (fun a1 a2 ->
 141       match a1.domain, a2.domain with
 142       | Type.Any, _
 143       | _, Type.Any -> ()
 144       | x, y when x = y -> ()
 145       | _ -> raise (Error (t1, sprintf "Atributes do not match : %s of type %s and %s of type %s"
 146         a1.name (Type.to_string a1.domain)
 147         a2.name (Type.to_string a2.domain)))) t1 t2
 148
 149   let check_types t1 t2 =
 150     try check_types t1 t2 with
 151     | List.Different_list_size _ -> raise (Error (t1, (to_string t1) ^ " differs in size to " ^ (to_string t2)))
 152
 153   let compound t1 t2 = check_types t1 t2; t1
 154
 155   let add t col pos =
 156     match find_by_name t col.name with
 157     | [] ->
 158       begin
 159       match pos with
 160       | `First -> col::t
 161       | `Default -> t @ [col]
 162       | `After name ->
 163         try
 164           let (i,_) = List.findi (fun _ attr -> by_name name attr) t in
 165           let (l1,l2) = List.split_nth (i+1) t in
 166           l1 @ (col :: l2)
 167         with
 168           Not_found -> raise (Error (t,"Can't insert column " ^ col.name ^ " after non-existing column " ^ name))
 169       end
 170     | _ -> raise (Error (t,"Already has column " ^ col.name))
 171
 172   let drop t col =
 173     ignore (find t col);
 174     List.remove_if (by_name col) t
 175
 176   let change t oldcol col pos =
 177     match pos with
 178     | `Default -> change_inplace t oldcol col
 179     | `First | `After _ -> add (drop t oldcol) col pos
 180
 181   let to_string = show
 182   let print x = prerr_endline (to_string x)
 183
 184 end
 185
 186 type table = string * Schema.t [@@deriving show]
 187 type schema = Schema.t
 188
 189 let print_table out (name,schema) =
 190   IO.write_line out name;
 191   schema |> List.iter (fun {name=name;domain=domain} ->
 192     IO.printf out "%10s %s\n" (Type.to_string domain) name);
 193   IO.write_line out ""
 194
 195 (** optional name and start/end position in string *)
 196 type param_id = string option * (int * int) [@@deriving show]
 197 type param = param_id * Type.t [@@deriving show]
 198 type params = param list [@@deriving show]
 199
 200 let params_to_string = show_params
 201
 202 type alter_pos = [ `After of string | `Default | `First ]
 203 type alter_action = [ `Add of attr * alter_pos | `Drop of string | `Change of string * attr * alter_pos | `None ]
 204
 205 type select_result = (schema * param list)
 206
 207 type int_or_param = [`Const of int | `Limit of param]
 208 type limit_t = [ `Limit | `Offset ]
 209 type col_name = {
 210   cname : string; (** column name *)
 211   tname : string option; (** table name *)
 212 }
 213 and limit = (param_id * Type.t) list * bool
 214 and source1 = [ `Select of select | `Table of string ]
 215 and source = source1 * string option
 216 and join_cond = [ `Cross | `Search of expr | `Default | `Natural | `Using of string list ]
 217 and select = {
 218   columns : column list;
 219   from : (source * (source * join_cond) list) option;
 220   where : expr option;
 221   group : expr list;
 222   having : expr option;
 223 }
 224 and select_full = {
 225   select : select * select list;
 226   order : expr list;
 227   limit : limit option;
 228 }
 229 and expr =
 230   | Value of Type.t (** literal value *)
 231   | Param of param
 232   | Fun of Type.func * expr list (** parameters *)
 233   | Select of select_full * bool (* single *)
 234   | Column of col_name
 235   | Inserted of string (** inserted value *)
 236 and column =
 237   | All
 238   | AllOf of string
 239   | Expr of expr * string option (** name *)
 240   [@@deriving show {with_path=false}]
 241
 242 type columns = column list [@@deriving show]
 243
 244 type expr_q = [ `Value of Type.t (** literal value *)
 245             | `Param of param
 246             | `Func of Type.func * expr_q list (** return type, grouping, parameters *)
 247             ]
 248             [@@deriving show]
 249
 250 let expr_to_string = show_expr
 251
 252 type assignments = (col_name * expr) list
 253
 254 type insert_action =
 255 {
 256   target : string;
 257   action : [ `Set of assignments option
 258            | `Values of (string list option * expr list list option) (* column names * list of value tuples *)
 259            | `Select of (string list option * select_full) ];
 260   on_duplicate : assignments option;
 261 }
 262
 263 type stmt =
 264 | Create of string * [ `Schema of schema | `Select of select_full ]
 265 | Drop of string
 266 | Alter of string * alter_action list
 267 | CreateIndex of string * string * string list (* index name, table name, columns *)
 268 | Insert of insert_action
 269 | Delete of string * expr option
 270 | Set of string * expr
 271 | Update of string * assignments * expr option * expr list * param list (* where, order, limit *)
 272 | UpdateMulti of source list * assignments * expr option
 273 | Select of select_full
 274 | CreateRoutine of string * Type.t option * (string * Type.t * expr option) list
 275
 276 (*
 277 open Schema
 278
 279 let test = [{name="a";domain=Type.Int}; {name="b";domain=Type.Int}; {name="c";domain=Type.Text};];;
 280
 281 let () = print test
 282 let () = print (project ["b";"c";"b"] test)
 283 let () = print (project ["b";"d"] test)
 284 let () = print (rename test "a" "new_a")
 285 *)
 286
 287 module SMap = Map.Make(String)
 288
 289 let functions = ref SMap.empty
 290
 291 let add_function k ret =
 292   let add map k v =
 293     let k = String.lowercase k in
 294     if SMap.mem k map then
 295       failwith (sprintf "Function %S already defined" k)
 296     else
 297       SMap.add k v map
 298   in
 299   functions := add !functions k ret
 300
 301 let get_function name =
 302   try
 303     SMap.find (String.lowercase name) !functions
 304   with
 305     Not_found -> failwith (sprintf "Unknown function %S" name)
 306
 307 let () =
 308   let module T = Type in
 309   let func ret l = List.iter (fun x -> add_function x ret) l in
 310   func T.Agg ["max";"min";"sum"]; (* TODO in sqlite3 min(a,b) acts as least(a,b), while min(a) is grouping *)
 311   func T.(Group (Int,true)) ["count"];
 312   func T.(Group (Float,false)) ["avg"];
 313   func T.(fixed Text [Text;Text]) ["strftime"];
 314   func T.(fixed Text [Text]) ["lower";"upper"];
 315   func T.(Ret Text) ["concat"];
 316   func T.(Ret Any) ["coalesce"];
 317   func T.(Ret Int) ["length"; "random";"unix_timestamp";"least";"greatest"];
 318   ()