src/rA.ml

   1 (*
   2  Relational Algebra
   3 *)
   4
   5 open Printf
   6 open ExtLib
   7 open Prelude
   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 make_unique = List.unique ~cmp:(fun a1 a2 -> a1.name = a2.name && a1.name <> "")
  34   let is_unique t = List.length (make_unique t) = List.length t
  35   let check_unique t = is_unique t || raise (Error (t,"duplicate attributes"))
  36
  37   let project names t = List.map (find t) names
  38
  39   let change_inplace t before after =
  40     List.map (fun attr ->
  41       match by_name before attr with
  42       | true -> after
  43       | false -> attr ) t
  44
  45   let cross t1 t2 = t1 @ t2
  46
  47   (** [contains t attr] tests whether schema [t] contains attribute [attr] *)
  48   let contains t attr = find t attr.name = attr
  49
  50   let check_contains t attr =
  51     if not (contains t attr) then
  52       raise (Error (t,"type mismatch for attribute " ^ attr.name))
  53
  54   let sub l a = List.filter (fun x -> not (List.mem x a)) l
  55
  56   let to_string v = v >> List.map (fun attr -> sprintf "%s %s" (Type.to_string attr.domain) attr.name) >>
  57     String.concat ", " >> sprintf "[%s]"
  58   let names t = t >> List.map (fun attr -> attr.name) >> String.concat "," >> sprintf "[%s]"
  59
  60   let natural_ t1 t2 =
  61     let (common,t1only) = List.partition (fun x -> List.mem x t2) t1 in
  62     if 0 = List.length common then failwith "natural'";
  63     let t2only = sub t2 common in
  64     common @ t1only @ t2only
  65
  66   let natural t1 t2 =
  67     try natural_ t1 t2 with
  68     | _ -> raise (Error (t1,"no common attributes for natural join of " ^
  69                              (names t1) ^ " and " ^ (names t2)))
  70
  71   let join_using l t1 t2 =
  72     let common = List.map (find t1) l in
  73     List.iter (check_contains t2) common;
  74     common @ sub t1 common @ sub t2 common
  75
  76   let check_types t1 t2 =
  77     List.iter2 (fun a1 a2 ->
  78       match a1.domain, a2.domain with
  79       | Type.Any, _
  80       | _, Type.Any -> ()
  81       | x, y when x = y -> ()
  82       | _ -> raise (Error (t1, sprintf "Atributes do not match : %s of type %s and %s of type %s"
  83         a1.name (Type.to_string a1.domain)
  84         a2.name (Type.to_string a2.domain)))) t1 t2
  85
  86   let check_types t1 t2 =
  87     try check_types t1 t2 with
  88     | List.Different_list_size _ -> raise (Error (t1, (to_string t1) ^ " differs in size to " ^ (to_string t2)))
  89
  90   let compound t1 t2 = check_types t1 t2; t1
  91
  92   let add t col pos =
  93     match find_by_name t col.name with
  94     | [] ->
  95       begin
  96       match pos with
  97       | `First -> col::t
  98       | `Default -> t @ [col]
  99       | `After name ->
 100         try
 101           let (i,_) = List.findi (fun _ attr -> by_name name attr) t in
 102           let (l1,l2) = List.split_nth (i+1) t in
 103           l1 @ (col :: l2)
 104         with
 105           Not_found -> raise (Error (t,"Can't insert column " ^ col.name ^ " after non-existing column " ^ name))
 106       end
 107     | _ -> raise (Error (t,"Already has column " ^ col.name))
 108
 109   let drop t col =
 110     ignore (find t col);
 111     List.remove_if (by_name col) t
 112
 113   let change t oldcol col pos =
 114     match pos with
 115     | `Default -> change_inplace t oldcol col
 116     | `First | `After _ -> add (drop t oldcol) col pos
 117
 118   let to_string x = Show.show<t>(x)
 119   let print x = prerr_endline (to_string x)
 120
 121 end
 122
 123 type table = string * Schema.t deriving (Show)
 124
 125 let print_table out (name,schema) =
 126   IO.write_line out name;
 127   schema >> List.iter (fun {name=name;domain=domain} ->
 128     IO.printf out "%10s %s\n" (Type.to_string domain) name);
 129   IO.write_line out ""
 130
 131 (*
 132 open Schema
 133
 134 let test = [{name="a";domain=Type.Int}; {name="b";domain=Type.Int}; {name="c";domain=Type.Text};];;
 135
 136 let () = print test
 137 let () = print (project ["b";"c";"b"] test)
 138 let () = print (project ["b";"d"] test)
 139 let () = print (rename test "a" "new_a")
 140 *)