lib/mlton/basic/rdb.sml

   1 (* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh
   2  *    Jagannathan, and Stephen Weeks.
   3  *
   4  * MLton is released under a BSD-style license.
   5  * See the file MLton-LICENSE for details.
   6  *)
   7
   8 structure RDB: RDB =
   9 struct
  10
  11 structure Rep =
  12    struct
  13       type t = exn
  14    end
  15
  16 structure Domain =
  17    struct
  18       datatype t = T of {compare : Rep.t * Rep.t -> Relation.t,
  19                          contains: Rep.t -> bool,
  20                          just: Justify.t,
  21                          toString: Rep.t -> string}
  22    end
  23
  24 structure Value =
  25    struct
  26       datatype t = T of {domain: Domain.t,
  27                          rep: Rep.t}
  28    end
  29
  30 structure Domain =
  31    struct
  32       open Domain
  33
  34       fun contains (T {contains, ...}, Value.T {rep = r, ...}) = contains r
  35
  36       fun new {compare: 'a * 'a -> Relation.t,
  37                just: Justify.t,
  38                toString: 'a -> string}: t * ('a -> Value.t) =
  39          let
  40             exception E of 'a
  41             val contains = fn E _ => true | _ => false
  42             val toString = fn E x => toString x
  43                             | _ => Error.bug "RDB.Domain.new.toString"
  44             val compare =
  45                fn (E x, E y) => compare (x, y)
  46                 | _ => Error.bug "RDB.Domain.new.compare"
  47             val d = T {compare = compare,
  48                       contains = contains,
  49                       just = just,
  50                       toString = toString}
  51             fun make (a: 'a): Value.t = Value.T {domain = d, rep = E a}
  52          in (d, make)
  53          end
  54
  55       val (bool, boolV) = new {compare = Bool.compare,
  56                                just = Justify.Left,
  57                                toString = Bool.toString}
  58
  59       val (int, intV) = new {compare =  Int.compare,
  60                              just = Justify.Right,
  61                              toString = Int.toString}
  62
  63       val (real, realV) = new {compare = Real.compare,
  64                                just = Justify.Right,
  65                                toString =
  66                                fn r => Real.format (r, Real.Format.fix (SOME 1))}
  67 (*                             Real.toString *)
  68
  69       val (string, stringV) = new {compare = String.compare,
  70                                    just = Justify.Left,
  71                                    toString = String.toString}
  72    end
  73
  74 structure Value =
  75    struct
  76       open Value
  77
  78       local open Domain
  79       in
  80          val bool = boolV
  81          val int = intV
  82          val real = realV
  83          val string = stringV
  84       end
  85
  86       local
  87          fun unary f (T {domain = Domain.T d, rep = r, ...}) = f d r
  88       in
  89          val toString = unary #toString
  90       end
  91
  92       fun justification (T {domain = Domain.T {just, ...}, ...}) = just
  93
  94       local
  95          fun binary f (T {domain = Domain.T d, rep = r, ...}, T {rep = r', ...}) =
  96             f d (r, r')
  97       in
  98          val compare = binary #compare
  99       end
 100
 101       val {<, <=, equals, >=, >, ...} = Relation.compare compare
 102    end
 103
 104 structure Attribute =
 105    struct
 106       open String
 107
 108       val new = fn s => s
 109    end
 110
 111 structure Heading =
 112    struct
 113       datatype t = T of (Attribute.t * Domain.t) list
 114
 115       fun degree (T l) = List.length l
 116
 117       fun info (T l, a) =
 118          case List.peeki (l, fn (_, (a', _)) => Attribute.equals (a, a')) of
 119             NONE => Error.bug "RDB.Heading.info"
 120           | SOME (i, (_, d)) => (i, d)
 121
 122       val position = #1 o info
 123    end
 124
 125 datatype t = T of {heading: Heading.t,
 126                    body: Value.t list list ref}
 127
 128 fun add (T {heading = Heading.T attrs, body, ...}, r) =
 129    List.push
 130    (body,
 131     List.fold (rev attrs, [], fn ((a, d), ac) =>
 132               case List.peek (r, fn (a', _) => Attribute.equals (a, a')) of
 133                  NONE => Error.bug "RDB.add"
 134                | SOME (_, v) =>
 135                     if Domain.contains (d, v)
 136                        then v :: ac
 137                     else Error.bug "RDB.add"))
 138
 139 fun cardinality (T {body, ...}) = List.length (!body)
 140
 141 fun degree (T {heading, ...}) = Heading.degree heading
 142
 143 fun new {heading} = T {heading = Heading.T heading,
 144                      body = ref []}
 145
 146 fun project (T {heading, body, ...}, a: Attribute.t): Value.t list =
 147    let val n = Heading.position (heading, a)
 148    in List.fold (!body, [], fn (vs, ac) =>
 149                 List.insert (vs, List.nth (vs, n), Value.<=))
 150    end
 151
 152 fun outputTable (t, out) =
 153    let
 154       val print = Out.outputc out
 155    in
 156       List.foreach (t, fn ss =>
 157                    (case ss of
 158                        [] => ()
 159                      | s :: ss =>
 160                           (print s
 161                            ; List.foreach (ss, fn s =>
 162                                           (print " "; print s)))
 163                           ; print "\n"))
 164    end
 165
 166 fun printTable {rdb as T {body, heading, ...}, row, col, entry, out}: unit =
 167    let
 168       val default = "*"
 169       val body = !body
 170       val rows = project (rdb, row)
 171       val cols = project (rdb, col)
 172       val nr = Heading.position (heading, row)
 173       val nc = Heading.position (heading, col)
 174       val ne = Heading.position (heading, entry)
 175       val table =
 176          ("" :: List.map (cols, Value.toString)) ::
 177          let
 178             val cols = rev cols
 179          in List.fold
 180             (rev rows, [], fn (r, ac) =>
 181              let
 182                 val row =
 183                    List.fold
 184                    (cols, [], fn (c, ac) =>
 185                     let
 186                        val e =
 187                           case (List.peek
 188                                 (body, fn t =>
 189                                  Value.equals (r, List.nth (t, nr))
 190                                  andalso Value.equals (c, List.nth (t, nc))))
 191                              of
 192                                 NONE => default
 193                               | SOME t => Value.toString (List.nth (t, ne))
 194                     in e :: ac
 195                     end)
 196              in (Value.toString r :: row) :: ac
 197              end)
 198          end
 199       val justs =
 200          (Value.justification (hd rows)
 201           :: List.map (cols, Value.justification))
 202       val t = Justify.table {columnHeads = NONE, justs = justs, rows = table}
 203    in outputTable (t, out)
 204    end
 205
 206 fun printTable' {rdb as T {body, heading = Heading.T ads, ...},
 207                 cols, sortBy, out}: unit =
 208    let
 209       val is = List.revMap (cols, fn a =>
 210                            valOf (List.index (ads, fn (a', _) =>
 211                                             Attribute.equals (a, a'))))
 212       val rows =
 213          List.revMap (!body, fn r =>
 214                      let val a = Array.fromList r
 215                      in List.revMap (is, fn i => Array.sub (a, i))
 216                      end)
 217       val justs = List.map (hd rows, Value.justification)
 218       val i = valOf (List.index (cols, fn a => Attribute.equals (a, sortBy)))
 219       val rows =
 220          QuickSort.sortList (rows, fn (r, r') =>
 221                              Value.<= (List.nth (r, i), List.nth (r', i)))
 222       val rows =
 223          List.map (cols, Attribute.toString)
 224          :: List.map (rows, fn r => List.map (r, Value.toString))
 225       val t = Justify.table {columnHeads = NONE,
 226                              justs = justs,
 227                              rows = rows}
 228    in outputTable (t, out)
 229    end
 230
 231 end