{-# 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 (:) []