rA.ml

   1 (*
   2  Relational Algebra
   3 *)
   4
   5 open ListMore
   6 open Printf
   7 open Operators
   8
   9 module Type = Sql.Type
  10
  11 type attr = {name : string; domain : Type.t;}
  12   deriving (Show)
  13
  14 let attr n d = {name=n;domain=d}
  15
  16 module Schema =
  17 struct
  18   type t = attr list
  19     deriving (Show)
  20
  21   exception Error of t * string
  22
  23   (** FIXME attribute case sensitivity? *)
  24   let by_name name = function attr -> attr.name = name
  25   let find_by_name t name = List.find_all (by_name name) t
  26
  27   let find t name =
  28     match find_by_name t name with
  29     | [x] -> x
  30     | [] -> raise (Error (t,"missing attribute : " ^ name))
  31     | _ -> raise (Error (t,"duplicate attribute : " ^ name))
  32
  33   let is_unique t =
  34     let t1 = List.unique ~cmp:(fun a1 a2 -> a1.name = a2.name && a1.name <> "") t in
  35     List.length t1 = List.length t
  36
  37   let check_unique t = is_unique t || raise (Error (t,"duplicate attributes"))
  38
  39   let project names t = List.map (find t) names
  40
  41   let rename t before after =
  42     List.map (fun attr ->
  43       match attr.name with
  44       | x when x = before -> { attr with name=after }
  45       | _ -> attr ) t
  46
  47   let cross t1 t2 = t1 @ t2
  48
  49   (** [contains t attr] tests whether schema [t] contains attribute [attr] *)
  50   let contains t attr = find t attr.name = attr
  51
  52   let check_contains t attr =
  53     if not (contains t attr) then
  54       raise (Error (t,"type mismatch for attribute " ^ attr.name))
  55
  56   let sub l a = List.filter (fun x -> not (List.mem x a)) l
  57
  58   let to_string v = Show.show<t>(v)
  59   let names t = t >> List.map (fun attr -> attr.name) >> String.concat "," >> sprintf "[%s]"
  60
  61   let natural_ t1 t2 =
  62     let (common,t1only) = List.partition (fun x -> List.mem x t2) t1 in
  63     if 0 = List.length common then failwith "natural'";
  64     let t2only = sub t2 common in
  65     common @ t1only @ t2only
  66
  67   let natural t1 t2 =
  68     try natural_ t1 t2 with
  69     | _ -> raise (Error (t1,"no common attributes for natural join of " ^
  70                              (names t1) ^ " and " ^ (names t2)))
  71
  72   let join_using l t1 t2 =
  73     let common = List.map (find t1) l in
  74     List.iter (check_contains t2) common;
  75     common @ sub t1 common @ sub t2 common
  76
  77   let compound t1 t2 =
  78     let types = List.map (fun attr -> attr.domain) in
  79     if types t1 <> types t2 then
  80       raise (Error (t1, (to_string t1) ^ " not equal to " ^ (to_string t2)))
  81      else
  82       t1
  83
  84   let add t col pos =
  85     match find_by_name t col.name with
  86     | [] ->
  87       begin
  88       match pos with
  89       | `First -> col::t
  90       | `Last -> t @ [col]
  91       | `After name ->
  92         try
  93           let (i,_) = List.findi (fun _ attr -> by_name name attr) t in
  94           let (l1,l2) = List.split_nth (i+1) t in
  95           l1 @ (col :: l2)
  96         with
  97           Not_found -> raise (Error (t,"Can't insert column " ^ col.name ^ " after non-existing column " ^ name))
  98       end
  99     | _ -> raise (Error (t,"Already has column " ^ col.name))
 100
 101   let drop t col =
 102     ignore (find t col);
 103     List.remove_if (by_name col) t
 104
 105   let to_string x = Show.show<t>(x)
 106   let print x = prerr_endline (to_string x)
 107
 108 end
 109
 110 type table = string * Schema.t deriving (Show)
 111
 112 let print_table t = print_endline (Show.show<table>(t))
 113
 114 (*
 115 open Schema
 116
 117 let test = [{name="a";domain=Type.Int}; {name="b";domain=Type.Int}; {name="c";domain=Type.Text};];;
 118
 119 let () = print test
 120 let () = print (project ["b";"c";"b"] test)
 121 let () = print (project ["b";"d"] test)
 122 let () = print (rename test "a" "new_a")
 123 *)