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