{-# LANGUAGE BangPatterns #-}
{-# OPTIONS -fno-warn-name-shadowing #-}

{------------------

This module builds structure common to instances of functional heaps, using monoidal structure.
A HeapQ consists of a size tag and a monoidally structured tree type, probably lacking a 'true' mzero.
This module automatically lifts monoidal stucture from the tree type to the HeapQ, and provides a common mconcat implementation
that provides balanced, linear-time heap merging.  Then a new heap can work as follows:

data FooHeap e = ...
newtype FooQueue e = FQ (HeapQ (FooHeap e)) deriving (Monoid)

instance Queuelike (FooQueue e) where
	empty = mempty
	merge = mappend
	mergeAll = mconcat
	...

-------------------}

module Data.Queue.QueueHelpers (HeapQ(..), endoMaybe, order, fusing) where

import Data.Monoid

data HeapQ m = HQ {elts :: {-# UNPACK #-} !Int, heap :: Maybe m}

instance Monoid m => Monoid (HeapQ m) where
	{-# INLINE mappend #-}
	{-# INLINE mconcat #-}

	mempty = HQ 0 mempty
	HQ n1 h1 `mappend` HQ n2 h2 = HQ (n1 + n2) (h1 `mappend` h2)
	mconcat qs = uncurry HQ $ fuseMerge [(n, h) | HQ n h <- qs]

{-# INLINE endoMaybe #-}
endoMaybe :: (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a
endoMaybe f (Just a) (Just b)	= Just (f a b)
endoMaybe _ ma Nothing		= ma
endoMaybe _ _ mb		= mb

{-# INLINE fusing #-}
fusing :: Monoid m => [m] -> Maybe m
fusing [] = Nothing
fusing [t] = Just t
fusing ts = fusing (fuse mappend ts) where
	fuse !f (t1:t2:ts) = (t1 `f` t2):fuse f ts
	fuse _ ts = ts

{-# INLINE order #-}
order :: (e -> e -> Ordering) -> e -> e -> (e, e)
order cmp x y	| cmp x y == GT	= (y, x)
		| otherwise	= (x, y)

data IntAcc e = IA {-# UNPACK #-} !Int e

{-# INLINE fuseMerge #-}
fuseMerge :: Monoid m => [(Int, Maybe m)] -> (Int, Maybe m)
fuseMerge qs = let IA n ts = foldr merger (IA 0 []) qs in (n, fusing ts) where
	merger (m, mt) (IA n ts) = case mt of
		Nothing	-> IA n ts
		Just t	-> IA (n+m) (t:ts)