{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} -- | Classes for the various heaps, mainly to avoid name clashing. module Data.Queue.Class (Queue(..) ,MeldableQueue(..) ,showsPrecQueue ,readPrecQueue ,eqQueue ,cmpQueue) where import Data.List (unfoldr) import Data.Function (on) import Data.Coerce (Coercible,coerce) import Data.Set (Set) import qualified Data.Set as Set -- | A class for queues. Conforming members can have their own -- definition of order on their contents. (i.e., 'Ord' is not required) class Queue h a where {-# MINIMAL minView , insert , empty #-} -- | Return the first element, and the remaining elements, -- or 'Nothing' if the queue is empty. For most queues, -- this will be the minimal element minView :: h a -> Maybe (a, h a) -- | Insert an element into the queue. insert :: a -> h a -> h a -- | The empty queue. empty :: h a -- | A queue with one element. singleton :: a -> h a singleton = flip insert empty -- | Return a list of the contents of the queue, in order, from -- smallest to largest. toList :: h a -> [a] toList = unfoldr minView -- | Create a heap from a list. fromList :: [a] -> h a fromList = foldr insert empty -- | Perform heap sort on a list of items. heapSort :: p h -> [a] -> [a] heapSort (_ :: p h) = toList . (fromList :: [a] -> h a) -- | A class for meldable queues. Conforming members should -- form a monoid under 'merge' and 'empty'. class Queue h a => MeldableQueue h a where {-# MINIMAL merge #-} -- | Merge two heaps. This operation is associative, and has the -- identity of 'empty'. -- -- @'merge' x ('merge' y z) = 'merge' ('merge' x y) z@ -- -- @'merge' x 'empty' = 'merge' 'empty' x = x@ merge :: h a -> h a -> h a -- | Create a heap from a 'Foldable' container. This operation is -- provided to allow the use of 'foldMap', which may be -- asymptotically more efficient. The default definition uses -- 'foldMap'. fromFoldable :: (Foldable f) => f a -> h a fromFoldable = runQueueWrapper #. foldMap (QueueWrapper #. singleton) newtype QueueWrapper h a = QueueWrapper { runQueueWrapper :: h a } instance MeldableQueue h a => Monoid (QueueWrapper h a) where mempty = QueueWrapper empty mappend = (coerce :: (h a -> h a -> h a) -> QueueWrapper h a -> QueueWrapper h a -> QueueWrapper h a) merge {-# INLINE mempty #-} {-# INLINE mappend #-} -- | A default definition for 'showsPrec'. showsPrecQueue :: (Queue h a, Show a) => Int -> h a -> ShowS showsPrecQueue d xs = showParen (d >= 11) (showString "fromList " . showList (toList xs)) -- | A default definition for 'readsPrec'. readPrecQueue :: (Read a, Queue h a) => Int -> ReadS (h a) readPrecQueue d = readParen (d > 10) (\xs -> [ (fromList x, zs) | ("fromList",ys) <- lex xs , (x,zs) <- readList ys ]) -- | A default definition of '=='. eqQueue :: (Eq a, Queue h a) => h a -> h a -> Bool eqQueue = (==) `on` toList -- | A default definition of 'compare'. cmpQueue :: (Ord a, Queue h a) => h a -> h a -> Ordering cmpQueue = compare `on` toList infixr 9 #. (#.) :: Coercible b c => (b -> c) -> (a -> b) -> a -> c (#.) _ = coerce instance Ord a => Queue Set a where insert = Set.insert empty = Set.empty fromList = Set.fromList singleton = Set.singleton minView = Set.minView toList = Set.toList instance Ord a => MeldableQueue Set a where merge = Set.union instance Queue [] a where insert = (:) empty = [] fromList = id singleton = (:[]) minView [] = Nothing minView (x:xs) = Just (x,xs) toList = id instance MeldableQueue [] a where merge = (++) fromFoldable = foldr (:) []