Queue.hs

{-# LANGUAGE BangPatterns #-}
module Queue (Queue, empty, snoc, head, tail) where 
import Prelude hiding(head,tail)

-- invariant: 
--  length (frontList q) - length (tailList q) - length (thunk q) == 0
data Queue a = 
    Queue { 
        frontList :: [a]  -- O(1) to be evaluated to WHNF
      , tailList :: [a] -- should be strict
      , thunk    :: [a]
    }

empty :: Queue a
empty = Queue [] [] []

-- invariant: length (frontList q) + 1 == length (tailList q)
rotate :: [a] -> [a] -> [a]
rotate = go []
    where
    go !a [] (y : _) = y : a
    go !a (x : xs) (y : ys) = x : go (y : a) xs ys

exec :: Queue a -> Queue a
exec q =
    case thunk q of
        _ : s -> q{ thunk = s }
        []    -> Queue f' [] f'
            where f' = rotate (frontList q) (tailList q)

snoc :: Queue a -> a -> Queue a
snoc q x = exec $! (q{ tailList = x : tailList q})

head :: Queue a -> a
head q =
    case frontList q of
        [] -> error "emptyQueue"
        x : _ -> x

tail :: Queue a -> Queue a
tail q =
    case frontList q of
        [] -> error "emptyQueue"
        _ : f -> exec $! (q { frontList = f })