queuelike 1.0.6 → 1.0.7

raw patch · 14 files changed

+570/−315 lines, 14 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• Data/Queue/Fuse/Map.hs +31/−0
• Data/Queue/Fuse/PHeap.hs +101/−0
• Data/Queue/Fuse/PHeap2.hs +76/−0
• Data/Queue/Fuse/SkewHeap.hs +89/−0
• Data/Queue/Fuse/Vanilla.hs +81/−0
• Data/Queue/PQueue.hs +12/−12
• Data/Queue/QueueHelpers.hs +25/−44
• Data/Queue/TrieQueue.hs +42/−39
• Data/Queue/TrieQueue/Edge.hs +0/−14
• Data/Queue/TrieQueue/MonoidQueue.hs +0/−111
• Data/Queue/TrieQueue/MonoidQueue2.hs +0/−84
• Data/Queue/TrieQueue/TrieLabel.hs +24/−7
• Data/Semigroup.hs +75/−0
• queuelike.cabal +14/−4

@@ -0,0 +1,31 @@+{-# LANGUAGE TypeFamilies, PatternGuards #-}+module Data.Queue.Fuse.Map where++import Data.Semigroup+import Data.Queue.Class+import Data.Map+import qualified Data.Map as Map++newtype FuseMapQ k v = FMQ (Map k v) deriving (Show)++instance (Ord k, Semigroup v) => IQueue (FuseMapQ k v) where+	type QueueKey (FuseMapQ k v) = (k, v)+	empty = FMQ Map.empty+	singleton = FMQ . uncurry Map.singleton+	fromList = FMQ . Map.fromListWith sappend++	null (FMQ m) = Map.null m+	size (FMQ m) = Map.size m+	extract (FMQ m) = fmap (fmap FMQ) (Map.minViewWithKey m)+	FMQ m1 `merge` FMQ m2 = FMQ (Map.unionWith sappend m1 m2)+	mergeAll qs = FMQ (Map.unionsWith sappend [m | FMQ m <- qs])+	(k, v) `insert` FMQ m = FMQ (Map.insertWith sappend k v m)++extractSingle :: (Ord k, Semigroup v) => FuseMapQ k v -> Maybe (k, v)+extractSingle (FMQ m)+	| Map.size m == 1, (k, v) <- findMin m+		= Just (k, v)+extractSingle _ = Nothing++replace :: (Ord k, Semigroup v) => v -> FuseMapQ k v -> FuseMapQ k v+replace v (FMQ m) = FMQ (updateMin (\ _ -> Just v) m)

@@ -0,0 +1,101 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies #-}+{-# OPTIONS -fno-liberate-case #-}++{- |+This module implements the functionality of a /monoid queue/, which is essentially a priority queue that merges values with equal keys.  +Several implementations were considered:++* A pairing heap which, as part of its merging operation, merges any identical-keyed values it encounters.+	This may result in partial merging of equal-keyed values for several different keys during a single +	delete-min operation, decreasing the number of nodes in the queue without costing any additional +	comparisons (and -- since the merged values are stored lazily -- the actual merged value is not computed+	until it actually gets demanded).  Various specialized implementations of bulk merging operations are also+	possible.+* A skew heap constructed along the same lines: an extremely simple, vanilla implementation of a heap fundamentally+	based on its merge operation, modified appropriately.+* A considerably simpler bootstrap on a vanilla @PQueue@, which keeps the totally merged value associated with its very minimum key and performs no partial merging until a+	key becomes the minimum. (The fact that no partial merging is performed allows an optimized and balanced 'mconcat' to be used on all the values associated with a key at once.)+* A simple wrapper over Data.Map, which includes a variant for every one of its methods to use a combination operation+	(i.e. sappend).++Each of these implementations are included in the Cabal distribution of queuelike.++-}+module Data.Queue.Fuse.PHeap (FusePHeap, extractSingle, replace) where++import Data.Queue.Class+import Data.Queue.QueueHelpers+import Data.Semigroup+import Data.Maybe++data PHeap k v = PH k v [PHeap k v] deriving (Show)+newtype FusePHeap k v = FPH (Point (PHeap k v)) deriving (Show, Monoid)++data Merge k v = Mrg k v [v] [PHeap k v]++extractSingle :: FusePHeap k v -> Maybe (k, v)+extractSingle (FPH (Pt (Just (PH k v [])))) = Just (k,v)+extractSingle _ = Nothing++replace :: v -> FusePHeap k v -> FusePHeap k v+replace v (FPH (Pt (Just (PH k _ ts)))) = fph (Just (PH k v ts))+replace _ h = h++instance (Ord k, Semigroup v) => Semigroup (PHeap k v) where+	sappend = mergePH+	sconcat = mergePHs+	sconcat_ = mergePHs_+	+mergePH :: (Ord k, Semigroup v) => Endo (PHeap k v)+h1@(PH k1 v1 hs1) `mergePH` h2@(PH k2 v2 hs2) = case compare k1 k2 of+	LT	-> PH k1 v1 (h2:hs1)+	EQ	-> PH k1 (v1 `sappend` v2) (hs1 ++ hs2)+	GT	-> PH k2 v2 (h1:hs2)++mergePHs :: (Ord k, Semigroup v) => [PHeap k v] -> Maybe (PHeap k v)+mergePHs [] = Nothing+mergePHs (h:hs) = Just (mergePHs_ h hs)++mergePHs_ :: (Ord k, Semigroup v) => PHeap k v -> [PHeap k v] -> PHeap k v+h@(PH k0 v0 hs0) `mergePHs_` hs = case hs of+	[]	-> h+	_	-> merger k0 v0 [] hs0 hs+	where	--{-# NOINLINE merger #-}+		{-# NOINLINE cmp #-}+		cmp = compare+		{-# NOINLINE (<<|) #-}+		(<<|) = sconcat_+		merger k0 v0 vs0 hs0 (h@(PH k v hs):hss) = case cmp k k0 of+			LT	-> merger k v [] (PH k0 (v0 <<| vs0) hs0:hs) hss+			EQ	-> merger k0 v0 (v:vs0) (hs ++ hs0) hss+			GT	-> merger k0 v0 vs0 (h:hs0) hss+		merger k v vs hs [] = PH k (v <<| vs) hs++instance (Ord k, Semigroup v) => IQueue (FusePHeap k v) where+	type QueueKey (FusePHeap k v) = (k, v)+	empty = FPH pNothing --mempty+	merge = mappend+	mergeAll = mconcat++	insertAll = mappend . fph . sconcat . map single+--	insertAll = mappend . fph . fusing . map single++	singleton = fph . Just . single+--	fromList = fph . fusing . map single+	fromList = fph . sconcat . map single++	top (FPH (Pt h)) = fmap peek' h where peek' (PH k v _) = (k, v)+	delete (FPH (Pt h)) = fmap delete' h where+		delete' (PH _ _ hs) = fph $ fusing hs++	null (FPH (Pt Nothing)) = True+	null _ = False++	toList_ (FPH (Pt h)) = maybe [] (unfoldList unHeap) h where+		unHeap (PH k v hs) = ((k, v), hs)++single :: (k, v) -> PHeap k v+single (k, v) = PH k v []++fph = FPH . Pt+

@@ -0,0 +1,76 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies #-}++module Data.Queue.Fuse.PHeap2 (FusePHeap, extractSingle, replace) where++import Data.Queue.Class+import Data.Semigroup+import Data.Maybe++data PHeap k v = PH k v [PHeap k v] deriving (Show)+newtype FusePHeap k v = FPH (Point (PHeap k v)) deriving (Show, Monoid)++data Merge k v = Mrg v [v] [PHeap k v]++extractSingle :: FusePHeap k v -> Maybe (k, v)+extractSingle (FPH (Pt (Just (PH k v [])))) = Just (k,v)+extractSingle _ = Nothing++replace :: v -> FusePHeap k v -> FusePHeap k v+replace v (FPH (Pt (Just (PH k _ ts)))) = fph (Just (PH k v ts))+replace _ h = h++instance Functor (PHeap k) where+	fmap f (PH k v hs) = PH k (f v) (map (fmap f) hs)++instance Semigroup (Merge k v) where+	Mrg v1 vs1 qs1 `sappend` Mrg v2 vs2 qs2 = Mrg v1 (v2:vs1 ++ vs2) (qs1 ++ qs2)++merger :: (v -> v -> v) -> v -> [v] -> v+merger (><) h hs = case merger' h hs of (h', hs') -> foldl (><) h' hs ; where+	merger' h [] = (h, [])+	merger' h1 (h2:hs) = (h1 >< h2, case hs of+		[]	-> []+		(h3:hs)	-> case merger' h3 hs of (h, hs) -> h:hs)++instance (Ord k, Semigroup v) => Semigroup (PHeap k v) where+	sappend = mergePH+	sconcat_ = merger mergePH+	sconcat [] = Nothing+	sconcat (h:hs) = Just (merger mergePH h hs)++mergePH :: (Ord k, Semigroup v) => Endo (PHeap k v)+h1@(PH k1 v1 hs1) `mergePH` h2@(PH k2 v2 hs2) = case compare k1 k2 of+	LT	-> PH k1 v1 (h2:hs1)+	EQ	-> PH k1 (v1 `sappend` v2) (hs1 ++ hs2)+	GT	-> PH k2 v2 (h1:hs2)+	--sconcat = fusePHs sconcat_++{-# NOINLINE fusePHs #-}+fusePHs :: (Ord k) => (v -> [v] -> v) -> Fusion (PHeap k v)+fusePHs scat hs = {-cmp hs `seq`-} fmap fromMrg (fusing [single (k, Mrg v [] qs) | PH k v qs <- hs]) where+	fromMrg (PH k (Mrg v vs qs) qs0) = PH k (scat v vs) (map fromMrg qs0 ++ qs)+	cmp :: Ord k => [PHeap k v] -> k -> k -> Ordering+	cmp _ = compare++instance (Ord k, Semigroup v) => IQueue (FusePHeap k v) where+	type QueueKey (FusePHeap k v) = (k, v)+	empty = FPH pNothing --mempty+	merge = mappend+	mergeAll = mconcat++	insertAll = merge . fph . fusing . map single+	singleton = fph . Just . single+	fromList = fph . fusing . map single+	+	{-# INLINE extract #-}+	extract (FPH (Pt h)) = fmap extract' h where extract' (PH k v hs) = ((k, v), fph $ fusing hs)+--	top (FPH (Pt h)) = fmap top' h where top' (PH k v _) = (k, v)+--	delete (FPH (Pt h)) = fmap delete' h where delete' (PH _ _ hs) = fph $ fusing hs++	null (FPH (Pt Nothing)) = True+	null _ = False++single :: (k, v) -> PHeap k v+single (k, v) = PH k v []++fph = FPH . Pt

@@ -0,0 +1,89 @@+{-# LANGUAGE TypeFamilies, GeneralizedNewtypeDeriving #-}+{-# OPTIONS -fspec-constr -fspec-constr-count=8 -fspec-constr-threshold=50 #-}++module Data.Queue.Fuse.SkewHeap (FuseSHeap, extractSingle, replace) where++import Data.Semigroup+import Data.Maybe+import Data.Queue.Class+import Data.Queue.QueueHelpers+import Data.Queue.Fuse.SplitList++data SHeap k v = SH k v (MSHeap k v) (MSHeap k v) deriving (Show)+type MSHeap k v = Point (SHeap k v)+newtype FuseSHeap k v = FSH (MSHeap k v) deriving (Monoid, Show)++type Comparator e = e -> e -> Ordering++instance (Ord k, Semigroup v) => Semigroup (SHeap k v) where+	sappend = mergeSH+	sconcat = mergeSHs++{-# INLINE mergeSH #-}+mergeSH :: (Ord k, Semigroup v) => Endo (SHeap k v)+mergeSH = (mergeFuncs compare sappend)++mergeFuncs :: Comparator k -> Endo v -> Endo (SHeap k v)+mergeFuncs cmp (><) = (>!<) where+	(>?<) = endoPoint (>!<)+	h1@(SH k1 v1 l1 r1) >!< h2@(SH k2 v2 l2 r2) = case cmp k1 k2 of+		LT	-> SH k1 v1 (pJust h2 >?< r1) l1+		EQ	-> SH k1 (v1 >< v2) (l1 >?< r2) (l2 >?< r1)+		GT	-> SH k2 v2 (pJust h1 >?< r2) l2++data Merge k v = Mrg k v [v] {-# UNPACK #-} !(Split (SHeap k v)) ++{-# INLINE sh #-}+sh :: k -> v -> Maybe (SHeap k v) -> Maybe (SHeap k v) -> SHeap k v+sh k v l r = SH k v (Pt l) (Pt r)++{-# INLINE mergeSHs #-}+mergeSHs :: (Ord k, Semigroup v) => Fusion (SHeap k v)+mergeSHs = mergeSHs0 compare sappend sconcat++mergeSHs0 :: Comparator k -> Endo v -> Fusion v -> Fusion (SHeap k v)+mergeSHs0 cmp (><) cat0 = mergeSHs' where+	mergeSHs' [] = Nothing+	mergeSHs' (SH k v l r:hs0) = Just $ mrgToSH $ foldl merger (Mrg k v [] (consLR l r emptySpl)) hs0+	consLR l r spl = [q | Pt (Just q) <- [l,r]] <<| spl+	(>!<) = mergeFuncs cmp (><)+	v `cat` vs = fromJust (cat0 (v:vs))+	{-# INLINE mrgToSH #-}+	mrgToSH (Mrg k v vs subTs) = let (ls, rs) = split subTs in +		sh k (v `cat` vs) (mergeSHs' ls) (mergeSHs' rs)+	mrg@(Mrg k0 v0 vs0 subTs) `merger` h@(SH k v l r) = case cmp k k0 of+		LT	-> let (ls, rs) = split subTs in+			Mrg k v [] $ singleSpl (mrgToSH mrg)+		EQ	-> Mrg k0 v0 (v:vs0) (consLR l r subTs)+		GT	-> Mrg k0 v0 vs0 (h <| subTs)++instance (Ord k, Semigroup v) => IQueue (FuseSHeap k v) where+	type QueueKey (FuseSHeap k v) = (k, v)+	empty = mempty+	merge = mappend+	mergeAll = mconcat++	singleton = FSH . pJust . single+	fromList = fsh . sconcat . map single++	extract (FSH (Pt h)) = fmap extract' h where+		extract' (SH k v l r) = ((k,v), FSH (l `mappend` r))++	null (FSH (Pt Nothing)) = True+	null _ = False++	toList_ (FSH (Pt h)) = maybe [] (unfoldList unHeap) h where+		unHeap (SH k v l r) = ((k, v), [t | Pt (Just t) <- [l,r]])++single :: (Ord k, Semigroup v) => (k, v) -> SHeap k v+single (k, v) = SH k v mempty mempty++extractSingle :: FuseSHeap k v -> Maybe (k, v)+extractSingle (FSH (Pt (Just (SH k v (Pt Nothing) (Pt Nothing)))))+	= Just (k, v)+extractSingle _ = Nothing++replace :: v -> FuseSHeap k v -> FuseSHeap k v+replace v (FSH (Pt (Just (SH k _ l r)))) = FSH (pJust (SH k v l r))++fsh = FSH . Pt

@@ -0,0 +1,81 @@+{-# LANGUAGE TypeFamilies, GeneralizedNewtypeDeriving #-}++module Data.Queue.Fuse.Vanilla (FuseVHeap, extractSingle, replace) where++import Data.Queue.Class+import Data.Queue.PQueue+import Data.Semigroup+import Prelude hiding (null)++data Assoc k v = A k v deriving (Show)+data VHeap k v = VH k v {-# UNPACK #-} !(PQueue (Assoc k v)) deriving (Show)+newtype FuseVHeap k v = FVH (Point (VHeap k v)) deriving (Monoid, Show)++instance Eq k => Eq (Assoc k v) where+	A x _ == A y _ = x == y++instance Ord k => Ord (Assoc k v) where+	A x _ `compare` A y _ = x `compare` y+	A x _ <= A y _ = x <= y++instance (Ord k, Semigroup v) => Semigroup (VHeap k v) where+	sappend = mergeVH+	sconcat [] = Nothing+	sconcat (q:qs) = Just (mergeVHs q qs)+	sconcat_ = mergeVHs++mergeVH :: (Ord k, Semigroup v) => Endo (VHeap k v)+VH k1 v1 q1 `mergeVH` VH k2 v2 q2 = case compare k1 k2 of+	LT	-> VH k1 v1 (A k2 v2 `insert` q)+	EQ	-> VH k1 (v1 `sappend` v2) q+	GT	-> VH k2 v2 (A k1 v1 `insert` q)+	where	q = q1 `merge` q2++data Acc k v = Ac k v [v] [Assoc k v] [PQueue (Assoc k v)]++mergeVHs :: (Ord k, Semigroup v) => VHeap k v -> [VHeap k v] -> VHeap k v+mergeVHs (VH k0 v0 q0) hs = case foldl merger (Ac k0 v0 [] [] []) hs of+	Ac k v vs as qs	-> VH k (v <<| vs) (as `insertAll` mergeAll qs)+	where	Ac k v vs as qs `merger` VH k' v' q' = let qs' = q':qs in case compare k' k of+			LT -> Ac k' v' [] (A k (v <<| vs):as) qs'+			EQ -> Ac k v (v':vs) as qs'+			GT -> Ac k v vs (A k' v':as) qs'+		{-# NOINLINE (<<|) #-}+		(<<|) = sconcat_++toVH :: (Ord k, Semigroup v) => PQueue (Assoc k v) -> Maybe (VHeap k v)+toVH = fmap toVH1 . extract where+	toVH1 (A k v, q) = let	toVH' vs q = case extract q of	Just (A k' v', q') | k == k'+									-> toVH' (v':vs) q'+								_	-> VH k (sconcat_ v vs) q+				in toVH' [] q++instance (Ord k, Semigroup v) => IQueue (FuseVHeap k v) where+	type QueueKey (FuseVHeap k v) = (k, v)+	empty = fvh Nothing+	merge = mappend+	mergeAll = mconcat++	singleton = fvh . Just . single+	fromList = fvh . fusing . map single++	null (FVH (Pt Nothing)) = True+	null _ = False++	extract (FVH (Pt h)) = fmap extract' h where+		extract' (VH k v q) = ((k, v), fvh $ toVH q)++single :: (Ord k, Semigroup v) => (k, v) -> VHeap k v+single (k, v) = VH k v empty++fvh :: (Ord k, Semigroup v) => Maybe (VHeap k v) -> FuseVHeap k v+fvh = FVH . Pt++extractSingle :: Ord k => FuseVHeap k v -> Maybe (k, v)+extractSingle (FVH (Pt (Just (VH k v q))))+	| null q	= Just (k, v)+extractSingle _ = Nothing++replace :: (Ord k, Semigroup v) => v -> FuseVHeap k v -> FuseVHeap k v+replace v (FVH (Pt (Just (VH k _ q)))) = fvh (Just (VH k v q))+replace _ q = q

@@ -13,7 +13,8 @@ import qualified Data.Tree as T 	 import Data.Maybe-import Data.Monoid+import Data.Semigroup+--import Data.Monoid  import Control.Monad @@ -26,11 +27,10 @@ 	show = drawQueue  drawQueue :: Show e => PQueue e -> String-drawQueue (PQ (HQ _ t)) = maybe "" (T.drawTree . fmap show . T.unfoldTree (\ (T x ts) -> (x, ts))) t+drawQueue (PQ (HQ _ (Pt t))) = maybe "" (T.drawTree . fmap show . T.unfoldTree (\ (T x ts) -> (x, ts))) t -instance Ord e => Monoid (Tree e) where-	-- no actual mzero instance, but induces a correct Monoid instance for Heap e-	t1@(T x1 ts1) `mappend` t2@(T x2 ts2)+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) @@ -41,25 +41,25 @@  	type QueueKey (PQueue e) = e -	empty = mempty+	empty = PQ mempty 	singleton = PQ . single-	fromList xs = PQ $ fuseMergeM [single x | x <- xs]+	fromList xs = PQ (HQ (length xs) (Pt $ sconcat [T x [] | x <- xs]))  	xs `insertAll` q = q `mappend` fromList xs 	merge = mappend-	mergeAll qs = PQ (fuseMergeM [h | PQ h <- qs])+	mergeAll = mconcat -	extract (PQ (HQ n t)) = fmap (fmap (PQ . HQ (n-1)) . extract') t+	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 _ t)) = maybe [] flatten t+	toList_ (PQ (HQ _ (Pt t))) = maybe [] flatten t 		where	flatten (T x ts) = x:concatMap flatten ts -	null (PQ (HQ _ Nothing)) = True+	null (PQ (HQ _ (Pt Nothing))) = True 	null _ = False 	size (PQ (HQ n _)) = n  single :: e -> HeapQ (Tree e)-single x = HQ 1 $ Just (T x [])+single x = HQ 1 $ pJust (T x [])  {-# RULES -- 	"singleton/PQueue" forall (x :: Ord e => e) . singleton x = PQ (single x);

@@ -1,5 +1,5 @@-{-# LANGUAGE FlexibleContexts #-}-{-# OPTIONS -fno-warn-name-shadowing #-}+{-# LANGUAGE FlexibleContexts, ViewPatterns #-}+{-# OPTIONS -fno-warn-name-shadowing -fno-warn-overlapping-patterns #-}  {------------------ @@ -23,16 +23,21 @@ monoid merging operation used by nearly every priority queue implementation in this package. -------------------} -module Data.Queue.QueueHelpers (MonoidQ (..), HeapQ, fusing', endoMaybe, order, fusing, fuseMerge, fuseMergeM) where+module Data.Queue.QueueHelpers (MonoidQ (..), HeapQ, order, unfoldList) where -import Data.Monoid+import Data.Semigroup+--import Data.Monoid import Data.Maybe import Data.List(unfoldr) import GHC.Exts(build)  data MonoidQ m = HQ {elts :: Int, heap :: m} deriving (Eq, Ord, Show)-type HeapQ m = MonoidQ (Maybe m)+type HeapQ m = MonoidQ (Point m) +instance Semigroup m => Semigroup (MonoidQ m) where+	HQ n1 h1 `sappend` HQ n2 h2 = HQ (n1 + n2) (h1 `sappend` h2)+	sconcat qs = fmap (HQ $ sum [n | HQ n _ <- qs]) (sconcat [q | HQ _ q <- qs])+ instance Functor MonoidQ where 	fmap f (HQ n m) = HQ n (f m) @@ -56,35 +61,6 @@ -- decr f (HQ 0 x) = Nothing  -{-# INLINE endoMaybe #-}-endoMaybe :: (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a-endoMaybe f (Just a) (Just b)	= Just (f a b)-endoMaybe _ ma mb		= maybe mb Just ma--fusing' :: (m -> m -> m) -> [m] -> Maybe m-fusing' (><) = let-		fuser [] = Nothing-		fuser [t] = Just t-		fuser ts = fuser (fuser' ts)-		fuser' (t1:t2:t3:t4:ts) =-			(t1 >< t2) >< (t3 >< t4) : fuser' ts-		fuser' [t1,t2,t3]	= [t1 >< t2 >< t3]-		fuser' [t1,t2]		= [t1 >< t2]-		fuser' ts		= ts-	in fuser--fusing :: Monoid m => [m] -> Maybe m-fusing = fusing' mappend--{--fusing [] = Nothing-fusing [t] = Just t-fusing ts = fusing (fuse ts) where-	fuse [] = []-	fuse [t] = [t]-	fuse (t1:t2:ts) = (t1 `mappend` t2):fuse ts--}- {-# INLINE order #-} order :: (e -> e -> Ordering) -> e -> e -> (e, e) order cmp x y	| cmp x y == GT	= (y, x)@@ -94,28 +70,33 @@  {-# INLINE [2] fuseMerge #-} fuseMerge :: Monoid m => [MonoidQ m] -> MonoidQ m-fuseMerge qs = let	merger (HQ size t) (IA n ts) = IA (n + size) (t:ts)-			in case foldr merger (IA 0 []) qs of-			IA n ts -> HQ n (fromMaybe mempty (fusing ts))+fuseMerge qs = HQ (sum [n | HQ n _ <- qs]) (mconcat [t | HQ _ t <- qs]) -{-# INLINE fuseMergeM #-}-fuseMergeM :: Monoid m => [HeapQ m] -> HeapQ m+--{-# INLINE fuseMergeM #-}+{-fuseMergeM :: Monoid m => [HeapQ m] -> HeapQ m fuseMergeM qs = let	merger (HQ size (Just t)) (IA n ts) = IA (n + size) (t:ts) 			merger _ (IA n ts) = IA n ts 			in case foldr merger (IA 0 []) qs of 			IA n ts -> HQ n (fusing ts)--{-# INLINE [0] unfoldFB #-}-unfoldFB :: (b -> Maybe (a, b)) -> b -> (a -> c -> c) -> c -> c+-}+--{-# INLINE [0] unfoldFB #-}+{-unfoldFB :: (b -> Maybe (a, b)) -> b -> (a -> c -> c) -> c -> c unfoldFB suc s0 c nil = unfold' s0 where 	unfold' s = case suc s of 		Nothing	-> nil-		Just (x, s') -> x `c` unfold' s'+		Just (x, s') -> x `c` unfold' s'-} +{-# INLINE unfoldList #-}+unfoldList :: (b -> (a, [b])) -> b -> [a]+unfoldList branch root = build (\ c n -> unfoldToList c n branch root)+	where	unfoldToList cons nil branch root = unfold' root nil where+			unfold' (branch -> (x, ts)) nil = x `cons` foldr unfold' nil ts++ {-# RULES 	"[] ++" forall l . [] ++ l = l; 	"++ []" forall l . l ++ [] = l;-	"fuseMerge/HeapQ" forall (qs :: Monoid m => [MonoidQ (Maybe m)]) . fuseMerge qs = fuseMergeM qs;+--	"fuseMerge/HeapQ" forall (qs :: Monoid m => [MonoidQ (Maybe m)]) . fuseMerge qs = fuseMergeM qs; --	"unfold" [~1] forall suc s0 . unfoldr suc s0 = build (unfoldrFB suc s0) 	#-} 

@@ -1,4 +1,4 @@-{-# LANGUAGE TypeFamilies, PatternGuards #-}+{-# LANGUAGE TypeFamilies, PatternGuards, GeneralizedNewtypeDeriving #-}  -- | @TrieQueue e@ is a priority queue @IQueue@ instance satisfying @QueueKey (TrieQueue e) ~ [e]@, with the property that this queue frequently performs better than any other queue -- implementation in this package for keys of type @[e]@.  @@ -11,14 +11,16 @@  import Control.Arrow((***)) import Control.Monad-import Data.Monoid+import Data.Semigroup+--import Data.Monoid import Data.Maybe  import Data.Queue.Class-import Data.Queue.QueueHelpers(fusing')+import Data.Queue.QueueHelpers -import Data.Queue.TrieQueue.Edge-import Data.Queue.TrieQueue.MonoidQueue+import Data.Queue.Fuse.PHeap+--import Data.Queue.TrieQueue.Edge+--import Data.Queue.TrieQueue.MonoidQueue import Data.Queue.TrieQueue.TrieLabel  import GHC.Exts@@ -28,7 +30,7 @@ -- On the back end it uses something called a /monoid queue/, -- which takes ordered keys associated with monoid values and returns (k, m') pairs where m' is the concatenation of every monoid value associated with k, -- with no guarantees made upon the order of the concatenation.  Essentially, it is a priority queue which internally "merges" values with equal keys.--- See Data.Queue.TrieQueue.MonoidQueue for details and a list of alternative implementations.+-- See Data.Queue.Fuse.PHeap for details and a list of alternative implementations.  -- After some experimentation, trie edge labels are currently implemented as vanilla lists; however, the implementation is modularized in -- Data.Queue.TrieQueue.EdgeLabel.  (Other possible implementations include mergeable deques and Data.Sequence finger trees.)@@ -38,20 +40,19 @@ -- random-access string lookup is not required in a priority queue: only extract-min and insert, operations perfectly well suited to a monoid queue. -- Note that the monoid values in the monoid queue are themselves tries, which get recursively merged as necessary. -data Trie e = Trie (Label e) {-# UNPACK #-} !Int (MQueue e (Trie e)) deriving (Show)-data TrieQueue e = TQ Int (Maybe (Trie e)) deriving (Show)+data Trie e = Trie (Label e) {-# UNPACK #-} !Int (FusePHeap e (Trie e)) deriving (Show)+newtype TrieQueue e = TQ (HeapQ (Trie e)) deriving (Monoid, Show)  -- This monoid instance can now get exploited for great justice by the monoid queue.-instance Ord e => Monoid (Trie e) where-	mempty = Trie mempty 0 mempty-	mappend = mergeTrie-	mconcat = fromMaybe mempty . mergeTries+instance Ord e => Semigroup (Trie e) where+	sappend = mergeTrie+	sconcat = mergeTries -{-# INLINE forceOrd #-}-forceOrd :: Ord e => Trie e -> x -> x+--{-# INLINE forceOrd #-}+{-forceOrd :: Ord e => Trie e -> x -> x forceOrd t x = cmp t `seq` x where 	cmp :: Ord e => Trie e -> (e -> e -> Ordering)-	cmp _ = compare+	cmp _ = compare-}  catTrie :: Ord e => Label e -> Trie e -> Trie e xs `catTrie` Trie ys yn yQ = Trie (xs `mappend` ys) yn yQ@@ -59,32 +60,34 @@ consTrie :: Ord e => e -> Trie e -> Trie e x `consTrie` Trie xs xn xQ = Trie (x `cons` xs) xn xQ -mergeTrie :: Ord e => Trie e -> Trie e -> Trie e+mergeTrie :: Ord e => Endo (Trie e) xT@(Trie xs0 xn xQ) `mergeTrie` yT@(Trie ys0 yn yQ) = merging xs0 ys0 split (tail xT yT) (tail yT xT) xy where-	end (Trie _ xn xQ) x xs = x :- Trie xs xn xQ+	end (Trie _ xn xQ) x xs = (x, Trie xs xn xQ) 	split pfx x xs y ys = let xEnd = end xT x xs; yEnd = end yT y ys in Trie pfx 0 (xEnd `insert` singleton yEnd) 	tail (Trie xs xn xQ) yT y ys = let yEnd = end yT y ys in Trie xs xn (yEnd `insert` xQ) 	xy = Trie xs0 (xn + yn) (xQ `merge` yQ) -{-# INLINE compactTrie #-}+--{-# INLINE compactTrie #-} compactTrie :: Ord e => Trie e -> Maybe (Trie e) compactTrie (Trie xs 0 xQ) 	| null xQ	= Nothing-	| Just (y :- t) <- extractSingle xQ+	| Just (y, t) <- extractSingle xQ 			= Just (xs `catTrie` (y `consTrie` t)) compactTrie t = Just t -data Acc e = A {-# UNPACK #-} !Int e+data Acc e f = A {-# UNPACK #-} !Int e f  -- Note that a monoid queue is built up and (sometimes) torn down for each character.  If every label on every trie being merged matches -- on the first character, then the monoid queue simply automatically becomes a singleton, a case handled by compactTrie with a specialized -- implementation based on extractSingle.  If the labels do not match, or there are tries being merged with empty labels, -- then the monoid queue is exactly what we needed anyway.-mergeTries :: Ord e => [Trie e] -> Maybe (Trie e)-mergeTries ts0 = compactTrie (Trie mempty nEmpty ([x :- Trie xs xn xQ | Trie (x:xs) xn xQ <- ts0] `insertAll` mergeAll qs))-	where	A nEmpty qs = foldr procEmpty (A 0 []) ts0-		procEmpty (Trie [] n q) (A nEmpty qs) = A (n + nEmpty) (q:qs)-		procEmpty _ acc = acc +mergeTries :: Ord e => Fusion (Trie e)+mergeTries ts0 = compactTrie (Trie mempty nEmpty (combine es qs))+	where	combine es qs = es `insertAll` mergeAll qs+		A nEmpty qs es = foldl procEmpty (A 0 [] []) ts0+		A nEmpty qs es `procEmpty` Trie xs n q = case uncons xs of+			Nothing	-> A (n + nEmpty) (q:qs) es+			Just (x, xs) -> A nEmpty qs ((x, Trie xs n q):es) --mergeTries = fusing' mergeTrie  {-# INLINE fin #-}@@ -98,35 +101,35 @@ extractTrie :: Ord e => Trie e -> (Label e, Maybe (Trie e)) extractTrie (Trie xs (n+1) xQ) = (xs, inline compactTrie (Trie xs n xQ)) extractTrie (Trie xs 0 xQ)-	| Just (y :- t, xQ') <- extract xQ, (ys, t') <- extractTrie t+	| Just (y, t) <- top xQ, (ys, t') <- extractTrie t 		= (xs `mappend` (y `cons` ys), case t' of-			Nothing	-> inline compactTrie (Trie xs 0 xQ')-			Just t'	-> fin (Trie xs 0 $ replace (y :- t') xQ))+			Nothing	-> delete xQ >>= inline compactTrie . Trie xs 0+			Just t'	-> Just (Trie xs 0 $ replace t' xQ)) extractTrie _ = error "Failure to detect empty queue" -instance Ord e => Monoid (TrieQueue e) where-	mempty = TQ 0 Nothing-	TQ n1 t1 `mappend` TQ n2 t2 = TQ (n1 + n2) (t1 `mappend` t2)-	mconcat ts = TQ (sum [n | TQ n _ <- ts]) (mergeTries [t | TQ _ (Just t) <- ts])- instance Ord e => IQueue (TrieQueue e) where 	type QueueKey (TrieQueue e) = [e] 	empty = mempty 	merge = mappend 	mergeAll = mconcat 	-	singleton = TQ 1 . Just . single+	singleton = TQ . HQ 1 . pJust . single 	insertAll = mappend . fromListTrie 	fromList = fromListTrie -	extract (TQ n t) = fmap ((labelToList *** TQ (n-1)) . extractTrie) t-	null (TQ _ Nothing) = True+	extract (TQ (HQ n (Pt t))) = fmap ((labelToList *** (TQ . HQ (n-1) . Pt)) . extractTrie) t+	null (TQ (HQ _ (Pt Nothing))) = True 	null _ = False -	size (TQ n _) = n+	size (TQ (HQ n _)) = n +	toList (TQ (HQ _ (Pt t))) = maybe [] trieToList t where+		trieToList (Trie xs xn xQ) = replicate xn xs ++ [xs ++ y:ys | (y, t) <- toList xQ, ys <- trieToList t]+	toList_ (TQ (HQ _ (Pt t))) = maybe [] trieToList_ t where+		trieToList_ (Trie xs xn xQ) = replicate xn xs ++ [xs ++ y:ys | (y, t) <- toList_ xQ, ys <- trieToList_ t]+ fromListTrie :: Ord e => [[e]] -> TrieQueue e-fromListTrie = liftM2 TQ length (mergeTries . map single)+fromListTrie = TQ . liftM2 HQ length (Pt . mergeTries . map single)  single :: Ord e => [e] -> Trie e-single xs = Trie (labelFromList xs) 1 mempty+single xs = Trie (labelFromList xs) 1 empty

@@ -1,14 +0,0 @@-{-# LANGUAGE TypeFamilies, TypeOperators #-}---- | As simple as it looks: an edge type constructor that performs comparisons only on its key.-module Data.Queue.TrieQueue.Edge ((:-)(..)) where--data k :- m = k :- m deriving (Show)--instance Eq k => Eq (k :- m) where-	(x :- _) == (y :- _) = x == y--instance Ord k => Ord (k :- m) where-	(x :- _) `compare` (y :- _) = x `compare` y-	(x :- _) <= (y :- _) = x <= y-

@@ -1,111 +0,0 @@-{-# LANGUAGE TypeFamilies, TypeOperators, PatternGuards #-}-{-# OPTIONS -fno-warn-missing-methods #-}--{- |-This module implements the functionality of a /monoid queue/, which is essentially a priority queue that merges values with equal keys.  Several implementations were considered:--* A pairing heap which, as part of its merging operation, merges any identical-keyed values it encounters.  This may result in partial merging of equal-keyed values for several different keys-	during a single delete-min operation, decreasing the number of nodes in the queue without costing any additional comparisons.  In addition, it naturally falls out that-	the values associated with the minimum key are always fully merged.  Disadvantages include no control over the balancedness of complete merges, and possible extra polymorphism overhead.-* This considerably simpler bootstrap on a vanilla @PQueue@, which keeps the totally merged value associated with its very minimum key and performs no partial merging until a-	key becomes the minimum. (The fact that no partial merging is performed allows an optimized and balanced 'mconcat' to be used on all the values associated with a key at once.)--The primary difference between these two is the compromise between /performance of the heap itself/ and /performance of the merging of the monoids/:-	* The first implementation speculatively takes advantage of opportunities to merge nodes with equal keys.  No actual extra work is being done -- the same number of comparisons-		is made, and the actual merging is performed lazily.  As a result, truly the only disadvantages of this approach are the completely uncontrolled balance of the merges,-		and possible polymorphism overhead that can be carefully hand-removed.-	* The second implementation allows an optimized bulk merge operation, which -- in the case of tries, which is what after all the motivation for this structure ---		has extremely significant advantages.--A version of the second implementation is included with the Cabal distribution in -"Data.Queue.TrieQueue.MonoidQueue2", and can serve as a literal drop-in replacement for this module.-See its implementation notes for further details.---}-module Data.Queue.TrieQueue.MonoidQueue (MQueue, extractSingle, replace) where--import Data.Queue.Class-import Data.Queue.QueueHelpers(fusing')-import Data.Maybe-import Data.Monoid-import qualified Data.Tree as Tree--import Data.Queue.TrieQueue.Edge---- | A pairing heap node in the monoid queue; nonempty.-data MNode k m = Node k m (MForest k m)-type MForest k m = [MNode k m]--- | A full-fledged priority queue, including empty queues.-newtype MQueue k m = MQ (Maybe (MNode k m)) deriving (Show)--instance (Show k, Show m) => Show (MNode k m) where-	show = Tree.drawTree . Tree.unfoldTree (\ (Node k m ts) -> (show (k :- m), ts))---- | A @Functor@ instance exploited for great justice in @mergeNodes@.-instance Functor (MNode k) where-	fmap f (Node k m ns) = Node k (f m) (map (fmap f) ns)--instance (Ord k, Monoid m) => Monoid (MNode k m) where-	-- no mempty declaration-	mappend = mergeMNode $! mappend--instance (Ord k, Monoid m) => Monoid (MQueue k m) where-	mempty = MQ Nothing-	MQ n1 `mappend` MQ n2 = MQ (n1 `mappend` n2)-	 -- This is the straightforward implementation:-	 -- mconcat qs = MQ $ fusing [n | MQ (Just n) <- qs]-	 -- This implementation allows optimized mass mconcats rather than just using individual mappends,-	 -- and exploits the flexible monoid structure.-	mconcat qs = mergeNodes [n | MQ (Just n) <- qs]---mergeMNode :: Ord k => (m -> m -> m) -> MNode k m -> MNode k m -> MNode k m-mergeMNode (><) n1@(Node k1 m1 ns1) n2@(Node k2 m2 ns2) = case compare k1 k2 of-	LT	-> Node k1 m1 (n2:ns1)-	EQ	-> Node k1 (m1 >< m2) (ns1 ++ ns2)-	GT	-> Node k2 m2 (n1:ns2)--{-# INLINE mergeNodes' #-}--- | Merges a collection of nodes by performing a balanced fuse and performing an mconcat on all blocks of equal-keyed monoid values.-mergeNodes' :: (Ord k) => (k -> k -> Ordering) -> (m -> m -> m) -> MForest k m -> MQueue k m---mergeNodes ns = MQ (fmap (fmap mconcat) $ fusing (map (fmap $ \ m -> [m]) ns))-mergeNodes' _ (><) = MQ . fusing' (mergeMNode (><))--{-# INLINE mergeNodes #-}-mergeNodes :: (Ord k, Monoid m) => MForest k m -> MQueue k m-mergeNodes = (mergeNodes' $! compare) $! mappend--instance (Ord k, Monoid m) => IQueue (MQueue k m) where-	type QueueKey (MQueue k m) = k :- m-	empty = mempty-	merge = mappend-	mergeAll = mconcat--	singleton (k :- m) = MQ (Just (Node k m []))-	insertAll = merge . fromListMQ-	fromList = fromListMQ-	extract = extractMQ--	null (MQ Nothing) = True-	null _ = False--{-# INLINE single #-}-single :: k :- m -> MNode k m-single (k :- m) = Node k m []--extractMQ :: (Ord k, Monoid m) => MQueue k m -> Maybe (k :- m, MQueue k m)-extractMQ (MQ t) = fmap extract' t where-	extract' (Node k m ns) = (k :- m, mergeNodes ns)--fromListMQ :: (Ord k, Monoid m) => [k :- m] -> MQueue k m-fromListMQ ks = mergeNodes $ map single ks--{-# INLINE extractSingle #-}-extractSingle :: (Ord k, Monoid m) => MQueue k m -> Maybe (k :- m)-extractSingle (MQ (Just (Node k m []))) = Just (k :- m)-extractSingle _ = Nothing---- UNSAFE.  Do not use unless you know the key you're putting in is less than or equal to the minimum key.-replace :: (Ord k, Monoid m) => (k :- m) -> MQueue k m -> MQueue k m-replace km@(k :- m) (MQ t) = MQ $ Just (maybe (single km) (\ (Node _ _ ns) -> Node k m ns) t)-

@@ -1,84 +0,0 @@-{-# LANGUAGE TypeFamilies, TypeOperators, PatternGuards #-}--module Data.Queue.TrieQueue.MonoidQueue2 (MQueue, extractSingle, replace) where--import Data.Queue.PQueue-import Data.Queue.Class-import Data.Queue.QueueHelpers (fusing, fusing')--import Data.Queue.TrieQueue.Edge--import Data.Maybe-import Data.Monoid-import Prelude hiding (null)--data MQueue k m = Nil | MQ {-# UNPACK #-} !(k :- m) {-# UNPACK #-} !(PQueue (k :- m)) deriving (Show)--instance (Ord k, Monoid m) => Monoid (MQueue k m) where-	mempty = Nil-	mappend = mergeMQ-{--Here we organize on the queues themselves.  We require that fromList not be defined in terms of mergeAll, of course -- in fact, if it is defined using toQueue as it is below,-this gives us the best of both worlds -- balanced merging both on the values associated with the minimum key (provided by fromList), and balanced merging on the remaining queues.-We lose some partial merging opportunities, but this implementation does none, so that's not an issue.--}-	mconcat qs = case mkMQueue [k :- (m, q) | MQ (k :- m) q <- qs] of-		Nil	-> Nil-		MQ (k :- (m, pq)) qOfMQs -> -			let q' = pq `merge` mergeAll -					[(k :- m) `insert` q | k :- (m, q) <- toList_ qOfMQs]-				in MQ (k :- m) q'-		where	mkMQueue :: (Ord k, Monoid m) => [k :- m] -> MQueue k m-			mkMQueue = fromList----	mconcat = fromMaybe Nil . fusing' mergeMQ--mergeMQ' :: Ord k => (k -> k -> Ordering) -> (m -> m -> m) -> MQueue k m -> MQueue k m -> MQueue k m-mergeMQ' cmp (><) (MQ x1@(k1 :- m1) q1) (MQ x2@(k2 :- m2) q2) = case cmp k1 k2 of-	LT	-> MQ x1 (x2 `insert` q)-	EQ	-> MQ (k1 :- (m1 >< m2)) q-	GT	-> MQ x2 (x1 `insert` q)-	where	q = q1 `merge` q2-mergeMQ' _ _ q Nil = q-mergeMQ' _ _ Nil q = q--mergeMQ :: (Ord k, Monoid m) => MQueue k m -> MQueue k m -> MQueue k m-mergeMQ = mergeMQ' compare mappend--instance (Ord k, Monoid m) => IQueue (MQueue k m) where-	type QueueKey (MQueue k m) = (k :- m)-	empty = Nil-	singleton = (`MQ` empty)-	fromList = toQueue . fromList--	merge = mappend-	mergeAll = mconcat--	null Nil = True-	null _ = False-	-	extract Nil = Nothing-	extract (MQ x q) = Just (x, toQueue q)--	toList_ Nil = []-	toList_ (MQ x q) = x:toList_ q---- This version ignores balancing and does a totally simple merge on values with the minimal key in common.-toQueue :: (Ord k, Monoid m) => PQueue (k :- m) -> MQueue k m-toQueue q = case extract q of-	Nothing		-> Nil-	Just (k :- m, q') -> let toQueue' ms q = case extract q of	Just (k' :- m', q')-										| k == k'	-> toQueue' (m':ms) q'---									_			-> MQ (k :- maybe m (mappend m) (fusing ms)) q-									_	| [] <- ms	-> MQ (k :- m) q-										| otherwise	-> MQ (k :- (m `mappend` mconcat ms)) q-					in toQueue' [] q'--extractSingle :: Ord k => MQueue k m -> Maybe (k :- m)-extractSingle (MQ x q)-	| null q	= Just x-extractSingle _ = Nothing--replace :: (Ord k, Monoid m) => (k :- m) -> MQueue k m -> MQueue k m-replace (k :- m) (MQ _ q) = MQ (k :- m) q-replace _ Nil = error "Attempt to modify head of an empty queue"

@@ -17,20 +17,23 @@  {-# INLINE merging #-} -- | Performs partial matching of two labels and applies an appropriate function upon completing a partial match.-merging :: Eq e => Label e		-- ^ A label, @xs@.-			-> Label e	-- ^ A label, @ys@.-			-> Split e x	-- ^ A function to be applied when the two strings share some (possibly empty) common prefix and mismatchng tails.-			-> Tail e x	-- ^ A function to be applied when @xs@ is a prefix of @ys@.-			-> Tail e x 	-- ^ A function to be applied when @ys@ is a prefix of @xs@.-			-> x		-- ^ A value to be returned when @xs == ys@.+merging :: Eq e => Label e		-- A label, @xs@.+			-> Label e	-- A label, @ys@.+			-> Split e x	-- A function to be applied when the two strings share some (possibly empty) common prefix and mismatchng tails.+			-> Tail e x	-- A function to be applied when @xs@ is a prefix of @ys@.+			-> Tail e x 	-- A function to be applied when @ys@ is a prefix of @xs@.+			-> x		-- A value to be returned when @xs == ys@. 			-> x  cons :: e -> Label e -> Label e+{-# INLINE uncons #-}+uncons :: Label e -> Maybe (e, Label e)  labelToList :: Label e -> [e]  labelFromList :: [e] -> Label e + merging xs0 ys0 split xEnd yEnd xy = merging' 0 xs0 ys0 where 	merging' n xs ys = let pfx = take n xs0 in case (xs, ys) of 		(x:xs, y:ys)	| x == y	-> merging' (n+1) xs ys@@ -41,10 +44,17 @@ type Label e = [e]  cons = (:)++uncons [] = Nothing+uncons (x:xs) = Just (x,xs)+ labelToList = id labelFromList = id++ {- + type Label e = Seq e  merging xs0 ys0 split xEnd yEnd xy = merging' 0 (Fold.toList xs0) (Fold.toList ys0) where@@ -55,15 +65,22 @@ 		([], y:ys)			-> xEnd y yT 		([], [])			-> xy +uncons xs = case viewl xs of+	x :< xs	-> Just (x, xs)+	EmptyL	-> Nothing+ cons = (<|)  labelToList = Fold.toList  labelFromList = Seq.fromList--} + testMerging :: (Eq e, Show e) => Label e -> Label e -> String testMerging xs0 ys0 = merging xs0 ys0 (\ pfx x xs y ys -> "Split " ++ show pfx ++ " (" ++ show x ++ " -> " ++ show xs ++ ") (" ++ show y ++ " -> " ++ show ys ++ ")") 				(\ y ys -> "Break " ++ show xs0 ++ " = " ++ show y ++ " -> " ++ show ys) 				(\ x xs -> "Break " ++ show ys0 ++ " = " ++ show x ++ " -> " ++ show xs) 				("Equal " ++ show xs0)+++-}

@@ -0,0 +1,75 @@+{-# LANGUAGE MagicHash, UnboxedTuples, GeneralizedNewtypeDeriving, FlexibleInstances, UndecidableInstances, OverlappingInstances #-}++module Data.Semigroup (Monoid(..), Endo, Fusion, Point(..), Semigroup(..), endoMaybe, endoPoint, fusing', fusing, fuseCat, scatPoints', scatPoints, pJust, pNothing) where++import Data.Monoid(Monoid(..))+import Data.Maybe+import GHC.Exts++type Endo a = a -> a -> a+type Fusion a = [a] -> Maybe a+newtype Point a = Pt (Maybe a) deriving (Functor, Eq, Show, Read)++class Semigroup a where+	sappend :: Endo a+	sconcat :: Fusion a+	sconcat = fusing+	sconcat_ :: a -> [a] -> a+	sconcat_ x xs = fromJust (sconcat (x:xs))++instance Monoid a => Semigroup a where+	sappend = mappend+	sconcat = Just . mconcat+	sconcat_ x xs = mconcat (x:xs)++{-instance Semigroup a => Semigroup (Maybe a) where+	sappend = endoMaybe sappend+	sconcat xs = Just (sconcat [x | Just x <- xs])-}++instance Semigroup a => Monoid (Point a) where+	mempty = Pt Nothing+	mappend = endoPoint sappend+	mconcat = Pt . scatPoints++{-# INLINE [1] endoMaybe #-}+endoMaybe :: Endo a -> Endo (Maybe a)+endoMaybe (><) (Just a) = Just . maybe a (a ><)+endoMaybe _ Nothing = id++{-# RULES "endoMaybe/Just" forall f a b . endoMaybe f a (Just b) = Just (maybe b (`f` b) a) #-}++{-# INLINE endoPoint #-}+endoPoint :: Endo a -> Endo (Point a)+endoPoint (><) (Pt a) (Pt b) = Pt (endoMaybe (><) a b)++fusing' :: Endo a -> Fusion a+fusing' _ [] = Nothing+fusing' (><) (q:qs) = Just $ fuseCat (><) q qs++fuseCat :: Endo a -> a -> [a] -> a+fuseCat (><) = fuseCat' where+	fuseCat' x [] = x+	fuseCat' x xs = case fuse1 x xs of ( x', xs' ) -> fuseCat' x' xs'+	fuse1 x1 (x2:x3:x4:xs) = ( (x1 >< x2) >< (x3 >< x4), fuser xs )+	fuse1 x1 [x2,x3] = ( x1 >< x2 >< x3, [] )+	fuse1 x1 [x2] = ( x1 >< x2, [] )+	fuse1 x1 [] = ( x1, [] )+	fuser [] = []+	fuser (x:xs) = case fuse1 x xs of ( x, xs ) -> x:xs++fusing :: Semigroup a => Fusion a+fusing = fusing' sappend++{-# INLINE scatPoints' #-}+scatPoints' :: Fusion a -> [Point a] -> Maybe a+scatPoints' cat xs = cat [x | Pt (Just x) <- xs]++{-# INLINE scatPoints #-}+scatPoints :: Semigroup a => [Point a] -> Maybe a+scatPoints = scatPoints' sconcat++pJust :: a -> Point a+pJust = Pt . Just++pNothing :: Point a+pNothing = Pt Nothing

@@ -1,5 +1,5 @@ name:		queuelike-version:	1.0.6+version:	1.0.7 synopsis:	A library of queuelike data structures, both functional and stateful. description:	Contains several implementations of data structures implementing a /single-in, single-out/ paradigm.  Intended to be a better, more useful replacement for pqueue-mtl. 		In particular, includes an experimental and possibly genuinely new trie-based priority queue on strings.  Feedback is appreciated.@@ -27,11 +27,21 @@ 	Data.MQueue.Chan 	Data.MQueue other-modules: +	Data.Semigroup 	Data.Queue.QueueHelpers-	Data.Queue.TrieQueue.Edge-	Data.Queue.TrieQueue.MonoidQueue+--	Data.Queue.TrieQueue.Edge+--	Data.Queue.TrieQueue.MonoidQueue+	Data.Queue.Fuse.PHeap+--	Data.Queue.Fuse.PHeap2+--	Data.Queue.Fuse.SkewHeap+--	Data.Queue.Fuse.SplitList 	Data.Queue.TrieQueue.TrieLabel 	Data.MQueue.MonadHelpers extra-source-files:-	Data/Queue/TrieQueue/MonoidQueue2.hs+--	Data/Queue/TrieQueue/MonoidQueue2.hs+-- various implementations of fusing queues+	Data/Queue/Fuse/PHeap2.hs+	Data/Queue/Fuse/Vanilla.hs+	Data/Queue/Fuse/SkewHeap.hs+	Data/Queue/Fuse/Map.hs ghc-options: