packages feed

pqueue-mtl 1.0 → 1.0.1

raw patch · 5 files changed

+44/−66 lines, 5 filesdep ~stateful-mtl

Dependency ranges changed: stateful-mtl

Files

Control/Monad/Queue/Class.hs view
@@ -8,7 +8,7 @@ import Control.Monad.Reader import Control.Monad.Maybe import Control.Monad.Array-import Control.Monad.ST.Trans+-- import Control.Monad.ST.Trans import Control.Monad.Trans.Operations import qualified Control.Monad.Writer.Strict as StrictW import qualified Control.Monad.Writer.Lazy as LazyW@@ -112,25 +112,7 @@ 	queueEmpty = lift queueEmpty 	queueSize = lift queueSize 	-instance MonadQueue e m => MonadQueue e (ArrayT f m) where-	queueInsert = lift . queueInsert-	queueInsertAll = lift . queueInsertAll-	queueExtract = lift queueExtract-	queueDelete = lift queueDelete-	queuePeek = lift queuePeek-	queueEmpty = lift queueEmpty-	queueSize = lift queueSize-	 instance MonadQueue e m => MonadQueue e (IntMapT f m) where-	queueInsert = lift . queueInsert-	queueInsertAll = lift . queueInsertAll-	queueExtract = lift queueExtract-	queueDelete = lift queueDelete-	queuePeek = lift queuePeek-	queueEmpty = lift queueEmpty-	queueSize = lift queueSize--instance MonadQueue e m => MonadQueue e (STT s m) where 	queueInsert = lift . queueInsert 	queueInsertAll = lift . queueInsertAll 	queueExtract = lift queueExtract
Control/Monad/Queue/Heap.hs view
@@ -1,6 +1,6 @@-{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, UndecidableInstances #-}+{-# LANGUAGE RankNTypes, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, UndecidableInstances #-} -module Control.Monad.Queue.Heap (HeapT, HeapM, runHeapT, runHeapM) where+module Control.Monad.Queue.Heap (HeapM, runHeapM) where  import Control.Monad.State.Strict import Control.Monad.Array@@ -10,31 +10,28 @@ import Control.Monad.Queue.Class import Control.Monad.Identity --- | Monad transformer based on an array implementation of a standard binary heap.-newtype HeapT e m a = HeapT {runHeapT :: ArrayT e (StateT Int m) a} deriving (Monad, MonadReader r, MonadST s, MonadWriter w, MonadFix, MonadIO)-type HeapM e = HeapT e Identity---- | Runs an 'HeapT' transformer starting with an empty heap.-runHeapT :: (Monad m, Ord e) => HeapT e m a -> m a-runHeapT m = evalStateT (runArrayT_ 16 (runHeapT m)) 0+-- | Monad based on an array implementation of a standard binary heap.+newtype HeapM s e a = HeapM {execHeapM :: StateT Int (ArrayM s e) a}  --- | Runs an 'HeapT' transformer starting with a heap initialized to hold the specified list.  (Since this can be done with linear preprocessing, this is more efficient than inserting the elements one by one.)-runHeapTOn :: (Monad m, Ord e) => HeapT e m a -- ^ The transformer operation.-					-> Int -- ^ The starting size of the heap (must be equal to the length of the list)-					-> [e] -- ^ The initial contents of the heap-					-> m a-runHeapTOn m n l = flip evalStateT n $ runArrayT_ 16 $ do	mapM_ (uncurry unsafeWriteAt) (zip [0..] l)-								mapM_ (\ i -> unsafeReadAt i >>= heapDown n i) [0..n-1]-								runHeapT m+instance Monad (HeapM s e) where+	return x = HeapM (return x)+	m >>= k = HeapM (execHeapM m >>= execHeapM . k) -runHeapM :: Ord e => HeapM e a -> a-runHeapM = runIdentity . runHeapT+instance MonadST s (HeapM s e) where+	liftST = HeapM . liftST -runHeapMOn :: Ord e => HeapM e a -> Int -> [e] -> a-runHeapMOn m n l = runIdentity (runHeapTOn m n l)+-- | Runs an 'HeapM' computation starting with an empty heap.+runHeapM :: Ord e => (forall s . HeapM s e a) -> a+runHeapM m = runArrayM_ 16 (evalStateT (execHeapM m) 0) -instance MonadTrans (HeapT e) where-	lift = HeapT . lift . lift+-- | Runs an 'HeapM' computation starting with a heap initialized to hold the specified list.  (Since this can be done with linear preprocessing, this is more efficient than inserting the elements one by one.)+runHeapTOn :: (Ord e) => (forall s . HeapM s e a) -- ^ The transformer operation.+				-> Int -- ^ The starting size of the heap (must be equal to the length of the list)+				-> [e] -- ^ The initial contents of the heap+				-> a+runHeapTOn m n l = runArrayM_ 16 $ flip evalStateT n $ do	mapM_ (uncurry unsafeWriteAt) (zip [0..] l)+								mapM_ (\ i -> unsafeReadAt i >>= heapDown n i) [0..n-1]+								execHeapM m  ensureHeap :: MonadArray e m => Int -> m () ensureHeap n = do	cap <- getSize@@ -58,22 +55,17 @@ 					if al < x then unsafeWriteAt i al >> unsafeWriteAt lch x else unsafeWriteAt i x 			GT	-> unsafeWriteAt i x -instance (Ord e, Monad m) => MonadQueue e (HeapT e m) where-	{-# SPECIALIZE instance Ord e => MonadQueue e (HeapT e Identity) #-}-	queuePeek = HeapT $ do	+instance (Ord e) => MonadQueue e (HeapM s e) where+	queuePeek = HeapM $ do	 		size <- get 		if size > 0 then liftM Just (unsafeReadAt 0) else return Nothing-	queueInsert x = HeapT $ do+	queueInsert x = HeapM $ do 		size <- get 		ensureHeap (size+1) 		put (size + 1) 		heapUp size x-	queueDelete = HeapT $ do+	queueDelete = HeapM $ do 		size <- get 		put (size - 1) 		unsafeReadAt (size - 1) >>= heapDown (size - 1) 0 >> unsafeWriteAt (size-1) undefined-	queueSize = HeapT get--instance MonadState s m => MonadState s (HeapT e m) where-	get = lift get-	put = lift . put+	queueSize = HeapM get
Data/Queue/FibQueue.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE ViewPatterns, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts #-}+{-# LANGUAGE RankNTypes, ViewPatterns, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, ImpredicativeTypes #-} {-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}  {- |@@ -30,7 +30,7 @@ 	toList_ = concatMap (map lab . flatten) . heap 	size = elts 	peek = liftM treeMin . listToMaybe . heap-	delete (FQueue n mR (Node (Rk _ x) ts : tss)) = Just $ rebuild (n-1) mR (mapM_ meld tss >> mapM_ meld ts)+	delete (FQueue n mR (Node (Rk _ x) ts : tss)) = Just $ rebuild (MA (n-1) mR (mapM_ meld tss >> mapM_ meld ts)) 	delete _ = Nothing  treeMin :: RkTree e -> e@@ -47,7 +47,7 @@ 	| otherwise	= Node (Rk (d+1) x2) (t1:ts2)  -- The use of the ArrayM monad here considerably increases readability and efficiency.-meld :: Ord e => RkTree e -> ArrayM (Maybe (RkTree e)) ()+meld :: Ord e => RkTree e -> ArrayM s (Maybe (RkTree e)) () meld t@(rk . rootLabel -> d) = 	ensureSize (d+2) >> readAt d >>= maybe (writeAt d (Just t)) (\ t' -> writeAt d Nothing >> meld (t `meldTree` t')) @@ -57,13 +57,17 @@ 	exM (Just t@(Node (Rk d x) _)) (mi, rk, ts) = let rk' = max d rk in maybe (Just t, rk', ts)  		(\ t'@(lab . rootLabel -> y) -> if x <= y then (Just t, rk', t':ts) else (Just t', rk', t:ts)) mi -rebuild :: Ord e => Int -> Int -> ArrayM (Maybe (RkTree e)) () -> FQueue e-rebuild n mR melder = runArrayM mR Nothing $ melder >> liftM ((\ (mR', h') -> FQueue n mR' h') . extractMin) getContents+rebuild :: Ord e => MergeAccum e -> FQueue e+rebuild (MA n mR melder) = runArrayM mR Nothing $ melder >> liftM ((\ (mR', h') -> FQueue n mR' h') . extractMin) getContents +data MergeAccum e = MA {-# UNPACK #-} !Int {-# UNPACK #-} !Int (forall s . ArrayM s (Maybe (RkTree e)) ())+ {-# INLINE mergeAllFH #-} mergeAllFH :: Ord e => [FQueue e] -> FQueue e-mergeAllFH qs = case foldr merger (0, 0, return ()) qs of (n, mR, merger) -> rebuild n mR merger ; where-		merger (FQueue n r ts) (m, mR, toMerge) = (n +  m, max r mR, mapM_ meld ts >> toMerge)+mergeAllFH qs = rebuild (foldr merger (MA 0 0 (return ())) qs) where+	merger :: Ord e => FQueue e -> MergeAccum e -> MergeAccum e+	merger (FQueue n r ts) (MA m mR toMerge) = MA (n+m) (max r mR) (mapM_ meld ts >> toMerge)+	  {-# RULES 	"mergeAll/FibHeap" forall (ts :: Ord e => [FQueue e]) . mergeAll ts = mergeAllFH ts
Data/Queue/PQueue.hs view
@@ -17,7 +17,7 @@ data PHeap e = PH {elts :: {-# UNPACK #-} !Int, heap :: {-# UNPACK #-} !(Tree e)} deriving (Read, Show) newtype PQueue e = PQ {getQ :: Maybe (PHeap e)} deriving (Monoid, Read, Show) -instance Ord e => Monoid (PHeap e) where+instance Ord e => Monoid (PHeap e) where -- elegant hack to automatically derive the Monoid instance for PQueue (via Maybe) 	PH n1 h1 `mappend` PH n2 h2 = PH (n1 + n2) (h1 `meld` h2)  instance Ord e => Queuelike (PQueue e) e where@@ -26,9 +26,9 @@ 	delete (PQ h) = fmap (\ (PH (n+1) (Node _ ts)) -> mkQ n (fuser ts)) h 	isEmpty = isNothing . getQ 	size = maybe 0 elts . getQ-	fromList xs = case xs of	[] -> PQ Nothing-					_ -> case foldr (\ x (n, ys) -> (n+1, single x : ys)) (0, []) xs of-						(n, ys) -> mkQ n (fuser ys)+	fromList xs = case foldr (\ x (n, ys) -> (n+1, single x : ys)) (0, []) xs of+				(0, _)	-> PQ Nothing+				(n, ys) -> mkQ n (fuser ys) 	{-# INLINE toList_ #-} 	toList_ (PQ h) = maybe [] (flatten . heap) h 	merge = mappend@@ -40,7 +40,7 @@ mkQ n t = PQ (Just (PH n t))  meld :: Ord e => Tree e -> Tree e -> Tree e-meld t1@(Node x1 ts1) t2@(Node x2 ts2) =+t1@(Node x1 ts1) `meld` t2@(Node x2 ts2) = 	if x1 > x2 then Node x2 (t1:ts2) else Node x1 (t2:ts1)  fuser :: Ord e => Forest e -> Tree e
pqueue-mtl.cabal view
@@ -1,6 +1,6 @@  name:		pqueue-mtl-version:	1.0+version:	1.0.1 synopsis:	Fully encapsulated monad transformers with queuelike functionality. description:	Contains several implementations of data structures implementing a /single-in, single-out/ paradigm, and implements monad transformers for their safe use.  The monad transformer part of the library includes tools to fully encapsulate single-threaded use of a priority queue in a monad, including an array-based heap implementation. tested-with:	GHC@@ -9,7 +9,7 @@ license-file:	LICENSE author:		Louis Wasserman maintainer:	wasserman.louis@gmail.com-build-Depends:	base, ghc-prim, mtl, containers, stateful-mtl, MaybeT+build-Depends:	base, ghc-prim, mtl, containers, stateful-mtl >= 1.0.1 , MaybeT build-type:	Simple Exposed-modules:Control.Monad.Queue, Control.Monad.Queue.Instances, Control.Monad.Queue.Class, Control.Monad.Queue.Heap, Control.Monad.Queue.QueueT, Data.Queue, Data.Queue.PQueue, Data.Queue.FibQueue, Data.Queue.Class, Data.Queue.Instances, Data.Queue.Stack, Data.Queue.Queue, Data.Queue.ReverseQueue ghc-options: