{-# LANGUAGE DeriveDataTypeable, TypeSynonymInstances,
MultiParamTypeClasses, ExistentialQuantification,
OverloadedStrings, FlexibleInstances, UndecidableInstances #-}
module Data.Persistent.Collection (
RefQueue, getQRef,
pop,popSTM,pick, flush, flushSTM,
pickAll, pickAllSTM, push,pushSTM,
pickElem, pickElemSTM, readAll, readAllSTM,
deleteElem, deleteElemSTM,updateElem,updateElemSTM,
unreadSTM,isEmpty,isEmptySTM
) where
import Data.Typeable
import Control.Concurrent.STM(STM,atomically, retry)
import Control.Monad
import Data.TCache.DefaultPersistence
import Data.TCache
import Data.RefSerialize
instance Indexable (Queue a) where
key :: Queue a -> String
key (Queue String
k [a]
_ [a]
_)= String
queuePrefix forall a. [a] -> [a] -> [a]
++ String
k
data Queue a= Queue String [a] [a] deriving (Typeable)
instance Serialize a => Serialize (Queue a) where
showp :: Queue a -> STW ()
showp (Queue String
n [a]
i [a]
o)= forall c. Serialize c => c -> STW ()
showp String
n forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall c. Serialize c => c -> STW ()
showp [a]
i forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall c. Serialize c => c -> STW ()
showp [a]
o
readp :: STR (Queue a)
readp = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. String -> [a] -> [a] -> Queue a
Queue forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` forall c. Serialize c => STR c
readp forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` forall c. Serialize c => STR c
readp forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` forall c. Serialize c => STR c
readp
queuePrefix :: String
queuePrefix :: String
queuePrefix= String
"Queue#"
lenQPrefix :: Int
lenQPrefix :: Int
lenQPrefix= forall (t :: * -> *) a. Foldable t => t a -> Int
Prelude.length String
queuePrefix
instance Serialize a => Serializable (Queue a ) where
serialize :: Queue a -> ByteString
serialize = STW () -> ByteString
runW forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. Serialize c => c -> STW ()
showp
deserialize :: ByteString -> Queue a
deserialize = forall a. STR a -> ByteString -> a
runR forall c. Serialize c => STR c
readp
type RefQueue a= DBRef (Queue a)
unreadSTM :: (Typeable a, Serialize a) => RefQueue a -> a -> STM ()
unreadSTM :: forall a. (Typeable a, Serialize a) => RefQueue a -> a -> STM ()
unreadSTM RefQueue a
queue a
x= do
Queue a
r <- forall a. (Typeable a, Serialize a) => RefQueue a -> STM (Queue a)
readQRef RefQueue a
queue
forall a. (IResource a, Typeable a) => DBRef a -> a -> STM ()
writeDBRef RefQueue a
queue forall a b. (a -> b) -> a -> b
$ Queue a -> Queue a
doit Queue a
r
where
doit :: Queue a -> Queue a
doit (Queue String
n [a]
imp [a]
out) = forall a. String -> [a] -> [a] -> Queue a
Queue String
n [a]
imp ( a
x forall a. a -> [a] -> [a]
: [a]
out)
isEmpty :: (Typeable a, Serialize a) => RefQueue a -> IO Bool
isEmpty :: forall a. (Typeable a, Serialize a) => RefQueue a -> IO Bool
isEmpty = forall a. STM a -> IO a
atomically forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Typeable a, Serialize a) => RefQueue a -> STM Bool
isEmptySTM
isEmptySTM :: (Typeable a, Serialize a) => RefQueue a -> STM Bool
isEmptySTM :: forall a. (Typeable a, Serialize a) => RefQueue a -> STM Bool
isEmptySTM RefQueue a
queue= do
Maybe (Queue a)
r <- forall a. (IResource a, Typeable a) => DBRef a -> STM (Maybe a)
readDBRef RefQueue a
queue
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Maybe (Queue a)
r of
Maybe (Queue a)
Nothing -> Bool
True
Just (Queue String
_ [] []) -> Bool
True
Maybe (Queue a)
_ -> Bool
False
getQRef :: (Typeable a, Serialize a) => String -> RefQueue a
getQRef :: forall a. (Typeable a, Serialize a) => String -> RefQueue a
getQRef String
n = forall a. (Typeable a, IResource a) => String -> DBRef a
getDBRef forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Indexable a => a -> String
key forall a b. (a -> b) -> a -> b
$ forall a. String -> [a] -> [a] -> Queue a
Queue String
n forall a. HasCallStack => a
undefined forall a. HasCallStack => a
undefined
flush :: (Typeable a, Serialize a) => RefQueue a -> IO ()
flush :: forall a. (Typeable a, Serialize a) => RefQueue a -> IO ()
flush = forall a. STM a -> IO a
atomically forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Typeable a, Serialize a) => RefQueue a -> STM ()
flushSTM
flushSTM :: (Typeable a, Serialize a) => RefQueue a -> STM ()
flushSTM :: forall a. (Typeable a, Serialize a) => RefQueue a -> STM ()
flushSTM = forall a. (IResource a, Typeable a) => DBRef a -> STM ()
delDBRef
pop
:: (Typeable a, Serialize a) => RefQueue a
-> IO a
pop :: forall a. (Typeable a, Serialize a) => RefQueue a -> IO a
pop RefQueue a
tv = forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. (Typeable a, Serialize a) => RefQueue a -> STM a
popSTM RefQueue a
tv
readQRef :: (Typeable a, Serialize a) => RefQueue a -> STM(Queue a)
readQRef :: forall a. (Typeable a, Serialize a) => RefQueue a -> STM (Queue a)
readQRef RefQueue a
tv= do
Maybe (Queue a)
mdx <- forall a. (IResource a, Typeable a) => DBRef a -> STM (Maybe a)
readDBRef RefQueue a
tv
case Maybe (Queue a)
mdx of
Maybe (Queue a)
Nothing -> do
let q :: Queue a
q= forall a. String -> [a] -> [a] -> Queue a
Queue ( forall a. Int -> [a] -> [a]
Prelude.drop Int
lenQPrefix forall a b. (a -> b) -> a -> b
$ forall a. DBRef a -> String
keyObjDBRef RefQueue a
tv) [] []
forall a. (IResource a, Typeable a) => DBRef a -> a -> STM ()
writeDBRef RefQueue a
tv forall {a}. Queue a
q
forall (m :: * -> *) a. Monad m => a -> m a
return forall {a}. Queue a
q
Just Queue a
dx ->
forall (m :: * -> *) a. Monad m => a -> m a
return Queue a
dx
popSTM :: (Typeable a, Serialize a) => RefQueue a
-> STM a
popSTM :: forall a. (Typeable a, Serialize a) => RefQueue a -> STM a
popSTM RefQueue a
tv=do
Queue a
dx <- forall a. (Typeable a, Serialize a) => RefQueue a -> STM (Queue a)
readQRef RefQueue a
tv
Queue a -> STM a
doit Queue a
dx
where
doit :: Queue a -> STM a
doit (Queue String
n [a
x] [])= do
forall a. (IResource a, Typeable a) => DBRef a -> a -> STM ()
writeDBRef RefQueue a
tv (forall a. String -> [a] -> [a] -> Queue a
Queue String
n [] [])
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
doit (Queue String
_ [] []) = forall a. STM a
retry
doit (Queue String
n [a]
imp []) = Queue a -> STM a
doit (forall a. String -> [a] -> [a] -> Queue a
Queue String
n [] forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
Prelude.reverse [a]
imp)
doit (Queue String
n [a]
imp [a]
list ) = do
forall a. (IResource a, Typeable a) => DBRef a -> a -> STM ()
writeDBRef RefQueue a
tv (forall a. String -> [a] -> [a] -> Queue a
Queue String
n [a]
imp (forall a. [a] -> [a]
Prelude.tail [a]
list ))
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
Prelude.head [a]
list
pick
:: (Typeable a, Serialize a) => RefQueue a
-> IO a
pick :: forall a. (Typeable a, Serialize a) => RefQueue a -> IO a
pick RefQueue a
tv = forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
Queue a
dx <- forall a. (Typeable a, Serialize a) => RefQueue a -> STM (Queue a)
readQRef RefQueue a
tv
forall {a}. Queue a -> STM a
doit Queue a
dx
where
doit :: Queue a -> STM a
doit (Queue String
_ [a
x] [])= forall (m :: * -> *) a. Monad m => a -> m a
return a
x
doit (Queue String
_ [] []) = forall a. STM a
retry
doit (Queue String
n [a]
imp []) = Queue a -> STM a
doit (forall a. String -> [a] -> [a] -> Queue a
Queue String
n [] forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
Prelude.reverse [a]
imp)
doit (Queue String
_ [a]
_ [a]
list ) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
Prelude.head [a]
list
push :: (Typeable a, Serialize a) => RefQueue a -> a -> IO ()
push :: forall a. (Typeable a, Serialize a) => RefQueue a -> a -> IO ()
push RefQueue a
tv a
v = forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. (Typeable a, Serialize a) => RefQueue a -> a -> STM ()
pushSTM RefQueue a
tv a
v
pushSTM :: (Typeable a, Serialize a) => RefQueue a -> a -> STM ()
pushSTM :: forall a. (Typeable a, Serialize a) => RefQueue a -> a -> STM ()
pushSTM RefQueue a
tv a
v=
forall a. (Typeable a, Serialize a) => RefQueue a -> STM (Queue a)
readQRef RefQueue a
tv forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ (Queue String
n [a]
imp [a]
out) -> forall a. (IResource a, Typeable a) => DBRef a -> a -> STM ()
writeDBRef RefQueue a
tv forall a b. (a -> b) -> a -> b
$ forall a. String -> [a] -> [a] -> Queue a
Queue String
n (a
v forall a. a -> [a] -> [a]
: [a]
imp) [a]
out
pickAll :: (Typeable a, Serialize a) => RefQueue a -> IO [a]
pickAll :: forall a. (Typeable a, Serialize a) => RefQueue a -> IO [a]
pickAll= forall a. STM a -> IO a
atomically forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Typeable a, Serialize a) => RefQueue a -> STM [a]
pickAllSTM
pickAllSTM :: (Typeable a, Serialize a) => RefQueue a -> STM [a]
pickAllSTM :: forall a. (Typeable a, Serialize a) => RefQueue a -> STM [a]
pickAllSTM RefQueue a
tv= do
(Queue String
_ [a]
imp [a]
out) <- forall a. (Typeable a, Serialize a) => RefQueue a -> STM (Queue a)
readQRef RefQueue a
tv
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [a]
out forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [a]
Prelude.reverse [a]
imp
pickElem ::(Indexable a,Typeable a, Serialize a) => RefQueue a -> String -> IO(Maybe a)
pickElem :: forall a.
(Indexable a, Typeable a, Serialize a) =>
RefQueue a -> String -> IO (Maybe a)
pickElem RefQueue a
tv String
k= forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a.
(Indexable a, Typeable a, Serialize a) =>
RefQueue a -> String -> STM (Maybe a)
pickElemSTM RefQueue a
tv String
k
pickElemSTM :: (Indexable a,Typeable a, Serialize a)
=> RefQueue a -> String -> STM(Maybe a)
pickElemSTM :: forall a.
(Indexable a, Typeable a, Serialize a) =>
RefQueue a -> String -> STM (Maybe a)
pickElemSTM RefQueue a
tv String
key1 = do
Queue String
name [a]
imp [a]
out <- forall a. (Typeable a, Serialize a) => RefQueue a -> STM (Queue a)
readQRef RefQueue a
tv
let xs :: [a]
xs = [a]
out forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [a]
Prelude.reverse [a]
imp
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
Prelude.null [a]
imp) forall a b. (a -> b) -> a -> b
$ forall a. (IResource a, Typeable a) => DBRef a -> a -> STM ()
writeDBRef RefQueue a
tv forall a b. (a -> b) -> a -> b
$ forall a. String -> [a] -> [a] -> Queue a
Queue String
name [] [a]
xs
case forall a. (a -> Bool) -> [a] -> [a]
Prelude.filter (\a
x -> forall a. Indexable a => a -> String
key a
x forall a. Eq a => a -> a -> Bool
== String
key1) [a]
xs of
[] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
(a
x:[a]
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just a
x
updateElem :: (Indexable a,Typeable a, Serialize a)
=> RefQueue a -> a -> IO()
updateElem :: forall a.
(Indexable a, Typeable a, Serialize a) =>
RefQueue a -> a -> IO ()
updateElem RefQueue a
tv a
x = forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a.
(Indexable a, Typeable a, Serialize a) =>
RefQueue a -> a -> STM ()
updateElemSTM RefQueue a
tv a
x
updateElemSTM :: (Indexable a,Typeable a, Serialize a)
=> RefQueue a -> a -> STM()
updateElemSTM :: forall a.
(Indexable a, Typeable a, Serialize a) =>
RefQueue a -> a -> STM ()
updateElemSTM RefQueue a
tv a
v= do
Queue String
name [a]
imp [a]
out <- forall a. (Typeable a, Serialize a) => RefQueue a -> STM (Queue a)
readQRef RefQueue a
tv
let xs :: [a]
xs= [a]
out forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [a]
Prelude.reverse [a]
imp
let xs' :: [a]
xs'= forall a b. (a -> b) -> [a] -> [b]
Prelude.map (\a
x -> if forall a. Indexable a => a -> String
key a
x forall a. Eq a => a -> a -> Bool
== String
n then a
v else a
x) [a]
xs
forall a. (IResource a, Typeable a) => DBRef a -> a -> STM ()
writeDBRef RefQueue a
tv forall a b. (a -> b) -> a -> b
$ forall a. String -> [a] -> [a] -> Queue a
Queue String
name [] [a]
xs'
where
n :: String
n= forall a. Indexable a => a -> String
key a
v
readAll :: (Typeable a, Serialize a) => RefQueue a -> IO [a]
readAll :: forall a. (Typeable a, Serialize a) => RefQueue a -> IO [a]
readAll= forall a. STM a -> IO a
atomically forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Typeable a, Serialize a) => RefQueue a -> STM [a]
readAllSTM
readAllSTM :: (Typeable a, Serialize a) => RefQueue a -> STM [a]
readAllSTM :: forall a. (Typeable a, Serialize a) => RefQueue a -> STM [a]
readAllSTM RefQueue a
tv= do
Queue String
name [a]
imp [a]
out <- forall a. (Typeable a, Serialize a) => RefQueue a -> STM (Queue a)
readQRef RefQueue a
tv
forall a. (IResource a, Typeable a) => DBRef a -> a -> STM ()
writeDBRef RefQueue a
tv forall a b. (a -> b) -> a -> b
$ forall a. String -> [a] -> [a] -> Queue a
Queue String
name [] []
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [a]
out forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [a]
Prelude.reverse [a]
imp
deleteElem :: (Indexable a,Typeable a, Serialize a) => RefQueue a-> a -> IO ()
deleteElem :: forall a.
(Indexable a, Typeable a, Serialize a) =>
RefQueue a -> a -> IO ()
deleteElem RefQueue a
tv a
x= forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a.
(Typeable a, Serialize a, Indexable a) =>
RefQueue a -> a -> STM ()
deleteElemSTM RefQueue a
tv a
x
deleteElemSTM :: (Typeable a, Serialize a,Indexable a) => RefQueue a-> a -> STM ()
deleteElemSTM :: forall a.
(Typeable a, Serialize a, Indexable a) =>
RefQueue a -> a -> STM ()
deleteElemSTM RefQueue a
tv a
x= do
Queue String
name [a]
imp [a]
out <- forall a. (Typeable a, Serialize a) => RefQueue a -> STM (Queue a)
readQRef RefQueue a
tv
let xs :: [a]
xs= [a]
out forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [a]
Prelude.reverse [a]
imp
forall a. (IResource a, Typeable a) => DBRef a -> a -> STM ()
writeDBRef RefQueue a
tv forall a b. (a -> b) -> a -> b
$ forall a. String -> [a] -> [a] -> Queue a
Queue String
name [] forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
Prelude.filter (\a
x2-> forall a. Indexable a => a -> String
key a
x2 forall a. Eq a => a -> a -> Bool
/= String
k) [a]
xs
where
k :: String
k=forall a. Indexable a => a -> String
key a
x