Import Upstream version 20180207

[hcoop/debian/mlton.git] / lib / cml / util / fun-queue.sml

(* fun-queue.sml\r
 * 2004 Matthew Fluet (mfluet@acm.org)\r
 *  Ported to MLton threads.\r
 *)\r
\r
structure FunQueue : FUN_QUEUE =\r
   struct\r
      datatype 'a t = T of {front: 'a list, back: 'a list}\r
\r
      local\r
         fun filterPrefix (xs, p) =\r
            case xs of\r
               [] => []\r
             | y::ys => if p y\r
                          then filterPrefix (ys, p)\r
                          else xs\r
         fun filter (xs, p) = List.filter (not o p) xs\r
         fun filterRevAcc ((xs, zs), p) =\r
            case xs of\r
               [] => zs\r
             | y::ys => if p y\r
                          then filterRevAcc ((ys, zs), p)\r
                          else filterRevAcc ((ys, y::zs), p)\r
         fun filterRev (xs, p) = filterRevAcc ((xs, []), p)\r
      in\r
         fun cleanPrefix (T {front, back}, p) =\r
            (case filterPrefix (front, p) of\r
                [] => T {front = filterPrefix (List.rev(back), p),\r
                         back = []}\r
              | front' =>  T {front = front',\r
                              back = back})\r
         fun clean (T {front, back}, p) =\r
            (case filter (front, p) of\r
                [] => T {front = filterRev (back, p),\r
                         back = []}\r
              | front' =>  T {front = front',\r
                              back = filter (back, p)})\r
         fun cleanAndDeque (T {front, back}, p) =\r
            (case filter (front, p) of\r
                [] => (case filterRev(back, p) of\r
                          [] => (NONE,\r
                                 T {front = [],\r
                                    back = []})\r
                        | x::front' => (SOME x,\r
                                        T {front = front',\r
                                           back = []}))\r
              | [x] => (SOME x,\r
                        T {front = filterRev (back, p),\r
                           back = []})\r
              | x::front' => (SOME x,\r
                              T {front = front',\r
                                 back = filter (back, p)}))\r
      end\r
\r
      fun deque (T {front, back}) =\r
         (case front of\r
             [] => (case back of\r
                       [] => NONE\r
                     | l => let val l = List.rev l\r
                            in \r
                               case l of\r
                                  [] => raise Fail "FunQueue.deque:impossible"\r
                                | x::front' => \r
                                     SOME (x,\r
                                           T {front = front',\r
                                              back = []})\r
                            end)\r
           | x::front' => SOME (x, T {front = front', back = back}))\r
                          \r
      fun empty (T {front, back}) =\r
         (case front of\r
             [] => (case back of\r
                       [] => true\r
                     | _ => false)\r
           | _ => false)\r
             \r
      fun enque (T {front, back, ...}, x) = \r
         T {front = front, back = x::back}\r
\r
      fun enqueAndClean (q, y, p) =\r
         clean (enque (q, y), p)\r
\r
      fun new () = T {front = [], back = []}\r
\r
      fun peek (T {front, back}) =\r
         (case front of\r
             [] => (case back of\r
                       [] => NONE\r
                     | l => let val l = List.rev l\r
                            in \r
                               case l of\r
                                  [] => raise Fail "FunQueue.peek:impossible"\r
                                | x::_ => SOME x\r
                            end)\r
           | x::_ => SOME x)\r
   end\r