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)
  10
  11   let to_string = Show.show<t>
  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   module Show_func = struct
  31   let show = function
  32   | Agg -> "|'a| -> 'a"
  33   | Group (ret,multi) -> sprintf "|%s'a| -> %s" (if multi then "{...} as " else "") (to_string ret)
  34   | Poly ret -> sprintf "'a -> 'a -> %s" (to_string ret)
  35   | Ret ret -> sprintf "_ -> %s" (to_string ret)
  36   | F (ret, args) -> sprintf "%s -> %s" (String.concat " -> " @@ List.map string_of_tyvar args) (string_of_tyvar ret)
  37   let format pp x = Format.fprintf pp "%s" (show x)
  38   end
  39
  40   let string_of_func = Show_func.show
  41
  42   let is_grouping = function
  43   | Group _ | Agg -> true
  44   | Ret _ | Poly _ | F _ -> false
  45 end
  46
  47 module Constraint =
  48 struct
  49   type conflict_algo = | Ignore | Replace | Abort | Fail | Rollback
  50        deriving (Show)
  51
  52   type t = | PrimaryKey | NotNull | Unique | Autoincrement | OnConflict of conflict_algo
  53        deriving (Show)
  54 end
  55
  56 type attr = {name : string; domain : Type.t;}
  57   deriving (Show)
  58
  59 let attr n d = {name=n;domain=d}
  60
  61 module Schema =
  62 struct
  63   type t = attr list
  64     deriving (Show)
  65
  66   exception Error of t * string
  67
  68   (** FIXME attribute case sensitivity? *)
  69   let by_name name = function attr -> attr.name = name
  70   let find_by_name t name = List.find_all (by_name name) t
  71
  72   let find t name =
  73     match find_by_name t name with
  74     | [x] -> x
  75     | [] -> raise (Error (t,"missing attribute : " ^ name))
  76     | _ -> raise (Error (t,"duplicate attribute : " ^ name))
  77
  78   let make_unique = List.unique ~cmp:(fun a1 a2 -> a1.name = a2.name && a1.name <> "")
  79   let is_unique t = List.length (make_unique t) = List.length t
  80   let check_unique t = is_unique t || raise (Error (t,"duplicate attributes"))
  81
  82   let project names t = List.map (find t) names
  83
  84   let change_inplace t before after =
  85     List.map (fun attr ->
  86       match by_name before attr with
  87       | true -> after
  88       | false -> attr ) t
  89
  90   let cross t1 t2 = t1 @ t2
  91
  92   (** [contains t attr] tests whether schema [t] contains attribute [attr] *)
  93   let contains t attr = find t attr.name = attr
  94
  95   let check_contains t attr =
  96     if not (contains t attr) then
  97       raise (Error (t,"type mismatch for attribute " ^ attr.name))
  98
  99   let sub l a = List.filter (fun x -> not (List.mem x a)) l
 100
 101   let to_string v = v |> List.map (fun attr -> sprintf "%s %s" (Type.to_string attr.domain) attr.name) |>
 102     String.concat ", " |> sprintf "[%s]"
 103   let names t = t |> List.map (fun attr -> attr.name) |> String.concat "," |> sprintf "[%s]"
 104
 105   let natural_ t1 t2 =
 106     let (common,t1only) = List.partition (fun x -> List.mem x t2) t1 in
 107     if 0 = List.length common then failwith "natural'";
 108     let t2only = sub t2 common in
 109     common @ t1only @ t2only
 110
 111   let natural t1 t2 =
 112     try natural_ t1 t2 with
 113     | _ -> raise (Error (t1,"no common attributes for natural join of " ^
 114                              (names t1) ^ " and " ^ (names t2)))
 115
 116   let join_using l t1 t2 =
 117     let common = List.map (find t1) l in
 118     List.iter (check_contains t2) common;
 119     common @ sub t1 common @ sub t2 common
 120
 121   let check_types t1 t2 =
 122     List.iter2 (fun a1 a2 ->
 123       match a1.domain, a2.domain with
 124       | Type.Any, _
 125       | _, Type.Any -> ()
 126       | x, y when x = y -> ()
 127       | _ -> raise (Error (t1, sprintf "Atributes do not match : %s of type %s and %s of type %s"
 128         a1.name (Type.to_string a1.domain)
 129         a2.name (Type.to_string a2.domain)))) t1 t2
 130
 131   let check_types t1 t2 =
 132     try check_types t1 t2 with
 133     | List.Different_list_size _ -> raise (Error (t1, (to_string t1) ^ " differs in size to " ^ (to_string t2)))
 134
 135   let compound t1 t2 = check_types t1 t2; t1
 136
 137   let add t col pos =
 138     match find_by_name t col.name with
 139     | [] ->
 140       begin
 141       match pos with
 142       | `First -> col::t
 143       | `Default -> t @ [col]
 144       | `After name ->
 145         try
 146           let (i,_) = List.findi (fun _ attr -> by_name name attr) t in
 147           let (l1,l2) = List.split_nth (i+1) t in
 148           l1 @ (col :: l2)
 149         with
 150           Not_found -> raise (Error (t,"Can't insert column " ^ col.name ^ " after non-existing column " ^ name))
 151       end
 152     | _ -> raise (Error (t,"Already has column " ^ col.name))
 153
 154   let drop t col =
 155     ignore (find t col);
 156     List.remove_if (by_name col) t
 157
 158   let change t oldcol col pos =
 159     match pos with
 160     | `Default -> change_inplace t oldcol col
 161     | `First | `After _ -> add (drop t oldcol) col pos
 162
 163   let to_string x = Show.show<t>(x)
 164   let print x = prerr_endline (to_string x)
 165
 166 end
 167
 168 type table = string * Schema.t deriving (Show)
 169 type schema = Schema.t
 170
 171 let print_table out (name,schema) =
 172   IO.write_line out name;
 173   schema |> List.iter (fun {name=name;domain=domain} ->
 174     IO.printf out "%10s %s\n" (Type.to_string domain) name);
 175   IO.write_line out ""
 176
 177 (** optional name and start/end position in string *)
 178 type param_id = string option * (int * int) deriving (Show)
 179 type param = param_id * Type.t deriving (Show)
 180 type params = param list deriving (Show)
 181
 182 let params_to_string ps = Show.show<params>(ps)
 183
 184 type alter_pos = [ `After of string | `Default | `First ]
 185 type alter_action = [ `Add of attr * alter_pos | `Drop of string | `Change of string * attr * alter_pos | `None ]
 186
 187 type select_result = (schema * param list)
 188
 189 type int_or_param = [`Const of int | `Limit of param]
 190 type limit_t = [ `Limit | `Offset ]
 191 type col_name = {
 192   cname : string; (** column name *)
 193   tname : string option; (** table name *)
 194 }
 195 and limit = (param_id * Type.t) list * bool
 196 and source1 = [ `Select of select | `Table of string ]
 197 and source = source1 * string option
 198 and join_cond = [ `Cross | `Search of expr | `Default | `Natural | `Using of string list ]
 199 and select = {
 200   columns : column list;
 201   from : (source * (source * join_cond) list) option;
 202   where : expr option;
 203   group : expr list;
 204   having : expr option;
 205 }
 206 and select_full = {
 207   select : select * select list;
 208   order : expr list;
 209   limit : limit option;
 210 }
 211 and expr =
 212   | Value of Type.t (** literal value *)
 213   | Param of param
 214   | Fun of Type.func * expr list (** parameters *)
 215   | Select of select_full * bool (* single *)
 216   | Column of col_name
 217 and column =
 218   | All
 219   | AllOf of string
 220   | Expr of expr * string option (** name *)
 221   deriving (Show)
 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.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 option)
 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
 256 (*
 257 open Schema
 258
 259 let test = [{name="a";domain=Type.Int}; {name="b";domain=Type.Int}; {name="c";domain=Type.Text};];;
 260
 261 let () = print test
 262 let () = print (project ["b";"c";"b"] test)
 263 let () = print (project ["b";"d"] test)
 264 let () = print (rename test "a" "new_a")
 265 *)