```{-# LANGUAGE TypeFamilies, GeneralizedNewtypeDeriving #-}
{-# OPTIONS -fno-warn-missing-methods -fno-warn-name-shadowing #-}
{- | An efficient implementation of a priority queue.

The implementation of 'PQueue' is based on a /pairing heap/, a simple and efficient implementation of a general-purpose priority queue.  'PQueue' supports 'insert', 'merge', and 'peek' in constant time, and 'extract' and 'delete' in logarithmic time.
-}

module Data.Queue.PQueue (PQueue, drawQueue) where --, IQueue(..), QueueKey(..)) where

import Data.Queue.Class
import Data.Queue.QueueHelpers

import qualified Data.Tree as T

import Data.Maybe
import Data.Semigroup
--import Data.Monoid

-- The real meat of the pairing heap is the merge operation, and in the "balanced" merging of subtrees.  This balancing idea is sufficiently general that it's implemented in QueueHelpers, to be automatically inferred from a monoid instance, and a perfectly correct implementation falls out almost immediately.

data Tree e = T e [Tree e]
newtype PQueue e = PQ (HeapQ (Tree e)) deriving (Monoid)

instance Show e => Show (PQueue e) where
show = drawQueue

drawQueue :: Show e => PQueue e -> String
drawQueue (PQ (HQ _ (Pt t))) = maybe "" (T.drawTree . fmap show . T.unfoldTree (\ (T x ts) -> (x, ts))) t

instance Ord e => Semigroup (Tree e) where
t1@(T x1 ts1) `sappend` t2@(T x2 ts2)
| x1 <= x2	= T x1 (t2:ts1)
| otherwise	= T x2 (t1:ts2)

instance Ord e => IQueue (PQueue e) where
{-# INLINE toList_ #-}
{-# INLINE mergeAll #-}
{-# INLINE insertAll #-}

type QueueKey (PQueue e) = e

empty = PQ mempty
singleton = PQ . single
fromList xs = PQ (HQ (length xs) (Pt \$ sconcat [T x [] | x <- xs]))

xs `insertAll` q = q `mappend` fromList xs
merge = mappend
mergeAll = mconcat

extract (PQ (HQ n (Pt t))) = fmap (fmap (PQ . HQ (n-1) . Pt) . extract') t
where	extract' (T x ts) = (x, fusing ts)
toList_ (PQ (HQ _ (Pt t))) = maybe [] flatten t
where	flatten (T x ts) = x:concatMap flatten ts

null (PQ (HQ _ (Pt Nothing))) = True
null _ = False
size (PQ (HQ n _)) = n

single :: e -> HeapQ (Tree e)
single x = HQ 1 \$ pJust (T x [])

{-# RULES
-- 	"singleton/PQueue" forall (x :: Ord e => e) . singleton x = PQ (single x);
#-}
```