Okasaki's purely functional queues.

Queue.hs

{-# LANGUAGE UnicodeSyntax #-}
module Queue
  ( Queue
  , isEmpty
  , ($*), head, tail
  , size
  , fromList
  ) where

import Data.List (foldl')
import Data.Monoid (Monoid(..))
import Prelude hiding (head, tail)
import qualified Prelude as P

data Queue β α = Queue [α] [α] β β

instance Show α ⇒ Show (Queue β α) where
  show (Queue xs ys _ _) = "fromList " ++ show (xs ++ reverse ys)

instance Integral β ⇒ Functor (Queue β) where
  fmap f (Queue xs ys xl yl) = queue (map f xs) (map f ys) xl yl

instance Integral β ⇒ Monoid (Queue β α) where
  mempty = Queue [] [] 0 0
  mappend (Queue axs ays axl ayl) (Queue bxs bys bxl byl) = queue (axs ++ reverse ays) (bys ++ reverse bxs) (axl + ayl) (bxl + byl)

isEmpty ∷ Integral β ⇒ Queue β α → Bool
isEmpty (Queue [] [] 0 0) = True
isEmpty _ = False

snoc ∷ Integral β ⇒ α → Queue β α → Queue β α
snoc t (Queue xs ys xl yl) = queue xs (t:ys) xl (succ yl)

($*) ∷ Integral β ⇒ Queue β α → α → Queue β α
($*) = flip snoc

head ∷ Queue β α → α
head (Queue (x:_) _ _ _) = x
head _ = error "Queue.head: empty queue"

tail ∷ Integral β ⇒ Queue β α → Queue β α
tail (Queue [] [] _ _) = error "Queue.tail: empty queue"
tail (Queue xs ys xl yl) = queue (P.tail xs) ys (pred xl) yl

size ∷ Integral β ⇒ Queue β α → β
size (Queue _ _ a b) = fromIntegral $ a + b

fromList ∷ Integral β ⇒ [α] → Queue β α
fromList = foldl' ($*) mempty

queue ∷ Integral β ⇒ [α] → [α] → β → β → Queue β α
queue xs ys xl yl
  | yl < xl = Queue xs ys xl yl
  | otherwise = Queue (xs ++ reverse ys) [] (xl + yl) 0