lib/mlton/basic/append-list.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 AppendList: APPEND_LIST =
   9 struct
  10
  11 (* We are careful to ensure that the empty list is always represented by
  12  * the Empty constructor.
  13  *)
  14 datatype 'a t =
  15    Append of 'a t * 'a t (* Neither is empty. *)
  16  | Appends of 'a t list (* None is empty and list is nonempty. *)
  17  | AppendsV of 'a t vector (* None is empty and vector is nonempty. *)
  18  | Cons of 'a * 'a t (* Nonempty. *)
  19  | Empty
  20  | List of 'a list (* Nonempty. *)
  21  | Single of 'a
  22  | Snoc of 'a t (* Nonempty *) * 'a
  23  | Vector of 'a vector (* Nonempty. *)
  24
  25 val isEmpty = fn Empty => true | _ => false
  26
  27 fun append (t1, t2) =
  28    if isEmpty t1
  29       then t2
  30    else if isEmpty t2
  31            then t1
  32         else Append (t1, t2)
  33
  34 fun appends l =
  35    let
  36       val l = List.keepAll (l, not o isEmpty)
  37    in
  38       if List.isEmpty l
  39          then Empty
  40       else Appends l
  41    end
  42
  43 fun appendsV v =
  44    let
  45       val v = Vector.keepAll (v, not o isEmpty)
  46    in
  47       if Vector.isEmpty v
  48          then Empty
  49       else AppendsV v
  50    end
  51
  52 fun cons (a, l) =
  53    case l of
  54       Empty => Single a
  55     | _ => Cons (a, l)
  56
  57 val empty = Empty
  58
  59 fun fromList l =
  60    if List.isEmpty l
  61       then Empty
  62    else List l
  63
  64 fun fromVector v =
  65    if Vector.isEmpty v
  66       then Empty
  67    else Vector v
  68
  69 val single = Single
  70
  71 fun snoc (l, a) =
  72    case l of
  73       Empty => Single a
  74     | _ => Snoc (l, a)
  75
  76 fun fold (l, b, f) =
  77    let
  78       fun loop (l, b) =
  79          case l of
  80             Append (l, l') => loop (l', loop (l, b))
  81           | Appends l => List.fold (l, b, loop)
  82           | AppendsV v => Vector.fold (v, b, loop)
  83           | Cons (x, l) => loop (l, f (x, b))
  84           | Empty => b
  85           | List l => List.fold (l, b, f)
  86           | Single x => f (x, b)
  87           | Snoc (l, x) => f (x, loop (l, b))
  88           | Vector v => Vector.fold (v, b, f)
  89    in loop (l, b)
  90    end
  91
  92 fun length l : int = fold (l, 0, fn (_, i) => i + 1)
  93
  94 fun foreach (l, f) = fold (l, (), fn (x, ()) => f x)
  95
  96 fun foldr (l, b, f) =
  97    let
  98       fun loop (l, b) =
  99          case l of
 100             Append (l, l') => loop (l, loop (l', b))
 101           | Appends l => List.foldr (l, b, loop)
 102           | AppendsV v => Vector.foldr (v, b, loop)
 103           | Cons (x, l) => f (x, loop (l, b))
 104           | Empty => b
 105           | List l => List.foldr (l, b, f)
 106           | Single x => f (x, b)
 107           | Snoc (l, x) => loop (l, f (x, b))
 108           | Vector v => Vector.foldr (v, b, f)
 109    in loop (l, b)
 110    end
 111
 112 fun map (l, f) =
 113    let
 114       val rec loop =
 115          fn Append (l, l') => Append (loop l, loop l')
 116           | Appends l => Appends (List.map (l, loop))
 117           | AppendsV v => AppendsV (Vector.map (v, loop))
 118           | Cons (x, l) => Cons (f x, loop l)
 119           | Empty => Empty
 120           | List l => List (List.map (l, f))
 121           | Single x => Single (f x)
 122           | Snoc (l, x) => Snoc (loop l, f x)
 123           | Vector v => Vector (Vector.map (v, f))
 124    in loop l
 125    end
 126
 127 fun toList ds = foldr (ds, [], op ::)
 128
 129 fun toListOnto (ds, l) = foldr (ds, l, op ::)
 130
 131 fun toVector ds = Vector.tabulator (length ds, fn call => foreach (ds, call))
 132
 133 fun layout layoutX l = List.layout layoutX (toList l)
 134
 135 fun push (r, x) = r := cons (x, !r)
 136
 137 end