mlton/atoms/record.fun

   1 (* Copyright (C) 2017 Matthew Fluet.
   2  * Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh
   3  *    Jagannathan, and Stephen Weeks.
   4  * Copyright (C) 1997-2000 NEC Research Institute.
   5  *
   6  * MLton is released under a BSD-style license.
   7  * See the file MLton-LICENSE for details.
   8  *)
   9
  10 (* empty tuple is also a record *)
  11
  12 functor Record (S: RECORD_STRUCTS): RECORD =
  13 struct
  14
  15 open S
  16
  17 datatype 'a t =
  18    Tuple of 'a vector
  19  | Record of (Field.t * 'a) vector
  20
  21 val tuple = Tuple
  22
  23 fun toVector r =
  24    case r of
  25       Tuple v => Vector.mapi (v, fn (i, x) => (Field.Int i, x))
  26     | Record r => r
  27
  28 fun detupleOpt (r: 'a t): 'a vector option =
  29    case r of
  30       Tuple t => SOME t
  31     | Record _ => NONE
  32
  33 fun sort v =
  34    QuickSort.sortVector (v, fn ((s, _), (s', _)) => Field.<= (s, s'))
  35
  36 fun fromVector v =
  37    let
  38       fun isTuple v : bool =
  39          Vector.foralli
  40          (v, fn (i, (f, _)) =>
  41           case f of
  42              Field.Int i' => Int.equals (i, i')
  43            | _ => false)
  44       val v = if isSorted then sort v else v
  45    in
  46       if isTuple v andalso Vector.length v <> 1
  47          then Tuple (Vector.map (v, #2))
  48       else Record v
  49    end
  50
  51 fun unzip r = Vector.unzip (toVector r)
  52 fun zip z = fromVector (Vector.zip z)
  53
  54 val peek: 'a t * Field.t -> 'a option =
  55    fn (r, f) =>
  56    case r of
  57       Record r =>
  58          (case Vector.peek (r, fn (f', _) => Field.equals (f, f')) of
  59              NONE => NONE
  60            | SOME (_, x) => SOME x)
  61     | Tuple t =>
  62          if Vector.isEmpty t
  63             then NONE
  64          else (case f of
  65                   Field.Int i =>
  66                      if 0 <= i andalso i < Vector.length t
  67                         then SOME (Vector.sub (t, i))
  68                      else NONE
  69                 | Field.Symbol _ => NONE)
  70
  71 fun domain r =
  72    case r of
  73       Tuple v => Vector.mapi (v, fn (i, _) => Field.Int i)
  74     | Record r => Vector.map (r, #1)
  75
  76 fun range r =
  77    case r of
  78       Tuple t => t
  79     | Record r => Vector.map (r, #2)
  80
  81 fun exists (r, p) =
  82    case r of
  83       Tuple xs => Vector.exists (xs, p)
  84     | Record r => Vector.exists (r, fn (_, x) => p x)
  85
  86 fun forall (r, p) = not (exists (r, not o p))
  87
  88 fun fold (r: 'a t, b: 'b, f: 'a * 'b -> 'b): 'b =
  89    case r of
  90       Tuple xs => Vector.fold (xs, b, f)
  91     | Record r => Vector.fold (r, b, fn ((_, x), b) => f (x, b))
  92
  93 fun map (r: 'a t, f: 'a -> 'b): 'b t =
  94    case r of
  95       Tuple xs => Tuple (Vector.map (xs, f))
  96     | Record r => Record (Vector.map (r, fn (field, a) => (field, f a)))
  97
  98 fun foreach (r: 'a t, f: 'a -> unit): unit =
  99    case r of
 100       Tuple xs => Vector.foreach (xs, f)
 101     | Record r => Vector.foreach (r, f o #2)
 102
 103 fun change (r: 'a t, f: 'a vector -> 'b vector * 'c): 'b t * 'c =
 104    case r of
 105       Tuple xs => let val (ys, c) = f xs
 106                   in (Tuple ys, c)
 107                   end
 108     | Record r => let val (fs, xs) = Vector.unzip r
 109                       val (ys, c) = f xs
 110                   in (Record (Vector.zip (fs, ys)), c)
 111                   end
 112
 113 fun layout {record, layoutTuple, separator, extra, layoutElt} =
 114    case (record, extra) of
 115       (Tuple xs, "") => layoutTuple xs
 116     | _ =>
 117          let
 118             val r = toVector record
 119             open Layout
 120          in seq [str "{",
 121                  mayAlign (separateRight (Vector.toListMap
 122                                           (r, fn (f, x) =>
 123                                            seq [Field.layout f,
 124                                                 str separator,
 125                                                 layoutElt x]),
 126                                           ",")),
 127                  str extra,
 128                  str "}"]
 129          end
 130
 131 end